Merge branch 'master' into debian
Norbert Preining
8 years ago
| 16 | 16 | *.status |
| 17 | 17 | *.ilg |
| 18 | 18 | *.ind |
| 19 | *.bbl | |
| 20 | *.blg | |
| 19 | 21 | *.out |
| 20 | 22 | *.toc |
| 21 | 23 | *.synctex.gz |
| 43 | 45 | manual/md/reference-manual.run.xml |
| 44 | 46 | manual/md/reference-manual.tex |
| 45 | 47 | auto |
| 48 | build-stamp | |
| 49 | doc/refman/reference-manual.bcf | |
| 50 | doc/refman/reference-manual.epub | |
| 51 | doc/refman/reference-manual.odt | |
| 52 | doc/refman/reference-manual.run.xml | |
| 53 | doc/refman/reference-manual.tex | |
| 54 | install-stamp | |
| 55 | make-cafeobj.lisp | |
| 56 | tswd | |
| 57 | version.lisp | |
| 58 | xbin/cafeobj.in | |
| 59 | dumps | |
| 0 | 0 | ;;;-*-Mode:LISP; Package: CHAOS; Base:10; Syntax:Common-lisp -*- |
| 1 | 1 | ;;; |
| 2 | ;;; Copyright (c) 2000-2014, Toshimi Sawada. All rights reserved. | |
| 2 | ;;; Copyright (c) 2000-2015, Toshimi Sawada. All rights reserved. | |
| 3 | 3 | ;;; |
| 4 | 4 | ;;; Redistribution and use in source and binary forms, with or without |
| 5 | 5 | ;;; modification, are permitted provided that the following conditions |
| 28 | 28 | ;;; |
| 29 | 29 | (in-package :chaos) |
| 30 | 30 | #|============================================================================= |
| 31 | System:Chaos | |
| 32 | Module:BigPink | |
| 33 | File:butils.lisp | |
| 31 | System:Chaos | |
| 32 | Module:BigPink | |
| 33 | File:butils.lisp | |
| 34 | 34 | =============================================================================|# |
| 35 | 35 | #-:chaos-debug |
| 36 | 36 | (declaim (optimize (speed 3) (safety 0) #-GCL (debug 0))) |
| 38 | 38 | (declaim (optimize (speed 1) (safety 3) #-GCL (debug 3))) |
| 39 | 39 | |
| 40 | 40 | ;;; ************************************************************************** |
| 41 | ;;; BASIC UTILITY FUNCTIONS | |
| 41 | ;;; BASIC UTILITY FUNCTIONS | |
| 42 | 42 | ;;; ************************************************************************** |
| 43 | 43 | |
| 44 | 44 | ;;; function specs |
| 112 | 112 | (let ((var (find-if #'(lambda (x) (variable-eq term x)) variables))) |
| 113 | 113 | (if var |
| 114 | 114 | var |
| 115 | #|| | |
| 115 | #|| | |
| 116 | 116 | (if variables |
| 117 | 117 | (with-output-panic-message-n (:p-pn-0010 (list (variable-name term))) |
| 118 | 118 | ;; (format t "copying term, could not find var ~a" |
| 120 | 120 | (break "type in :q for returning to top-level.") |
| 121 | 121 | ) |
| 122 | 122 | term) |
| 123 | ||# | |
| 124 | term ))) | |
| 123 | ||# | |
| 124 | term ))) | |
| 125 | 125 | ((term-is-application-form? term) |
| 126 | 126 | (@create-application-form-term |
| 127 | 127 | (term-head term) |
| 215 | 215 | |
| 216 | 216 | ;;; IS-SKOLEM : method module -> Bool |
| 217 | 217 | ;;; |
| 218 | (defun is-skolem (meth &optional (module (or *current-module* *last-module*))) | |
| 218 | (defun is-skolem (meth &optional (module (get-context-module))) | |
| 219 | 219 | (declare (type method meth) |
| 220 | (type module module) | |
| 220 | (type (or null module) module) | |
| 221 | 221 | (values boolean)) |
| 222 | 222 | (memq meth (module-skolem-functions module))) |
| 223 | 223 | |
| 827 | 827 | (max-kept? (pn-parameter max-kept))) |
| 828 | 828 | (declare (type fixnum max-given? max-gen? max-seconds? max-kept?)) |
| 829 | 829 | (cond ((and (not (= max-given? -1)) (>= given max-given?)) |
| 830 | (setq stat :max-given-exit)) | |
| 831 | ((and (not (= max-seconds? -1)) (>= seconds (float max-seconds?))) | |
| 832 | (setq stat :max-seconds-exit)) | |
| 833 | ((and (not (= max-gen? -1)) (>= gen max-gen?)) | |
| 830 | (setq stat :max-given-exit)) | |
| 831 | ((and (not (= max-seconds? -1)) (>= seconds (float max-seconds?))) | |
| 832 | (setq stat :max-seconds-exit)) | |
| 833 | ((and (not (= max-gen? -1)) (>= gen max-gen?)) | |
| 834 | 834 | (setq stat :max-gen-exit)) |
| 835 | 835 | ((and (not (= max-kept? -1)) (>= kept max-kept?)) |
| 836 | (setq stat :max-kept-exit))) | |
| 836 | (setq stat :max-kept-exit))) | |
| 837 | 837 | stat))) |
| 838 | 838 | |
| 839 | 839 | ;;; CHECK-FOR-PROOF : Clause -> Clause |
| 1390 | 1390 | (print-next) |
| 1391 | 1391 | (princ "strategy will be knuth-bendix with positive clauses in sos."))) |
| 1392 | 1392 | ||# |
| 1393 | ;; (auto-change-flag kb3 t) ************************** | |
| 1394 | (auto-change-flag kb2 t) | |
| 1393 | ;; (auto-change-flag kb3 t) ************************** | |
| 1394 | (auto-change-flag kb2 t) | |
| 1395 | 1395 | (when (every #'positive-clause? *usable*) |
| 1396 | 1396 | (when (pn-flag print-message) |
| 1397 | 1397 | (with-output-msg () |
| 1442 | 1442 | (print-next) |
| 1443 | 1443 | (princ "clauses in usable"))) |
| 1444 | 1444 | ||# |
| 1445 | ;; (auto-change-flag kb3 t) | |
| 1446 | (auto-change-flag kb2 t) | |
| 1445 | ;; (auto-change-flag kb3 t) | |
| 1446 | (auto-change-flag kb2 t) | |
| 1447 | 1447 | (auto-change-flag hyper-res t) |
| 1448 | 1448 | (auto-change-flag unit-deletion t) |
| 1449 | 1449 | (auto-change-flag factor t) |
| 1787 | 1787 | (princ "---")) |
| 1788 | 1788 | *full-lit-table*))) |
| 1789 | 1789 | |
| 1790 | (defun show-demodulators (&optional (mod (or *current-module* | |
| 1791 | *last-module*))) | |
| 1790 | (defun show-demodulators (&optional (mod (get-context-module t))) | |
| 1792 | 1791 | (unless mod (return-from show-demodulators nil)) |
| 1793 | 1792 | (with-in-module (mod) |
| 1794 | 1793 | (let* ((psys (module-proof-system mod)) |
| 1852 | 1851 | (format t " factor simplify~20t~,3f sec." |
| 1853 | 1852 | (time-in-seconds (pn-clock-value factor-simp-time))) |
| 1854 | 1853 | ;;(format t " wight cl time~20t,~3f sec." |
| 1855 | ;; (time-in-seconds (pn-clock-value weigh-cl-time))) | |
| 1854 | ;; (time-in-seconds (pn-clock-value weigh-cl-time))) | |
| 1856 | 1855 | ;; (format t " sort lits time~20t~,3f sec." |
| 1857 | ;; (time-in-seconds (pn-clock-value sort-lits-time))) | |
| 1856 | ;; (time-in-seconds (pn-clock-value sort-lits-time))) | |
| 1858 | 1857 | (print-next) |
| 1859 | 1858 | (format t " forward subsume~20t~,3f sec." |
| 1860 | 1859 | (time-in-seconds (pn-clock-value for-sub-time))) |
| 0 | 0 | ;;;-*-Mode:LISP; Package: CHAOS; Base:10; Syntax:Common-lisp -*- |
| 1 | 1 | ;;; |
| 2 | ;;; Copyright (c) 2000-2014, Toshimi Sawada. All rights reserved. | |
| 2 | ;;; Copyright (c) 2000-2015, Toshimi Sawada. All rights reserved. | |
| 3 | 3 | ;;; |
| 4 | 4 | ;;; Redistribution and use in source and binary forms, with or without |
| 5 | 5 | ;;; modification, are permitted provided that the following conditions |
| 28 | 28 | ;;; |
| 29 | 29 | (in-package :chaos) |
| 30 | 30 | #|============================================================================= |
| 31 | System:Chaos | |
| 32 | Module:BigPink | |
| 33 | File:formula.lisp | |
| 31 | System:Chaos | |
| 32 | Module:BigPink | |
| 33 | File:formula.lisp | |
| 34 | 34 | =============================================================================|# |
| 35 | 35 | #-:chaos-debug |
| 36 | 36 | (declaim (optimize (speed 3) (safety 0) #-GCL (debug 0))) |
| 37 | 37 | #+:chaos-debug |
| 38 | 38 | (declaim (optimize (speed 1) (safety 3) #-GCL (debug 3))) |
| 39 | 39 | |
| 40 | ;;; ************************************* | |
| 41 | ;;; Utility functions on CLAUSE & LITERAL | |
| 40 | ;;; ************************************* | |
| 41 | ;;; Utility functions on CLAUSE & LITERAL | |
| 42 | 42 | ;;; ************************************* |
| 43 | 43 | |
| 44 | 44 | ;;; IS-EQUALITY : term -> {:equal, :non-equal, :beh-equal} |
| 1167 | 1167 | (setf (svref .map-array. x) nil)) |
| 1168 | 1168 | (if (map-rest c d nil) |
| 1169 | 1169 | (progn |
| 1170 | ;; every literal of c matches some literal of d | |
| 1171 | ;; thus c subsumes d. | |
| 1170 | ;; every literal of c matches some literal of d | |
| 1171 | ;; thus c subsumes d. | |
| 1172 | 1172 | (when (pn-flag debug-infer) |
| 1173 | 1173 | (with-output-simple-msg () |
| 1174 | 1174 | (princ "*subsume?: ") |
| 0 | 0 | ;;;-*-Mode:LISP; Package: CHAOS; Base:10; Syntax:Common-lisp -*- |
| 1 | 1 | ;;; |
| 2 | ;;; Copyright (c) 2000-2014, Toshimi Sawada. All rights reserved. | |
| 2 | ;;; Copyright (c) 2000-2015, Toshimi Sawada. All rights reserved. | |
| 3 | 3 | ;;; |
| 4 | 4 | ;;; Redistribution and use in source and binary forms, with or without |
| 5 | 5 | ;;; modification, are permitted provided that the following conditions |
| 28 | 28 | ;;; |
| 29 | 29 | (in-package :chaos) |
| 30 | 30 | #|============================================================================= |
| 31 | System:Chaos | |
| 32 | Module:BigPink | |
| 33 | File:commands.lisp | |
| 31 | System:Chaos | |
| 32 | Module:BigPink | |
| 33 | File:commands.lisp | |
| 34 | 34 | =============================================================================|# |
| 35 | 35 | #-:chaos-debug |
| 36 | 36 | (declaim (optimize (speed 3) (safety 0) #-GCL (debug 0))) |
| 37 | 37 | #+:chaos-debug |
| 38 | 38 | (declaim (optimize (speed 1) (safety 3) #-GCL (debug 3))) |
| 39 | 39 | |
| 40 | ;;; **************** | |
| 41 | ;;; PigNose Commands | |
| 42 | ;;; **************** | |
| 40 | ;;; **************** | |
| 41 | ;;; PigNose Commands | |
| 42 | ;;; **************** | |
| 43 | 43 | |
| 44 | 44 | ;;; ================== |
| 45 | 45 | ;;; COMMAND SYNTAX ADT |
| 49 | 49 | ;;; ---------- |
| 50 | 50 | (defterm fax (%ast) |
| 51 | 51 | :visible (sentence |
| 52 | behavioural | |
| 53 | &optional goal label) | |
| 52 | behavioural | |
| 53 | &optional goal label) | |
| 54 | 54 | :eval eval-fax) |
| 55 | 55 | |
| 56 | 56 | ;;; input should be |
| 59 | 59 | ;;; |
| 60 | 60 | (defun pignose-process-fax-proc (input) |
| 61 | 61 | (declare (type list input) |
| 62 | (values list)) | |
| 62 | (values list)) | |
| 63 | 63 | (let ((lhs nil) |
| 64 | (label nil)) | |
| 64 | (label nil)) | |
| 65 | 65 | (setq lhs (second input)) |
| 66 | 66 | (when (and (not (equal (first lhs) "(")) |
| 67 | (equal (first lhs) "[") | |
| 68 | (equal (third lhs) "]") | |
| 69 | (equal (fourth lhs) ":")) | |
| 67 | (equal (first lhs) "[") | |
| 68 | (equal (third lhs) "]") | |
| 69 | (equal (fourth lhs) ":")) | |
| 70 | 70 | (setf label (list (intern (string (second lhs))))) |
| 71 | 71 | (setf lhs (nthcdr 4 lhs))) |
| 72 | 72 | (%fax* lhs |
| 73 | (char= #\b (char (first input) 0)) | |
| 74 | nil | |
| 75 | label)) | |
| 73 | (char= #\b (char (first input) 0)) | |
| 74 | nil | |
| 75 | label)) | |
| 76 | 76 | ) |
| 77 | 77 | |
| 78 | 78 | (defun pignose-eval-fax-proc (input) |
| 79 | 79 | (declare (type list input) |
| 80 | (values t)) | |
| 80 | (values t)) | |
| 81 | 81 | (eval-ast (pignose-process-fax-proc input))) |
| 82 | 82 | |
| 83 | 83 | (defun pignose-process-goal-proc (input) |
| 84 | 84 | (declare (type list input) |
| 85 | (values list)) | |
| 85 | (values list)) | |
| 86 | 86 | (let ((lhs nil) |
| 87 | (label nil)) | |
| 87 | (label nil)) | |
| 88 | 88 | (setq lhs (second input)) |
| 89 | 89 | (when (and (not (equal (first lhs) "(")) |
| 90 | (equal (first lhs) "[") | |
| 91 | (equal (third lhs) "]") | |
| 92 | (equal (fourth lhs) ":")) | |
| 90 | (equal (first lhs) "[") | |
| 91 | (equal (third lhs) "]") | |
| 92 | (equal (fourth lhs) ":")) | |
| 93 | 93 | (setf label (list (intern (string (second lhs))))) |
| 94 | 94 | (setf lhs (nthcdr 4 lhs))) |
| 95 | 95 | (%fax* lhs |
| 96 | (char= #\b (char (first input) 0)) | |
| 97 | t | |
| 98 | label) | |
| 96 | (char= #\b (char (first input) 0)) | |
| 97 | t | |
| 98 | label) | |
| 99 | 99 | )) |
| 100 | 100 | |
| 101 | 101 | (defun pignose-eval-goal-proc (input) |
| 102 | 102 | (declare (type list input) |
| 103 | (values t)) | |
| 103 | (values t)) | |
| 104 | 104 | (eval-ast (pignose-process-goal-proc input))) |
| 105 | 105 | |
| 106 | 106 | ;;; sos = "{" . "," ..."}" |
| 109 | 109 | ;;; ---------------------- |
| 110 | 110 | (defterm sos (%script) |
| 111 | 111 | :visible (operation |
| 112 | clause-list | |
| 113 | type) ; :sos or :passive | |
| 112 | clause-list | |
| 113 | type) ; :sos or :passive | |
| 114 | 114 | :eval eval-sos) |
| 115 | 115 | |
| 116 | 116 | ;;; pre-args ::= "sos" "=" "{" <real-args> "}" |
| 117 | 117 | (defun pignose-parse-sos (pre-args) |
| 118 | 118 | (declare (type list pre-args) |
| 119 | (values t)) | |
| 119 | (values t)) | |
| 120 | 120 | (let ((args nil) |
| 121 | (op nil) | |
| 122 | (ast nil) | |
| 123 | (type (if (equal (first pre-args) "sos") | |
| 124 | :sos | |
| 125 | :passive))) | |
| 121 | (op nil) | |
| 122 | (ast nil) | |
| 123 | (type (if (equal (first pre-args) "sos") | |
| 124 | :sos | |
| 125 | :passive))) | |
| 126 | 126 | (declare (type list args ast) |
| 127 | (type symbol op)) | |
| 127 | (type symbol op)) | |
| 128 | 128 | (case-equal (the simple-string (second pre-args)) |
| 129 | ("=" (setq op :set)) | |
| 130 | ("+" (setq op :add)) | |
| 131 | ("-" (setq op :delete)) | |
| 132 | (t (with-output-chaos-error ('internal) | |
| 133 | (format t "sos op given ivalid op ~a" (second pre-args))))) | |
| 129 | ("=" (setq op :set)) | |
| 130 | ("+" (setq op :add)) | |
| 131 | ("-" (setq op :delete)) | |
| 132 | (t (with-output-chaos-error ('internal) | |
| 133 | (format t "sos op given ivalid op ~a" (second pre-args))))) | |
| 134 | 134 | (setq pre-args (cdddr pre-args)) |
| 135 | 135 | (dolist (a pre-args) |
| 136 | 136 | (unless (equal "," a) |
| 137 | (push a args))) | |
| 138 | (pop args) ; pop last "}" | |
| 137 | (push a args))) | |
| 138 | (pop args) ; pop last "}" | |
| 139 | 139 | (setq ast (%sos* op (nreverse args) type)) |
| 140 | 140 | ast)) |
| 141 | 141 | |
| 156 | 156 | ;;; |
| 157 | 157 | (defun pignose-parse-clause (inp) |
| 158 | 158 | (declare (type list inp) |
| 159 | (values t)) | |
| 159 | (values t)) | |
| 160 | 160 | (%clause-print* (cadr inp))) |
| 161 | 161 | |
| 162 | 162 | ;;; resolve |
| 195 | 195 | (defun pignose-parse-list-command (inp) |
| 196 | 196 | (declare (type list inp)) |
| 197 | 197 | (let ((arg (cadr inp)) |
| 198 | (ast nil)) | |
| 198 | (ast nil)) | |
| 199 | 199 | (declare (type t arg) |
| 200 | (type list ast)) | |
| 200 | (type list ast)) | |
| 201 | 201 | (case-equal arg |
| 202 | 202 | (("axioms" "axiom") (setq arg :axiom)) |
| 203 | 203 | ("sos" (setq arg :sos)) |
| 208 | 208 | (("option" "options") (setq arg :option)) |
| 209 | 209 | (("demod" "demodulator" "demodulators") (setq arg :demod)) |
| 210 | 210 | (t (with-output-chaos-error ('invalid-list-option) |
| 211 | (format t "invalid list option ~a" arg)))) | |
| 211 | (format t "invalid list option ~a" arg)))) | |
| 212 | 212 | (setq ast (%pn-list* arg)) |
| 213 | 213 | ast)) |
| 214 | 214 | |
| 223 | 223 | (declare (type t name)) |
| 224 | 224 | (when (equal name ".") |
| 225 | 225 | (with-output-chaos-warning () |
| 226 | (format t "option name `.' is not allowed.") | |
| 227 | (return-from pignose-parse-save-option nil))) | |
| 226 | (format t "option name `.' is not allowed.") | |
| 227 | (return-from pignose-parse-save-option nil))) | |
| 228 | 228 | (%pn-option* :save name))) |
| 229 | 229 | |
| 230 | 230 | (defun pignose-parse-option (inp) |
| 231 | 231 | (declare (type list inp)) |
| 232 | 232 | (let* ((arg (second inp)) |
| 233 | (arg-1 (first arg))) | |
| 233 | (arg-1 (first arg))) | |
| 234 | 234 | (declare (type t arg arg-1)) |
| 235 | 235 | (cond ((equal arg-1 "=") |
| 236 | (let ((name (second arg))) | |
| 237 | (unless name | |
| 238 | (with-output-chaos-error ('insuf-arg) | |
| 239 | (princ "insufficient arguments to option command"))) | |
| 240 | (%pn-option* :restore name))) | |
| 241 | ((or (equal arg-1 ".") | |
| 242 | (equal arg-1 "reset")) | |
| 243 | (%pn-option* :reset)) | |
| 244 | (t (with-output-chaos-error ('inv-arg) | |
| 245 | (format t "invalid argument to option command ~{~a~}" arg)))))) | |
| 236 | (let ((name (second arg))) | |
| 237 | (unless name | |
| 238 | (with-output-chaos-error ('insuf-arg) | |
| 239 | (princ "insufficient arguments to option command"))) | |
| 240 | (%pn-option* :restore name))) | |
| 241 | ((or (equal arg-1 ".") | |
| 242 | (equal arg-1 "reset")) | |
| 243 | (%pn-option* :reset)) | |
| 244 | (t (with-output-chaos-error ('inv-arg) | |
| 245 | (format t "invalid argument to option command ~{~a~}" arg)))))) | |
| 246 | 246 | |
| 247 | 247 | ;;; flag(name, value) |
| 248 | 248 | ;;; |
| 253 | 253 | (defun pignose-parse-flag (inp) |
| 254 | 254 | (declare (type list inp)) |
| 255 | 255 | (let ((name (third inp)) |
| 256 | (value (fifth inp))) | |
| 256 | (value (fifth inp))) | |
| 257 | 257 | (%pn-set-flag* name value))) |
| 258 | 258 | |
| 259 | 259 | ;;; param(name, value) |
| 264 | 264 | |
| 265 | 265 | (defun pignose-parse-param (inp) |
| 266 | 266 | (let ((name (third inp)) |
| 267 | (value (fifth inp))) | |
| 267 | (value (fifth inp))) | |
| 268 | 268 | (%pn-assign* name value))) |
| 269 | 269 | |
| 270 | 270 | ;;; sigmatch '(' M1 ')' 'to' '(' M2 ')' |
| 277 | 277 | (defun pignose-parse-sigmatch (inp) |
| 278 | 278 | (declare (type list inp)) |
| 279 | 279 | (let ((mod1 (parse-modexp (nth 2 inp))) |
| 280 | (mod2 (parse-modexp (nth 6 inp)))) | |
| 280 | (mod2 (parse-modexp (nth 6 inp)))) | |
| 281 | 281 | (%sigmatch* mod1 mod2))) |
| 282 | 282 | |
| 283 | 283 | ;;; lex [in <MODEXP>] : '(' op1, ..., *, opn ')' |
| 284 | 284 | (defterm pn-lex (%script) |
| 285 | :visible ( ; module : TODO*** | |
| 286 | ops) | |
| 285 | :visible ( ; module : TODO*** | |
| 286 | ops) | |
| 287 | 287 | :eval eval-pn-lex) |
| 288 | 288 | |
| 289 | 289 | (defun pignose-parse-lex (inp) |
| 290 | 290 | (declare (type list inp) |
| 291 | (values t)) | |
| 291 | (values t)) | |
| 292 | 292 | (let ((ops nil) |
| 293 | (ast nil)) | |
| 294 | (dolist (elt (cddr inp)) ; skip "lex" "(" | |
| 293 | (ast nil)) | |
| 294 | (dolist (elt (cddr inp)) ; skip "lex" "(" | |
| 295 | 295 | (unless (equal "," elt) |
| 296 | (push elt ops))) | |
| 297 | (pop ops) ; last ")" | |
| 296 | (push elt ops))) | |
| 297 | (pop ops) ; last ")" | |
| 298 | 298 | (setq ast (%pn-lex* (nreverse ops))) |
| 299 | 299 | ast)) |
| 300 | 300 | |
| 303 | 303 | ;;; ============================= |
| 304 | 304 | |
| 305 | 305 | ;;; EVAL-FAX |
| 306 | (defun eval-fax (ast) | |
| 306 | ||
| 307 | (defun parse-fax-declaration (ast) | |
| 307 | 308 | (declare (type list ast)) |
| 308 | 309 | (let ((sentence (%fax-sentence ast)) |
| 309 | (behavioural (%fax-behavioural ast)) | |
| 310 | (label (%fax-label ast)) | |
| 311 | (goal? (%fax-goal ast))) | |
| 312 | (I-miss-current-module eval-fax) | |
| 310 | (behavioural (%fax-behavioural ast)) | |
| 311 | (label (%fax-label ast)) | |
| 312 | (goal? (%fax-goal ast))) | |
| 313 | (I-miss-current-module parse-fax-declaration) | |
| 313 | 314 | ;; include fopl-clause unless already be imported. |
| 314 | 315 | (include-fopl) |
| 315 | ;; | |
| 316 | 316 | (prepare-for-parsing *current-module*) |
| 317 | 317 | (let ((sort *cosmos*) |
| 318 | (*parse-variables* nil) | |
| 319 | (*parse-lhs-attr-vars* nil) | |
| 320 | (*lhs-attrid-vars* nil) | |
| 321 | (real-lhs nil) | |
| 322 | (ax nil)) | |
| 318 | (*parse-variables* nil) | |
| 319 | (*parse-lhs-attr-vars* nil) | |
| 320 | (*lhs-attrid-vars* nil) | |
| 321 | (real-lhs nil) | |
| 322 | (ax nil)) | |
| 323 | 323 | (let ((parsed-sentence (simple-parse *current-module* |
| 324 | sentence | |
| 325 | sort))) | |
| 326 | (when (term-ill-defined parsed-sentence) | |
| 327 | (with-output-chaos-error ('invalid-formula) | |
| 328 | (princ "no parse for FOPL formula") | |
| 329 | (print-next) | |
| 330 | (princ sentence))) | |
| 331 | (unless (sort<= (term-sort parsed-sentence) | |
| 332 | *fopl-sentence-sort* | |
| 333 | (module-sort-order *current-module*)) | |
| 334 | (with-output-chaos-error ('invalid-formula) | |
| 335 | (princ "sort of axiom must be (subsort of) FoplSentence.") | |
| 336 | (print-next) | |
| 337 | (princ sentence))) | |
| 338 | #|| | |
| 339 | (if goal? | |
| 340 | (setq real-lhs | |
| 341 | (make-term-with-sort-check *fopl-neg* | |
| 342 | (list parsed-sentence))) | |
| 343 | (setq real-lhs parsed-sentence)) | |
| 344 | ||# | |
| 345 | (setq real-lhs parsed-sentence) | |
| 346 | ;; | |
| 347 | (setq ax (make-pignose-axiom real-lhs | |
| 348 | :behavioural behavioural | |
| 349 | :label label | |
| 350 | :type (if goal? | |
| 351 | :pignose-goal | |
| 352 | :pignose-axiom))) | |
| 353 | (check-axiom-error-method *current-module* | |
| 354 | ax | |
| 355 | t) | |
| 356 | (add-axiom-to-module *current-module* ax) | |
| 357 | (set-needs-rule) | |
| 358 | ax)))) | |
| 324 | sentence | |
| 325 | sort))) | |
| 326 | (when (term-ill-defined parsed-sentence) | |
| 327 | (with-output-chaos-error ('invalid-formula) | |
| 328 | (princ "no parse for FOPL formula") | |
| 329 | (print-next) | |
| 330 | (princ sentence))) | |
| 331 | (unless (sort<= (term-sort parsed-sentence) | |
| 332 | *fopl-sentence-sort* | |
| 333 | (module-sort-order *current-module*)) | |
| 334 | (with-output-chaos-error ('invalid-formula) | |
| 335 | (princ "sort of axiom must be (subsort of) FoplSentence.") | |
| 336 | (print-next) | |
| 337 | (princ sentence))) | |
| 338 | #|| | |
| 339 | (if goal? | |
| 340 | (setq real-lhs | |
| 341 | (make-term-with-sort-check *fopl-neg* | |
| 342 | (list parsed-sentence))) | |
| 343 | (setq real-lhs parsed-sentence)) | |
| 344 | ||# | |
| 345 | (setq real-lhs parsed-sentence) | |
| 346 | ;; | |
| 347 | (setq ax (make-pignose-axiom real-lhs | |
| 348 | :behavioural behavioural | |
| 349 | :label label | |
| 350 | :type (if goal? | |
| 351 | :pignose-goal | |
| 352 | :pignose-axiom))) | |
| 353 | (check-axiom-error-method *current-module* | |
| 354 | ax | |
| 355 | t) | |
| 356 | ax)))) | |
| 357 | ||
| 358 | (defun eval-fax (ast) | |
| 359 | (let ((ax (parse-fax-declaration ast))) | |
| 360 | (add-axiom-to-module *current-module* ax) | |
| 361 | (set-needs-rule) | |
| 362 | ax)) | |
| 359 | 363 | |
| 360 | 364 | ;;; reset |
| 361 | 365 | (defun eval-pndb (ast) |
| 370 | 374 | ;;; |
| 371 | 375 | (defun eval-sos (ast) |
| 372 | 376 | (flet ((is-nat (tok) |
| 373 | (and (stringp tok) | |
| 374 | (every #'digit-char-p tok)))) | |
| 377 | (and (stringp tok) | |
| 378 | (every #'digit-char-p tok)))) | |
| 375 | 379 | (let ((args (%sos-clause-list ast)) |
| 376 | (op (%sos-operation ast)) | |
| 377 | (type (%sos-type ast)) | |
| 378 | (real-set nil) | |
| 379 | (psys nil) | |
| 380 | (put-sysgoal-in-sos nil)) | |
| 380 | (op (%sos-operation ast)) | |
| 381 | (type (%sos-type ast)) | |
| 382 | (real-set nil) | |
| 383 | (psys nil) | |
| 384 | (put-sysgoal-in-sos nil)) | |
| 381 | 385 | (unless *current-module* |
| 382 | (with-output-chaos-error ('no-context) | |
| 383 | (princ "no context (current) module is set!"))) | |
| 386 | (with-output-chaos-error ('no-context) | |
| 387 | (princ "no context (current) module is set!"))) | |
| 384 | 388 | (with-in-module (*current-module*) |
| 385 | (auto-db-reset *current-module*) | |
| 386 | (setq psys (module-proof-system *current-module*)) | |
| 387 | #|| | |
| 388 | (unless psys | |
| 389 | (with-output-chaos-error ('no-psys) | |
| 390 | (princ "no proof system prepared, do `db reset' first!")) | |
| 391 | ) | |
| 392 | ||# | |
| 393 | ;; | |
| 394 | (setq args (flatten-list args)) | |
| 395 | (dolist (arg args) | |
| 396 | (cond ((is-nat arg) | |
| 397 | (let ((cid nil) | |
| 398 | (clause nil)) | |
| 399 | (setq cid (read-from-string arg)) | |
| 400 | (setq clause | |
| 401 | (get-clause cid | |
| 402 | (psystem-clause-hash psys))) | |
| 403 | (unless clause | |
| 404 | (with-output-chaos-error ('unvalid-clause-id) | |
| 405 | (format t "no such claus with Id ~d." cid))) | |
| 406 | (push clause real-set))) | |
| 407 | ((null arg) ; setting empty | |
| 408 | ; do nothing | |
| 409 | ) | |
| 410 | (t (let ((label (intern arg)) | |
| 411 | (cl-list nil)) | |
| 412 | (declare (type symbol label) | |
| 413 | (type list cl-list)) | |
| 414 | (if (and (eq label '|:SYSTEM-GOAL|) | |
| 415 | (eq type :sos)) | |
| 416 | (setq put-sysgoal-in-sos t) | |
| 417 | (progn | |
| 418 | (setq cl-list (find-clause label psys)) | |
| 419 | (if cl-list | |
| 420 | (dolist (cl cl-list) | |
| 421 | (push cl real-set)) | |
| 422 | ;; assume let variable | |
| 423 | (let ((val (get-bound-value arg))) | |
| 424 | (unless val | |
| 425 | (with-output-chaos-error ('unboud) | |
| 426 | (format t "could not find let variable ~a" arg))) | |
| 427 | (setq val | |
| 428 | (copy-term-reusing-variables val | |
| 429 | (term-variables val))) | |
| 430 | ;; convert to clause form. | |
| 431 | (unless (and | |
| 432 | (is-valid-formula? val | |
| 433 | *current-module*) | |
| 434 | (check-fopl-syntax val)) | |
| 435 | (with-output-chaos-error ('invalid-formula) | |
| 436 | (princ "specified term is not valid as formula.") | |
| 437 | (term-print val))) | |
| 438 | (dolist (cl (formula->clause-1 val psys)) | |
| 439 | (push cl real-set))))))))) | |
| 440 | ) | |
| 441 | ;; | |
| 442 | (dolist (cl (if (eq type :sos) | |
| 443 | (psystem-sos psys) | |
| 444 | (psystem-passive psys))) | |
| 445 | (setf (clause-container cl) nil)) | |
| 446 | ;; | |
| 447 | (case op | |
| 448 | (:set (if (eq type :sos) | |
| 449 | (setf (psystem-sos psys) (nreverse real-set)) | |
| 450 | (setf (psystem-passive psys) (nreverse real-set)))) | |
| 451 | (:add (if (eq type :sos) | |
| 452 | (setf (psystem-sos psys) | |
| 453 | (union (psystem-sos psys) | |
| 454 | (nreverse real-set) | |
| 455 | :test #'clause-equal)) | |
| 456 | (setf (psystem-passive psys) | |
| 457 | (union (psystem-passive psys) | |
| 458 | (nreverse real-set) | |
| 459 | :test #'clause-equal)))) | |
| 460 | (:delete (if (eq type :sos) | |
| 461 | (setf (psystem-sos psys) | |
| 462 | (set-difference (psystem-sos psys) | |
| 463 | (nreverse real-set) | |
| 464 | :test #'clause-equal)) | |
| 465 | (setf (psystem-passive psys) | |
| 466 | (set-difference (psystem-passive psys) | |
| 467 | (nreverse real-set) | |
| 468 | :test #'clause-equal))) | |
| 469 | (when put-sysgoal-in-sos | |
| 470 | (setq put-sysgoal-in-sos nil))) | |
| 471 | ) | |
| 472 | ;; | |
| 473 | (if (eq type :sos) | |
| 474 | (dolist (cl (psystem-sos psys)) | |
| 475 | (setf (clause-container cl) :sos)) | |
| 476 | (dolist (cl (psystem-passive psys)) | |
| 477 | (setf (clause-container cl) :passive))) | |
| 478 | ||
| 479 | ;; setting sos/passive implies initial value of usable slot. | |
| 480 | (dolist (cl (psystem-usable psys)) | |
| 481 | (setf (clause-container cl) nil)) | |
| 482 | (setf (psystem-usable psys) | |
| 483 | (set-difference (psystem-axioms psys) | |
| 484 | (append (psystem-passive psys) | |
| 485 | (psystem-sos psys)) | |
| 486 | :test #'clause-equal)) | |
| 487 | (dolist (cl (psystem-usable psys)) | |
| 488 | (setf (clause-container cl) :usable)) | |
| 489 | ;; we sort sos usable in | |
| 490 | ;; *NOT YET* | |
| 491 | (setf (psystem-sos psys) | |
| 492 | (sort (psystem-sos psys) | |
| 493 | #'(lambda (x y) | |
| 494 | (< (clause-id x) (clause-id y))))) | |
| 495 | (setf (psystem-usable psys) | |
| 496 | (sort (psystem-usable psys) | |
| 497 | #'(lambda (x y) | |
| 498 | (< (clause-id x) (clause-id y))))) | |
| 499 | (setf (psystem-passive psys) | |
| 500 | (sort (psystem-passive psys) | |
| 501 | #'(lambda (x y) | |
| 502 | (< (clause-id x) (clause-id y))))) | |
| 503 | ;; | |
| 504 | (when put-sysgoal-in-sos | |
| 505 | (push :system-goal (psystem-sos psys))) | |
| 506 | ;; | |
| 507 | psys | |
| 508 | )))) | |
| 389 | (auto-db-reset *current-module*) | |
| 390 | (setq psys (module-proof-system *current-module*)) | |
| 391 | (setq args (flatten-list args)) | |
| 392 | (dolist (arg args) | |
| 393 | (cond ((is-nat arg) | |
| 394 | (let ((cid nil) | |
| 395 | (clause nil)) | |
| 396 | (setq cid (read-from-string arg)) | |
| 397 | (setq clause | |
| 398 | (get-clause cid | |
| 399 | (psystem-clause-hash psys))) | |
| 400 | (unless clause | |
| 401 | (with-output-chaos-error ('unvalid-clause-id) | |
| 402 | (format t "no such claus with Id ~d." cid))) | |
| 403 | (push clause real-set))) | |
| 404 | ((null arg) ; setting empty | |
| 405 | ; do nothing | |
| 406 | ) | |
| 407 | (t (let ((label (intern arg)) | |
| 408 | (cl-list nil)) | |
| 409 | (declare (type symbol label) | |
| 410 | (type list cl-list)) | |
| 411 | (if (and (eq label '|:SYSTEM-GOAL|) | |
| 412 | (eq type :sos)) | |
| 413 | (setq put-sysgoal-in-sos t) | |
| 414 | (progn | |
| 415 | (setq cl-list (find-clause label psys)) | |
| 416 | (if cl-list | |
| 417 | (dolist (cl cl-list) | |
| 418 | (push cl real-set)) | |
| 419 | ;; assume let variable | |
| 420 | (let ((val (get-bound-value arg))) | |
| 421 | (unless val | |
| 422 | (with-output-chaos-error ('unboud) | |
| 423 | (format t "could not find let variable ~a" arg))) | |
| 424 | (setq val | |
| 425 | (copy-term-reusing-variables val | |
| 426 | (term-variables val))) | |
| 427 | ;; convert to clause form. | |
| 428 | (unless (and | |
| 429 | (is-valid-formula? val | |
| 430 | *current-module*) | |
| 431 | (check-fopl-syntax val)) | |
| 432 | (with-output-chaos-error ('invalid-formula) | |
| 433 | (princ "specified term is not valid as formula.") | |
| 434 | (term-print val))) | |
| 435 | (dolist (cl (formula->clause-1 val psys)) | |
| 436 | (push cl real-set)))))))))) | |
| 437 | ;; | |
| 438 | (dolist (cl (if (eq type :sos) | |
| 439 | (psystem-sos psys) | |
| 440 | (psystem-passive psys))) | |
| 441 | (setf (clause-container cl) nil)) | |
| 442 | ;; | |
| 443 | (case op | |
| 444 | (:set (if (eq type :sos) | |
| 445 | (setf (psystem-sos psys) (nreverse real-set)) | |
| 446 | (setf (psystem-passive psys) (nreverse real-set)))) | |
| 447 | (:add (if (eq type :sos) | |
| 448 | (setf (psystem-sos psys) | |
| 449 | (union (psystem-sos psys) | |
| 450 | (nreverse real-set) | |
| 451 | :test #'clause-equal)) | |
| 452 | (setf (psystem-passive psys) | |
| 453 | (union (psystem-passive psys) | |
| 454 | (nreverse real-set) | |
| 455 | :test #'clause-equal)))) | |
| 456 | (:delete (if (eq type :sos) | |
| 457 | (setf (psystem-sos psys) | |
| 458 | (set-difference (psystem-sos psys) | |
| 459 | (nreverse real-set) | |
| 460 | :test #'clause-equal)) | |
| 461 | (setf (psystem-passive psys) | |
| 462 | (set-difference (psystem-passive psys) | |
| 463 | (nreverse real-set) | |
| 464 | :test #'clause-equal))) | |
| 465 | (when put-sysgoal-in-sos | |
| 466 | (setq put-sysgoal-in-sos nil)))) | |
| 467 | ;; | |
| 468 | (if (eq type :sos) | |
| 469 | (dolist (cl (psystem-sos psys)) | |
| 470 | (setf (clause-container cl) :sos)) | |
| 471 | (dolist (cl (psystem-passive psys)) | |
| 472 | (setf (clause-container cl) :passive))) | |
| 473 | ||
| 474 | ;; setting sos/passive implies initial value of usable slot. | |
| 475 | (dolist (cl (psystem-usable psys)) | |
| 476 | (setf (clause-container cl) nil)) | |
| 477 | (setf (psystem-usable psys) | |
| 478 | (set-difference (psystem-axioms psys) | |
| 479 | (append (psystem-passive psys) | |
| 480 | (psystem-sos psys)) | |
| 481 | :test #'clause-equal)) | |
| 482 | (dolist (cl (psystem-usable psys)) | |
| 483 | (setf (clause-container cl) :usable)) | |
| 484 | ;; we sort sos usable in | |
| 485 | ;; *NOT YET* | |
| 486 | (setf (psystem-sos psys) | |
| 487 | (sort (psystem-sos psys) | |
| 488 | #'(lambda (x y) | |
| 489 | (< (clause-id x) (clause-id y))))) | |
| 490 | (setf (psystem-usable psys) | |
| 491 | (sort (psystem-usable psys) | |
| 492 | #'(lambda (x y) | |
| 493 | (< (clause-id x) (clause-id y))))) | |
| 494 | (setf (psystem-passive psys) | |
| 495 | (sort (psystem-passive psys) | |
| 496 | #'(lambda (x y) | |
| 497 | (< (clause-id x) (clause-id y))))) | |
| 498 | ;; | |
| 499 | (when put-sysgoal-in-sos | |
| 500 | (push :system-goal (psystem-sos psys))) | |
| 501 | ;; | |
| 502 | psys)))) | |
| 509 | 503 | |
| 510 | 504 | ;;; EVAL-CLAUSE-SHOW |
| 511 | 505 | ;;; |
| 513 | 507 | (let ((pre-term (%clause-print-term ast))) |
| 514 | 508 | (unless *current-module* |
| 515 | 509 | (with-output-chaos-error ('no-context) |
| 516 | (princ "no context module is given."))) | |
| 510 | (princ "no context module is given."))) | |
| 517 | 511 | (prepare-for-parsing *current-module*) |
| 518 | #|| | |
| 519 | (unless (module-proof-system *current-module*) | |
| 520 | (with-output-chaos-error ('no-psys) | |
| 521 | (princ "no proof system prepared, do `db reset' first!"))) | |
| 522 | ||# | |
| 523 | 512 | (auto-db-reset *current-module*) |
| 524 | 513 | (with-in-module (*current-module*) |
| 525 | 514 | (let* ((*parse-variables* nil) |
| 526 | (term (simple-parse *current-module* pre-term *cosmos*))) | |
| 527 | (when (or (null (term-sort term)) | |
| 528 | (sort<= (term-sort term) | |
| 529 | *syntax-err-sort* *chaos-sort-order*)) | |
| 530 | (return-from eval-clause-show nil)) | |
| 531 | (when *mel-sort* | |
| 532 | (!setup-reduction *current-module*) | |
| 533 | (setq term (apply-sort-memb term *current-module*))) | |
| 534 | (unless (check-fopl-syntax term) | |
| 535 | (with-output-chaos-error ('invalid-formula) | |
| 536 | (princ "specified term is not valid as formula.") | |
| 537 | (term-print term))) | |
| 538 | (dolist (cl (formula->clause-1 term | |
| 539 | (module-proof-system *current-module*))) | |
| 540 | (print-next) | |
| 541 | (print-clause cl *standard-output*))) | |
| 542 | ))) | |
| 515 | (term (simple-parse *current-module* pre-term *cosmos*))) | |
| 516 | (when (or (null (term-sort term)) | |
| 517 | (sort<= (term-sort term) | |
| 518 | *syntax-err-sort* *chaos-sort-order*)) | |
| 519 | (return-from eval-clause-show nil)) | |
| 520 | (when *mel-sort* | |
| 521 | (!setup-reduction *current-module*) | |
| 522 | (setq term (apply-sort-memb term *current-module*))) | |
| 523 | (unless (check-fopl-syntax term) | |
| 524 | (with-output-chaos-error ('invalid-formula) | |
| 525 | (princ "specified term is not valid as formula.") | |
| 526 | (term-print term))) | |
| 527 | (dolist (cl (formula->clause-1 term | |
| 528 | (module-proof-system *current-module*))) | |
| 529 | (print-next) | |
| 530 | (print-clause cl *standard-output*)))))) | |
| 543 | 531 | |
| 544 | 532 | ;;; EVAL-PN-LIST |
| 545 | 533 | ;;; |
| 546 | 534 | (defun eval-pn-list (ast) |
| 547 | 535 | (let ((arg (%pn-list-arg ast)) |
| 548 | (psys nil)) | |
| 536 | (psys nil)) | |
| 549 | 537 | (unless (memq arg '(:flag :param :option)) |
| 550 | 538 | (unless *current-module* |
| 551 | (with-output-chaos-error ('no-context) | |
| 552 | (princ "no context (current) module is set."))) | |
| 539 | (with-output-chaos-error ('no-context) | |
| 540 | (princ "no context (current) module is set."))) | |
| 553 | 541 | (auto-db-reset *current-module*) |
| 554 | 542 | (setq psys (module-proof-system *current-module*)) |
| 555 | 543 | (unless psys |
| 556 | (with-output-panic-message () | |
| 557 | (princ "could not construct proof system!")))) | |
| 544 | (with-output-panic-message () | |
| 545 | (princ "could not construct proof system!")))) | |
| 558 | 546 | ;; |
| 559 | 547 | (case arg |
| 560 | 548 | (:axiom |
| 561 | 549 | (with-proof-context (*current-module*) |
| 562 | (format t "~% ~%** MODULE AXIOMS in CLAUSAL FORM ________") | |
| 563 | (with-output-simple-msg () | |
| 564 | (princ " ") | |
| 565 | (dolist (cl (psystem-axioms psys)) | |
| 566 | (print-next) | |
| 567 | (print-clause cl *standard-output*))) | |
| 568 | )) | |
| 550 | (format t "~% ~%** MODULE AXIOMS in CLAUSAL FORM ________") | |
| 551 | (with-output-simple-msg () | |
| 552 | (princ " ") | |
| 553 | (dolist (cl (psystem-axioms psys)) | |
| 554 | (print-next) | |
| 555 | (print-clause cl *standard-output*))))) | |
| 569 | 556 | (:sos |
| 570 | 557 | (with-proof-context (*current-module*) |
| 571 | (print-sos-list) | |
| 572 | #|| | |
| 573 | (dolist (cl (psystem-sos psys)) | |
| 574 | (print-next) | |
| 575 | (print-clause cl *standard-output*)) | |
| 576 | ||# | |
| 577 | )) | |
| 558 | (print-sos-list) )) | |
| 578 | 559 | (:usable |
| 579 | 560 | (with-proof-context (*current-module*) |
| 580 | (print-usable-list) | |
| 581 | #|| | |
| 582 | (dolist (cl (psystem-usable psys)) | |
| 583 | (print-next) | |
| 584 | (print-clause cl *standard-output*)) | |
| 585 | ||# | |
| 586 | )) | |
| 561 | (print-usable-list) )) | |
| 587 | 562 | (:passive |
| 588 | 563 | (with-proof-context (*current-module*) |
| 589 | (print-passive-list))) | |
| 590 | ||
| 564 | (print-passive-list))) | |
| 591 | 565 | (:flag |
| 592 | 566 | (pr-list-of-flag)) |
| 593 | 567 | (:param |
| 596 | 570 | (pr-list-of-option)) |
| 597 | 571 | (:demod |
| 598 | 572 | (with-proof-context (*current-module*) |
| 599 | (print-demodulators-list) | |
| 600 | #|| | |
| 601 | (dolist (cl (psystem-demods psys)) | |
| 602 | (print-next) | |
| 603 | (print-clause cl *standard-output*)) | |
| 604 | ||# | |
| 605 | )) | |
| 573 | (print-demodulators-list))) | |
| 606 | 574 | (otherwise |
| 607 | 575 | (with-output-chaos-error ('invalid) |
| 608 | (format t "internal error, unknown list option ~a" arg))) | |
| 609 | ))) | |
| 576 | (format t "internal error, unknown list option ~a" arg)))))) | |
| 610 | 577 | |
| 611 | 578 | ;;; EVAL-RESOLVE |
| 612 | 579 | ;;; |
| 613 | 580 | (defun eval-resolve (ast) |
| 614 | (unless *current-module* | |
| 615 | (with-output-chaos-error ('no-context) | |
| 616 | (princ "no context (current module) is set!")) | |
| 617 | ) | |
| 618 | (let ((out-file (%resolve-arg ast))) | |
| 619 | (if (and out-file (not (equal out-file "."))) | |
| 620 | (with-open-file (stream out-file :direction :output | |
| 621 | :if-exists :append :if-does-not-exist :create) | |
| 622 | (let ((*standard-output* stream)) | |
| 623 | (do-resolve (if *open-module* | |
| 624 | *last-module* | |
| 625 | *current-module*)))) | |
| 626 | (do-resolve (if *open-module* | |
| 627 | *last-module* | |
| 628 | *current-module*))))) | |
| 581 | (let ((eval-context (get-context-module))) | |
| 582 | (let ((out-file (%resolve-arg ast))) | |
| 583 | (if (and out-file (not (equal out-file "."))) | |
| 584 | (with-open-file (stream out-file :direction :output | |
| 585 | :if-exists :append :if-does-not-exist :create) | |
| 586 | (let ((*standard-output* stream)) | |
| 587 | (do-resolve eval-context))) | |
| 588 | (do-resolve eval-context))))) | |
| 629 | 589 | |
| 630 | 590 | (defun do-resolve (mod) |
| 631 | 591 | (let ((time1 nil) |
| 632 | (time2 nil) | |
| 633 | (time-for-run nil) | |
| 634 | (ret-code nil)) | |
| 592 | (time2 nil) | |
| 593 | (time-for-run nil) | |
| 594 | (ret-code nil)) | |
| 635 | 595 | (setq time1 (get-internal-run-time)) |
| 636 | 596 | (setq ret-code |
| 637 | 597 | (infer-main mod)) |
| 638 | 598 | (setq time2 (get-internal-run-time)) |
| 639 | 599 | (setq time-for-run |
| 640 | 600 | (format nil "~,3f sec" |
| 641 | (elapsed-time-in-seconds time1 time2))) | |
| 601 | (elapsed-time-in-seconds time1 time2))) | |
| 642 | 602 | (unless *chaos-quiet* |
| 643 | 603 | (when (pn-flag print-stats) |
| 644 | (with-output-simple-msg () | |
| 645 | (format t "(total run time ~a)" time-for-run)))) | |
| 604 | (with-output-simple-msg () | |
| 605 | (format t "(total run time ~a)" time-for-run)))) | |
| 646 | 606 | ret-code)) |
| 647 | 607 | |
| 648 | 608 | ;;; EXTENSIONS OF "SHOW"/"DESCRIBE" COMMAND. |
| 655 | 615 | (with-in-module (*current-module*) |
| 656 | 616 | (let ((psys (module-proof-system *current-module*))) |
| 657 | 617 | (let ((clauses (find-clause cl-id psys))) |
| 658 | (cond (desc | |
| 659 | (dolist (cl clauses) | |
| 660 | (print-next) | |
| 661 | (when (clause-formula cl) | |
| 662 | (princ "-- clause derived from formula:") | |
| 663 | (print-next) | |
| 664 | (term-print (clause-formula cl)) | |
| 665 | (print-next)) | |
| 666 | (print-clause cl *standard-output*))) | |
| 667 | (t ; show | |
| 668 | (dolist (cl clauses) | |
| 669 | (print-next) | |
| 670 | (print-clause cl *standard-output*)) | |
| 671 | )))))) | |
| 618 | (cond (desc | |
| 619 | (dolist (cl clauses) | |
| 620 | (print-next) | |
| 621 | (when (clause-formula cl) | |
| 622 | (princ "-- clause derived from formula:") | |
| 623 | (print-next) | |
| 624 | (term-print (clause-formula cl)) | |
| 625 | (print-next)) | |
| 626 | (print-clause cl *standard-output*))) | |
| 627 | (t ; show | |
| 628 | (dolist (cl clauses) | |
| 629 | (print-next) | |
| 630 | (print-clause cl *standard-output*)) | |
| 631 | )))))) | |
| 672 | 632 | |
| 673 | 633 | ;;; |
| 674 | 634 | ;;; SET-FLAG/CLEAR-FLAG |
| 675 | 635 | ;;; |
| 676 | 636 | (defun eval-pn-set-flag (ast) |
| 677 | 637 | (let ((name (%pn-set-flag-name ast)) |
| 678 | (given-value (%pn-set-flag-value ast)) | |
| 679 | (value nil)) | |
| 638 | (given-value (%pn-set-flag-value ast)) | |
| 639 | (value nil)) | |
| 680 | 640 | (let ((index (find-pn-flag-index name))) |
| 681 | 641 | (unless index |
| 682 | (with-output-chaos-error ('no-such-flag) | |
| 683 | (format t "no such flag name ~s" name))) | |
| 642 | (with-output-chaos-error ('no-such-flag) | |
| 643 | (format t "no such flag name ~s" name))) | |
| 684 | 644 | (when (or (equal given-value "on") |
| 685 | (equal given-value "set")) | |
| 686 | (setq value t)) | |
| 645 | (equal given-value "set")) | |
| 646 | (setq value t)) | |
| 687 | 647 | (when (pn-flag print-message) |
| 688 | (with-output-msg () | |
| 689 | (format t "setting flag ~s to ~s" name given-value))) | |
| 648 | (with-output-msg () | |
| 649 | (format t "setting flag ~s to ~s" name given-value))) | |
| 690 | 650 | (setf (pn-flag index) value) |
| 691 | 651 | (dependent-flags index) |
| 692 | 652 | ;; run hook |
| 693 | (funcall (pn-flag-hook index) value) | |
| 694 | ))) | |
| 653 | (funcall (pn-flag-hook index) value)))) | |
| 695 | 654 | |
| 696 | 655 | ;;; SHOW-OPTION |
| 697 | 656 | ;;; |
| 702 | 661 | ;;; |
| 703 | 662 | (defun eval-pn-assign (ast) |
| 704 | 663 | (let ((name (%pn-assign-name ast)) |
| 705 | (given-value (%pn-assign-value ast)) | |
| 706 | (index nil) | |
| 707 | (value nil)) | |
| 664 | (given-value (%pn-assign-value ast)) | |
| 665 | (index nil) | |
| 666 | (value nil)) | |
| 708 | 667 | (setq index (find-pn-parameter-index name)) |
| 709 | 668 | (unless index |
| 710 | 669 | (with-output-chaos-error ('no-such-param) |
| 711 | (format t "no such parameter name ~s" name))) | |
| 670 | (format t "no such parameter name ~s" name))) | |
| 712 | 671 | (if (integerp given-value) |
| 713 | (setq value given-value) | |
| 672 | (setq value given-value) | |
| 714 | 673 | (when (stringp given-value) |
| 715 | (setq value (parse-integer given-value :junk-allowed t)))) | |
| 674 | (setq value (parse-integer given-value :junk-allowed t)))) | |
| 716 | 675 | (unless (integerp value) |
| 717 | 676 | (with-output-chaos-error ('invalid-value) |
| 718 | (format t "invalid parameter value ~s" given-value))) | |
| 677 | (format t "invalid parameter value ~s" given-value))) | |
| 719 | 678 | (let ((min (pn-parameter-min index)) |
| 720 | (max (pn-parameter-max index))) | |
| 679 | (max (pn-parameter-max index))) | |
| 721 | 680 | (when (< value min) |
| 722 | (with-output-chaos-error ('out-of-range) | |
| 723 | (format t "given value ~d is too small, minimun value allowed is ~d" | |
| 724 | value min))) | |
| 681 | (with-output-chaos-error ('out-of-range) | |
| 682 | (format t "given value ~d is too small, minimun value allowed is ~d" | |
| 683 | value min))) | |
| 725 | 684 | (when (> value max) |
| 726 | (with-output-chaos-error ('out-of-range) | |
| 727 | (format t "given value ~d is too large, maximum value allowed is ~d" | |
| 728 | value max))) | |
| 685 | (with-output-chaos-error ('out-of-range) | |
| 686 | (format t "given value ~d is too large, maximum value allowed is ~d" | |
| 687 | value max))) | |
| 729 | 688 | (when (pn-flag print-message) |
| 730 | (with-output-msg () | |
| 731 | (format t "setting parameter ~s to ~d." | |
| 732 | name value))) | |
| 733 | (setf (pn-parameter index) value) | |
| 734 | ))) | |
| 689 | (with-output-msg () | |
| 690 | (format t "setting parameter ~s to ~d." | |
| 691 | name value))) | |
| 692 | (setf (pn-parameter index) value)))) | |
| 735 | 693 | |
| 736 | 694 | ;;; option reset |
| 737 | 695 | ;;; |
| 738 | 696 | (defun eval-pn-option (ast) |
| 739 | 697 | (let ((command (%pn-option-command ast)) |
| 740 | (name (%pn-option-name ast))) | |
| 698 | (name (%pn-option-name ast))) | |
| 741 | 699 | (case command |
| 742 | 700 | (:reset (init-pn-options)) |
| 743 | 701 | (:save (save-option-set name)) |
| 744 | (:restore (restore-option-set name)) | |
| 745 | ))) | |
| 702 | (:restore (restore-option-set name))))) | |
| 746 | 703 | |
| 747 | 704 | ;;; DEMOD |
| 748 | 705 | (defun perform-demodulation (ast) |
| 749 | 706 | (let ((preterm (%demod-term ast)) |
| 750 | (modexp (%demod-module ast)) | |
| 751 | (mode (%demod-mode ast)) | |
| 752 | (result-as-text (%demod-return-text ast))) | |
| 707 | (modexp (%demod-module ast)) | |
| 708 | (mode (%demod-mode ast)) | |
| 709 | (result-as-text (%demod-return-text ast))) | |
| 753 | 710 | (perform-demodulation* preterm modexp mode result-as-text))) |
| 754 | 711 | |
| 712 | ;;; *** TODO *** | |
| 713 | ;;; use reducer. | |
| 755 | 714 | (defun perform-demodulation* (preterm &optional modexp mode (result-as-text nil)) |
| 756 | ;; (setq $$trials 1) | |
| 757 | 715 | (let ((*consider-object* t) |
| 758 | (*rewrite-exec-mode* (eq mode :exec)) | |
| 759 | (*rewrite-semantic-reduce* nil) | |
| 760 | sort | |
| 761 | time1 | |
| 762 | time2 | |
| 763 | (time-for-parse nil) | |
| 764 | (time-for-reduction nil) | |
| 765 | (number-matches nil)) | |
| 716 | (*rewrite-exec-mode* (eq mode :exec)) | |
| 717 | (*rewrite-semantic-reduce* nil) | |
| 718 | sort | |
| 719 | time1 | |
| 720 | time2 | |
| 721 | (time-for-parse nil) | |
| 722 | (time-for-reduction nil) | |
| 723 | (number-matches nil)) | |
| 766 | 724 | (let ((mod (if modexp |
| 767 | (eval-modexp modexp) | |
| 768 | *last-module*))) | |
| 769 | (unless (eq mod *last-module*) | |
| 770 | (clear-term-memo-table *term-memo-table*)) | |
| 725 | (eval-modexp modexp) | |
| 726 | (get-context-module t)))) | |
| 727 | (unless (eq mod (get-context-module t)) | |
| 728 | (clear-term-memo-table *term-memo-table*)) | |
| 771 | 729 | (if (or (null mod) (modexp-is-error mod)) |
| 772 | (if (null mod) | |
| 773 | (with-output-chaos-error ('no-context) | |
| 774 | (princ "no module expression provided and no selected(current) module.") | |
| 775 | ) | |
| 776 | (with-output-chaos-error ('no-such-module) | |
| 777 | (princ "incorrect module expression, no such module ") | |
| 778 | (print-chaos-object modexp) | |
| 779 | )) | |
| 780 | (progn | |
| 781 | (context-push-and-move *last-module* mod) | |
| 782 | (with-in-module (mod) | |
| 783 | (auto-db-reset mod)) | |
| 784 | (with-proof-context (mod) | |
| 785 | (when *auto-context-change* | |
| 786 | (change-context *last-module* mod)) | |
| 787 | (!setup-reduction mod) | |
| 788 | (setq $$mod *current-module*) | |
| 789 | (setq sort *cosmos*) | |
| 790 | (when *show-stats* (setq time1 (get-internal-run-time))) | |
| 791 | (setq *rewrite-semantic-reduce* | |
| 792 | (and (eq mode :red) | |
| 793 | (module-has-behavioural-axioms mod))) | |
| 794 | ;; | |
| 795 | (let* ((*parse-variables* nil) | |
| 796 | (term (simple-parse *current-module* preterm sort))) | |
| 797 | (when (or (null (term-sort term)) | |
| 798 | (sort<= (term-sort term) *syntax-err-sort* *chaos-sort-order*)) | |
| 799 | (return-from perform-demodulation* nil)) | |
| 800 | (when *rewrite-stepping* (setq *steps-to-be-done* 1)) | |
| 801 | (when *show-stats* | |
| 802 | (setq time2 (get-internal-run-time)) | |
| 803 | (setf time-for-parse | |
| 804 | (format nil "~,3f sec" | |
| 805 | ;; (/ (float (- time2 time1)) internal-time-units-per-second) | |
| 806 | (elapsed-time-in-seconds time1 time2) | |
| 807 | ))) | |
| 808 | (unless *chaos-quiet* | |
| 809 | (fresh-all) | |
| 810 | (flush-all) | |
| 811 | (if *rewrite-exec-mode* | |
| 812 | (princ "-- execute in ") | |
| 813 | (if (eq mode :red) | |
| 814 | (princ "-- demodulate in ") | |
| 815 | (princ "-- behavioural demodulate in ")) | |
| 816 | ) | |
| 817 | (print-simple-mod-name *current-module*) | |
| 818 | (princ " : ") | |
| 819 | (let ((*print-indent* (+ 4 *print-indent*))) | |
| 820 | (term-print term)) | |
| 821 | (flush-all)) | |
| 822 | ;; ******** | |
| 823 | (reset-target-term term *last-module* mod) | |
| 824 | ;; ******** | |
| 825 | (setq $$matches 0) | |
| 826 | (setq time1 (get-internal-run-time)) | |
| 827 | (let ((*rule-count* 0)) | |
| 828 | (let ((res nil)) | |
| 829 | (catch 'rewrite-abort | |
| 830 | #|| | |
| 831 | (if (sort<= (term-sort term) *fopl-sentence-sort* | |
| 832 | *current-sort-order*) | |
| 833 | (dolist (sub (term-subterms term)) | |
| 834 | (unless (term-is-variable? sub) | |
| 835 | (demod-atom sub))) | |
| 836 | (setq res (demod-atom term))) | |
| 837 | ||# | |
| 838 | (setq res (demod-atom term)) | |
| 839 | ) | |
| 840 | (unless res (setq res $$term)) | |
| 841 | ;; | |
| 842 | (when *mel-sort* | |
| 843 | (setq res (apply-sort-memb res | |
| 844 | mod)) | |
| 845 | (when res | |
| 846 | (setq $$term res))) | |
| 847 | ;; | |
| 848 | (setq time2 (get-internal-run-time)) | |
| 849 | (setf time-for-reduction | |
| 850 | (format nil "~,3f sec" | |
| 851 | ;; (/ (float (- time2 time1)) | |
| 852 | ;; internal-time-units-per-second) | |
| 853 | (elapsed-time-in-seconds time1 time2))) | |
| 854 | (setf number-matches $$matches) | |
| 855 | (setq $$matches 0) | |
| 856 | (setq $$norm res) | |
| 857 | ;; print out the result. | |
| 858 | (if result-as-text | |
| 859 | (let ((red-term | |
| 860 | (with-output-to-string (s) | |
| 861 | (let ((*standard-output* s) | |
| 862 | (*print-indent* (+ *print-indent* 2))) | |
| 863 | (term-print res) | |
| 864 | (print-check) | |
| 865 | (princ " : ") | |
| 866 | (print-sort-name (term-sort res) | |
| 867 | *current-module*)) | |
| 868 | s | |
| 869 | )) | |
| 870 | (stat | |
| 871 | (if *show-stats* | |
| 872 | (concatenate | |
| 873 | 'string | |
| 874 | (format nil | |
| 875 | "~%(~a for parse, ~s rewrites(~a), ~d matches" | |
| 876 | time-for-parse | |
| 877 | *rule-count* | |
| 878 | time-for-reduction | |
| 879 | number-matches) | |
| 880 | (if (zerop *term-memo-hash-hit*) | |
| 881 | (format nil ")~%") | |
| 882 | (format nil ", ~d memo hits)~%" | |
| 883 | *term-memo-hash-hit*))) | |
| 884 | ""))) | |
| 885 | (return-from perform-demodulation* (values red-term stat))) | |
| 886 | (progn | |
| 887 | (let ((*print-indent* (+ *print-indent* 2))) | |
| 888 | (fresh-all) | |
| 889 | (term-print res) | |
| 890 | (print-check 0 3) | |
| 891 | (princ " : ") | |
| 892 | (print-sort-name (term-sort res) | |
| 893 | *current-module*)) | |
| 894 | (when *show-stats* | |
| 895 | (format t "~%(~a for parse, ~s rewrites(~a), ~d matches" | |
| 896 | time-for-parse | |
| 897 | *rule-count* | |
| 898 | time-for-reduction | |
| 899 | number-matches) | |
| 900 | (if (zerop *term-memo-hash-hit*) | |
| 901 | (format t ")~%") | |
| 902 | (format t ", ~d memo hits)~%" | |
| 903 | *term-memo-hash-hit*))) | |
| 904 | (flush-all))) | |
| 905 | )) | |
| 906 | )) | |
| 907 | (context-pop-and-recover)))))) | |
| 730 | (if (null mod) | |
| 731 | (with-output-chaos-error ('no-context) | |
| 732 | (princ "no module expression provided and no selected(current) module.")) | |
| 733 | (with-output-chaos-error ('no-such-module) | |
| 734 | (princ "incorrect module expression, no such module ") | |
| 735 | (print-chaos-object modexp))) | |
| 736 | (progn | |
| 737 | (context-push-and-move (get-context-module t) mod) | |
| 738 | (with-in-module (mod) | |
| 739 | (auto-db-reset mod)) | |
| 740 | (with-proof-context (mod) | |
| 741 | (when *auto-context-change* | |
| 742 | (change-context (get-context-module t) mod)) | |
| 743 | (!setup-reduction mod) | |
| 744 | (setq $$mod (get-context-module)) | |
| 745 | (setq sort *cosmos*) | |
| 746 | (when *show-stats* (setq time1 (get-internal-run-time))) | |
| 747 | (setq *rewrite-semantic-reduce* | |
| 748 | (and (eq mode :red) | |
| 749 | (module-has-behavioural-axioms mod))) | |
| 750 | ;; | |
| 751 | (let* ((*parse-variables* nil) | |
| 752 | (term (simple-parse (get-context-module) preterm sort))) | |
| 753 | (when (or (null (term-sort term)) | |
| 754 | (sort<= (term-sort term) *syntax-err-sort* *chaos-sort-order*)) | |
| 755 | (return-from perform-demodulation* nil)) | |
| 756 | (when *rewrite-stepping* (setq *steps-to-be-done* 1)) | |
| 757 | (when *show-stats* | |
| 758 | (setq time2 (get-internal-run-time)) | |
| 759 | (setf time-for-parse | |
| 760 | (format nil "~,3f sec" | |
| 761 | (elapsed-time-in-seconds time1 time2)))) | |
| 762 | (unless *chaos-quiet* | |
| 763 | (fresh-all) | |
| 764 | (flush-all) | |
| 765 | (if *rewrite-exec-mode* | |
| 766 | (princ "-- execute in ") | |
| 767 | (if (eq mode :red) | |
| 768 | (princ "-- demodulate in ") | |
| 769 | (princ "-- behavioural demodulate in ")) | |
| 770 | ) | |
| 771 | (print-simple-mod-name (get-context-module)) | |
| 772 | (princ " : ") | |
| 773 | (let ((*print-indent* (+ 4 *print-indent*))) | |
| 774 | (term-print term)) | |
| 775 | (flush-all)) | |
| 776 | ;; ******** | |
| 777 | (reset-target-term term (get-context-module) mod) | |
| 778 | ;; ******** | |
| 779 | (setq $$matches 0) | |
| 780 | (setq time1 (get-internal-run-time)) | |
| 781 | (let ((*rule-count* 0)) | |
| 782 | (let ((res nil)) | |
| 783 | (catch 'rewrite-abort | |
| 784 | (setq res (demod-atom term))) | |
| 785 | (unless res (setq res $$term)) | |
| 786 | ;; | |
| 787 | (when *mel-sort* | |
| 788 | (setq res (apply-sort-memb res | |
| 789 | mod)) | |
| 790 | (when res | |
| 791 | (setq $$term res))) | |
| 792 | ;; | |
| 793 | (setq time2 (get-internal-run-time)) | |
| 794 | (setf time-for-reduction | |
| 795 | (format nil "~,3f sec" | |
| 796 | (elapsed-time-in-seconds time1 time2))) | |
| 797 | (setf number-matches $$matches) | |
| 798 | (setq $$matches 0) | |
| 799 | (setq $$norm res) | |
| 800 | ;; print out the result. | |
| 801 | (if result-as-text | |
| 802 | (let ((red-term | |
| 803 | (with-output-to-string (s) | |
| 804 | (let ((*standard-output* s) | |
| 805 | (*print-indent* (+ *print-indent* 2))) | |
| 806 | (term-print res) | |
| 807 | (print-check) | |
| 808 | (princ " : ") | |
| 809 | (print-sort-name (term-sort res) | |
| 810 | (get-context-module)) | |
| 811 | s))) | |
| 812 | (stat | |
| 813 | (if *show-stats* | |
| 814 | (concatenate | |
| 815 | 'string | |
| 816 | (format nil | |
| 817 | "~%(~a for parse, ~s rewrites(~a), ~d matches" | |
| 818 | time-for-parse | |
| 819 | *rule-count* | |
| 820 | time-for-reduction | |
| 821 | number-matches) | |
| 822 | (if (zerop *term-memo-hash-hit*) | |
| 823 | (format nil ")~%") | |
| 824 | (format nil ", ~d memo hits)~%" | |
| 825 | *term-memo-hash-hit*))) | |
| 826 | ""))) | |
| 827 | (return-from perform-demodulation* (values red-term stat))) | |
| 828 | (progn | |
| 829 | (let ((*print-indent* (+ *print-indent* 2))) | |
| 830 | (fresh-all) | |
| 831 | (term-print res) | |
| 832 | (print-check 0 3) | |
| 833 | (princ " : ") | |
| 834 | (print-sort-name (term-sort res) | |
| 835 | (get-context-module))) | |
| 836 | (when *show-stats* | |
| 837 | (format t "~%(~a for parse, ~s rewrites(~a), ~d matches" | |
| 838 | time-for-parse | |
| 839 | *rule-count* | |
| 840 | time-for-reduction | |
| 841 | number-matches) | |
| 842 | (if (zerop *term-memo-hash-hit*) | |
| 843 | (format t ")~%") | |
| 844 | (format t ", ~d memo hits)~%" | |
| 845 | *term-memo-hash-hit*))) | |
| 846 | (flush-all))))))) | |
| 847 | (context-pop-and-recover)))))) | |
| 908 | 848 | |
| 909 | 849 | ;;; SIGMATCH |
| 910 | 850 | (defun eval-pn-sigmatch (ast) |
| 911 | 851 | (let ((mod1 (eval-modexp (%sigmatch-mod1 ast))) |
| 912 | (mod2 (eval-modexp (%sigmatch-mod2 ast))) | |
| 913 | (views nil)) | |
| 852 | (mod2 (eval-modexp (%sigmatch-mod2 ast))) | |
| 853 | (views nil)) | |
| 914 | 854 | (when (or (null mod1) (modexp-is-error mod1)) |
| 915 | 855 | (with-output-chaos-error ('no-such-module) |
| 916 | (princ "no such module: ") | |
| 917 | (print-modexp (%sigmatch-mod1 ast)))) | |
| 856 | (princ "no such module: ") | |
| 857 | (print-modexp (%sigmatch-mod1 ast)))) | |
| 918 | 858 | (when (or (null mod2) (modexp-is-error mod2)) |
| 919 | 859 | (with-output-chaos-error ('no-such-module) |
| 920 | (princ "no such module: ") | |
| 921 | (print-modexp (%sigmatch-mod2 ast)))) | |
| 860 | (princ "no such module: ") | |
| 861 | (print-modexp (%sigmatch-mod2 ast)))) | |
| 922 | 862 | (setq views (sigmatch mod1 mod2)) |
| 923 | ;; | |
| 924 | 863 | (if views |
| 925 | (princ views) | |
| 926 | (princ "( )")) | |
| 927 | )) | |
| 864 | (princ views) | |
| 865 | (princ "( )")))) | |
| 928 | 866 | |
| 929 | 867 | ;;; LEX |
| 930 | 868 | (defun eval-pn-lex (ast) |
| 931 | (unless *current-module* | |
| 932 | (with-output-chaos-error ('no-context) | |
| 933 | (princ "no context(current) module is specified."))) | |
| 934 | (compile-module *current-module*) | |
| 935 | (with-in-module (*current-module*) | |
| 869 | (compile-module (get-context-module)) | |
| 870 | (with-in-module ((get-context-module)) | |
| 936 | 871 | (let ((optokens (%pn-lex-ops ast)) |
| 937 | (prec-list nil)) | |
| 872 | (prec-list nil)) | |
| 938 | 873 | (dolist (e optokens) |
| 939 | (cond ((equal e '("*")) | |
| 940 | (push :* prec-list)) | |
| 941 | ((equal e '("SKOLEM")) | |
| 942 | (push :skolem prec-list)) | |
| 943 | (t (let ((parsedop (parse-op-name e))) | |
| 944 | (multiple-value-bind (ops mod) | |
| 945 | (resolve-operator-reference parsedop) | |
| 946 | (with-in-module (mod) | |
| 947 | (dolist (opinfo ops) | |
| 948 | (dolist (meth (reverse (opinfo-methods opinfo))) | |
| 949 | (push meth prec-list)))))) | |
| 950 | ) | |
| 951 | )) | |
| 874 | (cond ((equal e '("*")) | |
| 875 | (push :* prec-list)) | |
| 876 | ((equal e '("SKOLEM")) | |
| 877 | (push :skolem prec-list)) | |
| 878 | (t (let ((parsedop (parse-op-name e))) | |
| 879 | (multiple-value-bind (ops mod) | |
| 880 | (resolve-operator-reference parsedop) | |
| 881 | (with-in-module (mod) | |
| 882 | (dolist (opinfo ops) | |
| 883 | (dolist (meth (reverse (opinfo-methods opinfo))) | |
| 884 | (push meth prec-list))))))))) | |
| 952 | 885 | ;; |
| 953 | 886 | (unless (memq :* prec-list) |
| 954 | (push :* prec-list)) | |
| 887 | (push :* prec-list)) | |
| 955 | 888 | (unless (memq :skolem prec-list) |
| 956 | (push :skolem prec-list)) | |
| 889 | (push :skolem prec-list)) | |
| 957 | 890 | (setq prec-list (nreverse prec-list)) |
| 958 | 891 | ;; |
| 959 | (setf (module-op-lex *current-module*) prec-list) | |
| 960 | ))) | |
| 961 | ||
| 892 | (setf (module-op-lex *current-module*) prec-list)))) | |
| 962 | 893 | |
| 963 | 894 | ;;; EOF |
| 0 | 0 | ;;;-*-Mode:LISP; Package: CHAOS; Base:10; Syntax:Common-lisp -*- |
| 1 | 1 | ;;; |
| 2 | ;;; Copyright (c) 2000-2014, Toshimi Sawada. All rights reserved. | |
| 2 | ;;; Copyright (c) 2000-2015, Toshimi Sawada. All rights reserved. | |
| 3 | 3 | ;;; |
| 4 | 4 | ;;; Redistribution and use in source and binary forms, with or without |
| 5 | 5 | ;;; modification, are permitted provided that the following conditions |
| 28 | 28 | ;;; |
| 29 | 29 | (in-package :chaos) |
| 30 | 30 | #|============================================================================= |
| 31 | System:Chaos | |
| 32 | Module:BigPink | |
| 33 | File:demod.lisp | |
| 31 | System:Chaos | |
| 32 | Module:BigPink | |
| 33 | File:demod.lisp | |
| 34 | 34 | =============================================================================|# |
| 35 | 35 | #-:chaos-debug |
| 36 | 36 | (declaim (optimize (speed 3) (safety 0) #-GCL (debug 0))) |
| 38 | 38 | (declaim (optimize (speed 1) (safety 3) #-GCL (debug 3))) |
| 39 | 39 | |
| 40 | 40 | (declaim (special .demod-target-clause.) |
| 41 | (type (or null clause) .demod-target-clause.)) | |
| 41 | (type (or null clause) .demod-target-clause.)) | |
| 42 | 42 | (defvar .demod-target-clause. nil) |
| 43 | 43 | |
| 44 | 44 | (declaim (special .demod-used-clauses.) |
| 45 | (type list .demod-used-clauses.)) | |
| 45 | (type list .demod-used-clauses.)) | |
| 46 | 46 | (defvar .demod-used-clauses. nil) |
| 47 | 47 | |
| 48 | 48 | (declaim (special .current-demod-clause.) |
| 49 | (type (or null clause) .current-demod-clause.)) | |
| 49 | (type (or null clause) .current-demod-clause.)) | |
| 50 | 50 | (defvar .current-demod-clause. nil) |
| 51 | 51 | |
| 52 | 52 | (declaim (special .demod-to-be-used.) |
| 53 | (type list .demod-to-be-used.)) | |
| 53 | (type list .demod-to-be-used.)) | |
| 54 | 54 | (defvar .demod-to-be-used. nil) |
| 55 | 55 | |
| 56 | 56 | ;;; METHOD-DEMODULATORS : Method -> List[Demodulator] |
| 65 | 65 | |
| 66 | 66 | (defun rule-2-demod (rule &optional (order :normal)) |
| 67 | 67 | (declare (type axiom rule) |
| 68 | (type symbol order)) | |
| 68 | (type symbol order)) | |
| 69 | 69 | (make-demod :axiom rule |
| 70 | :order order)) | |
| 70 | :order order)) | |
| 71 | 71 | |
| 72 | 72 | (defun rule->demodulator (rule &optional (psys nil)) |
| 73 | 73 | (declare (type axiom rule) |
| 74 | (ignore psys) | |
| 75 | (values (or null demod))) | |
| 74 | (ignore psys) | |
| 75 | (values (or null demod))) | |
| 76 | 76 | (let ((cond (axiom-condition rule))) |
| 77 | 77 | (declare (type term cond)) |
| 78 | 78 | (if (is-true? cond) |
| 79 | (rule-2-demod rule :normal) | |
| 79 | (rule-2-demod rule :normal) | |
| 80 | 80 | ;; I don't know how to treat this |
| 81 | 81 | nil |
| 82 | 82 | ))) |
| 87 | 87 | ;;; |
| 88 | 88 | (defun cafeobj-rules->demodulators (module) |
| 89 | 89 | (declare (type module module) |
| 90 | (values t)) | |
| 90 | (values t)) | |
| 91 | 91 | (with-in-module (module) |
| 92 | 92 | (let ((opinfos (module-all-operators *current-module*)) |
| 93 | (demod-table (psystem-demodulators (module-proof-system module)))) | |
| 93 | (demod-table (psystem-demodulators (module-proof-system module)))) | |
| 94 | 94 | (declare (type list opinfos) |
| 95 | (type hash-table demod-table)) | |
| 95 | (type hash-table demod-table)) | |
| 96 | 96 | (dolist (opinfo opinfos) |
| 97 | (dolist (meth (opinfo-methods opinfo)) | |
| 98 | (declare (type method meth)) | |
| 99 | (let ((rules (method-rules-with-different-top meth))) | |
| 100 | (declare (type list rules)) | |
| 101 | (dolist (r rules) | |
| 102 | (declare (type axiom r)) | |
| 103 | (let ((demod (rule->demodulator r))) | |
| 104 | (when demod | |
| 105 | (push demod (method-demodulators meth demod-table))))))) | |
| 106 | )))) | |
| 97 | (dolist (meth (opinfo-methods opinfo)) | |
| 98 | (declare (type method meth)) | |
| 99 | (let ((rules (method-rules-with-different-top meth))) | |
| 100 | (declare (type list rules)) | |
| 101 | (dolist (r rules) | |
| 102 | (declare (type axiom r)) | |
| 103 | (let ((demod (rule->demodulator r))) | |
| 104 | (when demod | |
| 105 | (push demod (method-demodulators meth demod-table))))))) | |
| 106 | )))) | |
| 107 | 107 | |
| 108 | 108 | ;;; DYNAMIC-DEMODULATOR : Clause -> {:normal, :order-dep, nil} |
| 109 | 109 | ;;; :normal -- regular demodulator |
| 112 | 112 | ;;; |
| 113 | 113 | (defun dynamic-demodulator (clause) |
| 114 | 114 | (declare (type clause clause) |
| 115 | (values symbol)) | |
| 115 | (values symbol)) | |
| 116 | 116 | (let ((l (ith-literal clause 1))) |
| 117 | 117 | (declare (type literal l)) |
| 118 | 118 | (if (positive-eq-literal? l) |
| 119 | (let* ((atom (literal-atom l)) | |
| 120 | (lhs (term-arg-1 atom)) | |
| 121 | (rhs (term-arg-2 atom))) | |
| 122 | (declare (type term atom lhs rhs)) | |
| 123 | (when (term-is-identical lhs rhs) | |
| 124 | (return-from dynamic-demodulator nil)) | |
| 125 | (when (test-bit (literal-stat-bits l) oriented-eq-bit) | |
| 126 | (if (pn-flag lrpo) | |
| 127 | (return-from dynamic-demodulator :normal) | |
| 128 | (when (var-subset rhs lhs) | |
| 129 | (if (pn-flag dynamic-demod-all) | |
| 130 | (return-from dynamic-demodulator :normal) | |
| 131 | ;; | |
| 132 | (let ((wt-lft (term-weight lhs)) | |
| 133 | (wt-rgt (term-weight rhs))) | |
| 134 | (declare (type fixnum wt-lft wt-rgt)) | |
| 135 | (if (and (< wt-rgt (pn-parameter dynamic-demod-rhs)) | |
| 136 | (>= (- wt-lft wt-rgt) | |
| 137 | (pn-parameter dynamic-demod-depth))) | |
| 138 | (return-from dynamic-demodulator :normal))) | |
| 139 | ) | |
| 140 | ))) | |
| 141 | ;; | |
| 142 | (unless (pn-flag dynamic-demod-lex-dep) | |
| 143 | (return-from dynamic-demodulator nil)) | |
| 144 | ;; | |
| 145 | (when (pn-flag lrpo) | |
| 146 | (if (and (var-subset rhs lhs) | |
| 147 | (not (term-is-identical lhs rhs))) | |
| 148 | (return-from dynamic-demodulator :order-dep) | |
| 149 | (return-from dynamic-demodulator nil))) | |
| 150 | ;; | |
| 151 | (if (not (pn-flag dynamic-demod-all)) | |
| 152 | (return-from dynamic-demodulator nil) | |
| 153 | (if (and (term-ident-x-vars lhs rhs) | |
| 154 | (not (term-is-identical lhs rhs))) | |
| 155 | (return-from dynamic-demodulator :order-dep) | |
| 156 | (return-from dynamic-demodulator nil)))) | |
| 119 | (let* ((atom (literal-atom l)) | |
| 120 | (lhs (term-arg-1 atom)) | |
| 121 | (rhs (term-arg-2 atom))) | |
| 122 | (declare (type term atom lhs rhs)) | |
| 123 | (when (term-is-identical lhs rhs) | |
| 124 | (return-from dynamic-demodulator nil)) | |
| 125 | (when (test-bit (literal-stat-bits l) oriented-eq-bit) | |
| 126 | (if (pn-flag lrpo) | |
| 127 | (return-from dynamic-demodulator :normal) | |
| 128 | (when (var-subset rhs lhs) | |
| 129 | (if (pn-flag dynamic-demod-all) | |
| 130 | (return-from dynamic-demodulator :normal) | |
| 131 | ;; | |
| 132 | (let ((wt-lft (term-weight lhs)) | |
| 133 | (wt-rgt (term-weight rhs))) | |
| 134 | (declare (type fixnum wt-lft wt-rgt)) | |
| 135 | (if (and (< wt-rgt (pn-parameter dynamic-demod-rhs)) | |
| 136 | (>= (- wt-lft wt-rgt) | |
| 137 | (pn-parameter dynamic-demod-depth))) | |
| 138 | (return-from dynamic-demodulator :normal))) | |
| 139 | ) | |
| 140 | ))) | |
| 141 | ;; | |
| 142 | (unless (pn-flag dynamic-demod-lex-dep) | |
| 143 | (return-from dynamic-demodulator nil)) | |
| 144 | ;; | |
| 145 | (when (pn-flag lrpo) | |
| 146 | (if (and (var-subset rhs lhs) | |
| 147 | (not (term-is-identical lhs rhs))) | |
| 148 | (return-from dynamic-demodulator :order-dep) | |
| 149 | (return-from dynamic-demodulator nil))) | |
| 150 | ;; | |
| 151 | (if (not (pn-flag dynamic-demod-all)) | |
| 152 | (return-from dynamic-demodulator nil) | |
| 153 | (if (and (term-ident-x-vars lhs rhs) | |
| 154 | (not (term-is-identical lhs rhs))) | |
| 155 | (return-from dynamic-demodulator :order-dep) | |
| 156 | (return-from dynamic-demodulator nil)))) | |
| 157 | 157 | ;; |
| 158 | 158 | nil) |
| 159 | 159 | )) |
| 164 | 164 | ;;; |
| 165 | 165 | (defun new-demodulator (clause &optional (demod-flag nil)) |
| 166 | 166 | (declare (type clause clause) |
| 167 | (type symbol demod-flag) | |
| 168 | (values demod)) | |
| 167 | (type symbol demod-flag) | |
| 168 | (values demod)) | |
| 169 | 169 | (incf (pn-stat new-demods)) |
| 170 | 170 | (let* ((atom (literal-atom (ith-literal clause 1))) |
| 171 | (lhs (copy-term-reusing-variables (term-arg-1 atom) | |
| 172 | (term-variables (term-arg-1 atom)))) | |
| 173 | (rhs (copy-term-reusing-variables (term-arg-2 atom) | |
| 174 | (term-variables (term-arg-2 atom))))) | |
| 171 | (lhs (copy-term-reusing-variables (term-arg-1 atom) | |
| 172 | (term-variables (term-arg-1 atom)))) | |
| 173 | (rhs (copy-term-reusing-variables (term-arg-2 atom) | |
| 174 | (term-variables (term-arg-2 atom))))) | |
| 175 | 175 | (declare (type term atom lhs rhs)) |
| 176 | 176 | (let* ((ax (make-simple-axiom lhs |
| 177 | rhs | |
| 178 | nil ; type | |
| 179 | nil ; behavioural -> to do | |
| 180 | )) | |
| 181 | (demod nil)) | |
| 177 | rhs | |
| 178 | nil ; type | |
| 179 | nil ; behavioural -> to do | |
| 180 | )) | |
| 181 | (demod nil)) | |
| 182 | 182 | (declare (type axiom ax) |
| 183 | (type (or null demod) demod)) | |
| 183 | (type (or null demod) demod)) | |
| 184 | 184 | ;; specialization should be considered: TODO |
| 185 | 185 | (setq demod (make-demod :axiom ax :order demod-flag |
| 186 | :clause clause)) | |
| 186 | :clause clause)) | |
| 187 | 187 | ;; must consider `demod-flag' here, : TODO |
| 188 | 188 | ;; or at rewriting time...... |
| 189 | 189 | (push demod (gethash (term-head lhs) *demodulators*)) |
| 198 | 198 | ;;; =================== |
| 199 | 199 | |
| 200 | 200 | (declaim (special *current-cafeobj-rule*) |
| 201 | (type (or null axiom) *current-cafeobj-rule*)) | |
| 201 | (type (or null axiom) *current-cafeobj-rule*)) | |
| 202 | 202 | (defvar *current-cafeobj-rule* nil) |
| 203 | 203 | |
| 204 | 204 | (declaim (special *demod-is-back-demod*)) |
| 214 | 214 | (when (pn-flag trace-demod) |
| 215 | 215 | (with-output-simple-msg () |
| 216 | 216 | (if (= 1 *rule-count*) |
| 217 | (progn | |
| 218 | (if *demod-is-back-demod* | |
| 219 | (format t "<~D> back demod: " *rule-count*) | |
| 220 | (format t "<~D> demod: " *rule-count*)) | |
| 221 | (term-print $$term)) | |
| 222 | (format t "<~D>" *rule-count*)) | |
| 217 | (progn | |
| 218 | (if *demod-is-back-demod* | |
| 219 | (format t "<~D> back demod: " *rule-count*) | |
| 220 | (format t "<~D> demod: " *rule-count*)) | |
| 221 | (term-print $$term)) | |
| 222 | (format t "<~D>" *rule-count*)) | |
| 223 | 223 | (let ((*print-indent* (+ *print-indent* 4))) |
| 224 | (print-next) | |
| 225 | (term-print t1) | |
| 226 | (print-next) | |
| 227 | (format t "-(~a)-> " | |
| 228 | (if (clause-p .current-demod-clause.) | |
| 229 | (clause-id .current-demod-clause.) | |
| 230 | :*)) | |
| 231 | (term-print t2)) | |
| 224 | (print-next) | |
| 225 | (term-print t1) | |
| 226 | (print-next) | |
| 227 | (format t "-(~a)-> " | |
| 228 | (if (clause-p .current-demod-clause.) | |
| 229 | (clause-id .current-demod-clause.) | |
| 230 | :*)) | |
| 231 | (term-print t2)) | |
| 232 | 232 | )) |
| 233 | 233 | ;; |
| 234 | 234 | (term-replace t1 t2) |
| 241 | 241 | (defun apply-one-demodulator (demod term) |
| 242 | 242 | (if (eq (demod-order demod) :builtin) |
| 243 | 243 | (if (apply-one-rule (demod-axiom demod) term) |
| 244 | (progn (incf (pn-stat rewrites)) t) | |
| 245 | nil) | |
| 244 | (progn (incf (pn-stat rewrites)) t) | |
| 245 | nil) | |
| 246 | 246 | (apply-one-demodulator* demod term))) |
| 247 | 247 | |
| 248 | 248 | (defun apply-one-demodulator* (demod term &aux (rule (demod-axiom demod))) |
| 249 | 249 | (declare (type demod demod) |
| 250 | (type axiom rule) | |
| 251 | (type term term)) | |
| 250 | (type axiom rule) | |
| 251 | (type term term)) | |
| 252 | 252 | (declare (inline demod-replace-term)) |
| 253 | 253 | |
| 254 | 254 | ;; non-harmfull but nonsence. |
| 256 | 256 | (return-from apply-one-demodulator* nil)) |
| 257 | 257 | ;; |
| 258 | 258 | (let* ((*self* term) |
| 259 | (*do-unify* nil) | |
| 260 | (contr nil) | |
| 261 | (ok t)) | |
| 259 | (*do-unify* nil) | |
| 260 | (contr nil) | |
| 261 | (ok t)) | |
| 262 | 262 | (declare (type term *self*) |
| 263 | (type (or null term) contr)) | |
| 263 | (type (or null term) contr)) | |
| 264 | 264 | ;; |
| 265 | 265 | (multiple-value-bind (subst no-match E-equal) |
| 266 | (pn-match (rule-lhs rule) term nil t) | |
| 266 | (pn-match (rule-lhs rule) term nil t) | |
| 267 | 267 | (declare (type list subst) |
| 268 | (ignore e-equal)) | |
| 268 | (ignore e-equal)) | |
| 269 | 269 | (incf $$matches) |
| 270 | 270 | (when no-match (return-from apply-one-demodulator* nil)) |
| 271 | 271 | (unless (beh-context-ok? rule term) |
| 272 | (return-from apply-one-demodulator* nil)) | |
| 272 | (return-from apply-one-demodulator* nil)) | |
| 273 | 273 | |
| 274 | 274 | ;; match success ------------------------------------- |
| 275 | 275 | (block try-rule |
| 276 | (catch 'rule-failure | |
| 277 | (setq contr (set-term-color | |
| 278 | (substitution-image subst (rule-rhs rule)))) | |
| 279 | (when (eq (demod-order demod) :order-dep) | |
| 280 | (if (pn-flag lrpo) | |
| 281 | (setq ok (lrpo-greater term contr)) | |
| 282 | (setq ok (eq :less (lex-check contr term))))) | |
| 283 | (when ok | |
| 284 | (demod-replace-term term contr) | |
| 285 | (return-from apply-one-demodulator* t)))) | |
| 276 | (catch 'rule-failure | |
| 277 | (setq contr (set-term-color | |
| 278 | (substitution-image subst (rule-rhs rule)))) | |
| 279 | (when (eq (demod-order demod) :order-dep) | |
| 280 | (if (pn-flag lrpo) | |
| 281 | (setq ok (lrpo-greater term contr)) | |
| 282 | (setq ok (eq :less (lex-check contr term))))) | |
| 283 | (when ok | |
| 284 | (demod-replace-term term contr) | |
| 285 | (return-from apply-one-demodulator* t)))) | |
| 286 | 286 | nil))) |
| 287 | 287 | |
| 288 | 288 | ;;; APPLY-DEMODULATOR : rule term -> Bool |
| 293 | 293 | ;;; |
| 294 | 294 | (defun apply-demodulator (demod term &aux (rule (demod-axiom demod))) |
| 295 | 295 | (declare (type demod demod) |
| 296 | (type axiom rule) | |
| 297 | (type term term)) | |
| 296 | (type axiom rule) | |
| 297 | (type term term)) | |
| 298 | 298 | (let ((is-applied nil) |
| 299 | (.current-demod-clause. (demod-clause demod))) | |
| 299 | (.current-demod-clause. (demod-clause demod))) | |
| 300 | 300 | (declare (type (or symbol clause) .current-demod-clause.)) |
| 301 | 301 | ;; avoid self application, current implementation cannot handle |
| 302 | 302 | ;; this situation... |
| 303 | 303 | (when (eq .current-demod-clause. |
| 304 | .demod-target-clause.) | |
| 304 | .demod-target-clause.) | |
| 305 | 305 | (return-from apply-demodulator nil)) |
| 306 | 306 | ;; |
| 307 | 307 | (tagbody |
| 308 | 308 | ;; now this test is useless, just a memo for future |
| 309 | 309 | ;; versions. |
| 310 | 310 | (when (rule-is-rule rule) |
| 311 | (if *rewrite-exec-mode* | |
| 312 | (go do-apply) | |
| 313 | (return-from apply-demodulator nil))) | |
| 311 | (if *rewrite-exec-mode* | |
| 312 | (go do-apply) | |
| 313 | (return-from apply-demodulator nil))) | |
| 314 | 314 | ;; rule is equation |
| 315 | 315 | (when (and (not *cexec-normalize*) |
| 316 | (term-is-applform? term) | |
| 317 | (method-has-trans-rule (term-head term))) | |
| 318 | (return-from apply-demodulator nil)) | |
| 316 | (term-is-applform? term) | |
| 317 | (method-has-trans-rule (term-head term))) | |
| 318 | (return-from apply-demodulator nil)) | |
| 319 | 319 | ;;---- |
| 320 | 320 | do-apply |
| 321 | 321 | ;;---- |
| 328 | 328 | ;; return t iff the rule is applied. |
| 329 | 329 | (when is-applied |
| 330 | 330 | (let ((cid (if (clause-p .current-demod-clause.) |
| 331 | (clause-id .current-demod-clause.) | |
| 332 | :eval))) | |
| 333 | (pushnew cid .demod-used-clauses.)) | |
| 331 | (clause-id .current-demod-clause.) | |
| 332 | :eval))) | |
| 333 | (pushnew cid .demod-used-clauses.)) | |
| 334 | 334 | ) |
| 335 | 335 | ;; |
| 336 | 336 | is-applied)) |
| 339 | 339 | ;;; |
| 340 | 340 | (defun demod-apply-A-extensions (rule term top) |
| 341 | 341 | (declare (type axiom rule) |
| 342 | (type term term) | |
| 343 | (type method top)) | |
| 342 | (type term term) | |
| 343 | (type method top)) | |
| 344 | 344 | ;; (declare (optimize (speed 3) (safety 0))) |
| 345 | 345 | (let ((listext (!axiom-a-extensions rule)) |
| 346 | (a-ext nil) | |
| 347 | (is-applied nil)) | |
| 346 | (a-ext nil) | |
| 347 | (is-applied nil)) | |
| 348 | 348 | (declare (type list litext) |
| 349 | (type (or null axiom) a-ext)) | |
| 349 | (type (or null axiom) a-ext)) | |
| 350 | 350 | (when (null listext) |
| 351 | 351 | ;; then need to pre-compute the extensions and store then |
| 352 | 352 | (setq listext (compute-A-extensions rule top))) |
| 357 | 357 | (when (setq a-ext (car listext)) |
| 358 | 358 | ;; the second extension exists |
| 359 | 359 | (setq is-applied (or (apply-one-demodulator a-ext term) |
| 360 | is-applied))) | |
| 360 | is-applied))) | |
| 361 | 361 | (setq listext (cdr listext)) |
| 362 | 362 | (when (setq a-ext (car listext)) |
| 363 | 363 | ;; the third extension exists |
| 364 | 364 | (setq is-applied (or (apply-one-demodulator a-ext term) |
| 365 | is-applied))) | |
| 365 | is-applied))) | |
| 366 | 366 | ;; |
| 367 | 367 | is-applied)) |
| 368 | 368 | |
| 369 | 369 | (defun demod-apply-AC-extension (rule term top) |
| 370 | 370 | (declare (type axiom rule) |
| 371 | (type term term) | |
| 372 | (type method top) | |
| 373 | (values (or null t))) | |
| 371 | (type term term) | |
| 372 | (type method top) | |
| 373 | (values (or null t))) | |
| 374 | 374 | (let ((listext (!axiom-ac-extension rule)) |
| 375 | (is-applied nil)) | |
| 375 | (is-applied nil)) | |
| 376 | 376 | (when (null listext) |
| 377 | 377 | ;; then need to pre-compute the extensions and store then |
| 378 | 378 | (setq listext (compute-AC-extension rule top))) |
| 387 | 387 | ;;; |
| 388 | 388 | (defun apply-demodulators (term strategy) |
| 389 | 389 | (declare (type term term) |
| 390 | (type list strategy)) | |
| 390 | (type list strategy)) | |
| 391 | 391 | (labels ((apply-dt-rules (demods) |
| 392 | (declare (type list demods)) | |
| 393 | (block the-end | |
| 394 | (dolist (demod demods) | |
| 395 | (declare (type demod demod)) | |
| 396 | (when (apply-demodulator demod term) | |
| 397 | (return-from the-end t))))) | |
| 398 | (apply-rules-internal () | |
| 399 | (let ((top (term-head term))) | |
| 400 | (declare (type method top)) | |
| 401 | (update-lowest-parse term) | |
| 402 | (if (not (eq top (term-head term))) | |
| 403 | (demod-normalize-term term) | |
| 404 | (if (apply-dt-rules (or .demod-to-be-used. | |
| 405 | (method-demodulators top))) | |
| 406 | (demod-normalize-term term) | |
| 407 | (demod-reduce-term term (cdr strategy))) | |
| 408 | )))) | |
| 392 | (declare (type list demods)) | |
| 393 | (block the-end | |
| 394 | (dolist (demod demods) | |
| 395 | (declare (type demod demod)) | |
| 396 | (when (apply-demodulator demod term) | |
| 397 | (return-from the-end t))))) | |
| 398 | (apply-rules-internal () | |
| 399 | (let ((top (term-head term))) | |
| 400 | (declare (type method top)) | |
| 401 | (update-lowest-parse term) | |
| 402 | (if (not (eq top (term-head term))) | |
| 403 | (demod-normalize-term term) | |
| 404 | (if (apply-dt-rules (or .demod-to-be-used. | |
| 405 | (method-demodulators top))) | |
| 406 | (demod-normalize-term term) | |
| 407 | (demod-reduce-term term (cdr strategy))) | |
| 408 | )))) | |
| 409 | 409 | ;; |
| 410 | 410 | (apply-rules-internal) |
| 411 | 411 | )) |
| 415 | 415 | ;;; |
| 416 | 416 | (defun demod-reduce-term (term strategy) |
| 417 | 417 | (declare (type term term) |
| 418 | (type list strategy)) | |
| 418 | (type list strategy)) | |
| 419 | 419 | (let ((occ nil) |
| 420 | (top (term-head term)) | |
| 421 | ;; (*cexec-target* nil) | |
| 422 | ) | |
| 420 | (top (term-head term)) | |
| 421 | ;; (*cexec-target* nil) | |
| 422 | ) | |
| 423 | 423 | (declare (type (or null fixnum) occ) |
| 424 | (type method top)) | |
| 424 | (type method top)) | |
| 425 | 425 | (cond ((null strategy) |
| 426 | ;; no strat, or exhausted. | |
| 427 | (unless (term-is-lowest-parsed? term) | |
| 428 | (update-lowest-parse term) | |
| 429 | (unless (method= (term-method term) top) | |
| 430 | (return-from demod-reduce-term (demod-normalize-term term)))) | |
| 431 | (mark-term-as-reduced term) | |
| 432 | ) | |
| 433 | ||
| 434 | ;; whole | |
| 435 | ((= 0 (the fixnum (setf occ (car strategy)))) | |
| 436 | #|| | |
| 437 | (when (eq top *rwl-predicate*) | |
| 438 | (setq *cexec-target* term)) | |
| 439 | ||# | |
| 440 | (unless (term-is-reduced? term) | |
| 441 | (apply-demodulators term strategy))) | |
| 442 | ||
| 443 | ;; explicit lazy | |
| 444 | ((< (the fixnum occ) 0) | |
| 445 | (let ((d-arg (term-arg-n term (1- (abs occ))))) | |
| 446 | (unless (term-is-reduced? d-arg) (mark-term-as-on-demand d-arg)) | |
| 447 | (demod-reduce-term term (cdr strategy)))) | |
| 448 | ||
| 449 | ;; normal case, reduce specified subterm | |
| 450 | #|| | |
| 451 | (t (if (method-is-associative top) | |
| 452 | (let ((list-subterms (list-assoc-subterms term top)) | |
| 453 | (lowest-parsed t)) | |
| 454 | (declare (type list list-subterms)) | |
| 455 | (dolist (x list-subterms) | |
| 456 | (unless (demod-normalize-term x) | |
| 457 | (setf lowest-parsed nil))) | |
| 458 | (unless lowest-parsed | |
| 459 | (mark-term-as-not-lowest-parsed term)) | |
| 460 | (demod-reduce-term term (list 0))) | |
| 461 | (progn | |
| 462 | (unless (demod-normalize-term (term-arg-n term (1- occ))) | |
| 463 | (mark-term-as-not-lowest-parsed term)) | |
| 464 | (demod-reduce-term term (cdr strategy))))) | |
| 465 | ||# | |
| 466 | (t (unless (demod-normalize-term (term-arg-n term (1- occ))) | |
| 467 | (mark-term-as-not-lowest-parsed term)) | |
| 468 | (demod-reduce-term term (cdr strategy))) | |
| 469 | ))) | |
| 426 | ;; no strat, or exhausted. | |
| 427 | (unless (term-is-lowest-parsed? term) | |
| 428 | (update-lowest-parse term) | |
| 429 | (unless (method= (term-method term) top) | |
| 430 | (return-from demod-reduce-term (demod-normalize-term term)))) | |
| 431 | (mark-term-as-reduced term) | |
| 432 | ) | |
| 433 | ||
| 434 | ;; whole | |
| 435 | ((= 0 (the fixnum (setf occ (car strategy)))) | |
| 436 | #|| | |
| 437 | (when (eq top *rwl-predicate*) | |
| 438 | (setq *cexec-target* term)) | |
| 439 | ||# | |
| 440 | (unless (term-is-reduced? term) | |
| 441 | (apply-demodulators term strategy))) | |
| 442 | ||
| 443 | ;; explicit lazy | |
| 444 | ((< (the fixnum occ) 0) | |
| 445 | (let ((d-arg (term-arg-n term (1- (abs occ))))) | |
| 446 | (unless (term-is-reduced? d-arg) (mark-term-as-on-demand d-arg)) | |
| 447 | (demod-reduce-term term (cdr strategy)))) | |
| 448 | ||
| 449 | ;; normal case, reduce specified subterm | |
| 450 | #|| | |
| 451 | (t (if (method-is-associative top) | |
| 452 | (let ((list-subterms (list-assoc-subterms term top)) | |
| 453 | (lowest-parsed t)) | |
| 454 | (declare (type list list-subterms)) | |
| 455 | (dolist (x list-subterms) | |
| 456 | (unless (demod-normalize-term x) | |
| 457 | (setf lowest-parsed nil))) | |
| 458 | (unless lowest-parsed | |
| 459 | (mark-term-as-not-lowest-parsed term)) | |
| 460 | (demod-reduce-term term (list 0))) | |
| 461 | (progn | |
| 462 | (unless (demod-normalize-term (term-arg-n term (1- occ))) | |
| 463 | (mark-term-as-not-lowest-parsed term)) | |
| 464 | (demod-reduce-term term (cdr strategy))))) | |
| 465 | ||# | |
| 466 | (t (unless (demod-normalize-term (term-arg-n term (1- occ))) | |
| 467 | (mark-term-as-not-lowest-parsed term)) | |
| 468 | (demod-reduce-term term (cdr strategy))) | |
| 469 | ))) | |
| 470 | 470 | |
| 471 | 471 | ;;; |
| 472 | 472 | |
| 474 | 474 | (defun demod-method-rewrite-strategy (meth) |
| 475 | 475 | (let ((strat (method-rewrite-strategy meth))) |
| 476 | 476 | (if strat |
| 477 | (if (= 0 (car (last strat))) | |
| 478 | strat | |
| 479 | (append strat '(0))) | |
| 477 | (if (= 0 (car (last strat))) | |
| 478 | strat | |
| 479 | (append strat '(0))) | |
| 480 | 480 | (progn |
| 481 | (dotimes (x (cdr (method-name meth))) | |
| 482 | (push (1+ x) strat)) | |
| 483 | (push 0 strat) | |
| 484 | (nreverse strat))))) | |
| 481 | (dotimes (x (cdr (method-name meth))) | |
| 482 | (push (1+ x) strat)) | |
| 483 | (push 0 strat) | |
| 484 | (nreverse strat))))) | |
| 485 | 485 | ||# |
| 486 | 486 | |
| 487 | 487 | (defvar .demod-strat. |
| 500 | 500 | |
| 501 | 501 | (defun demod-method-rewrite-strategy (meth) |
| 502 | 502 | (let ((strat nil) |
| 503 | (num-args (cdr (method-name meth)))) | |
| 503 | (num-args (cdr (method-name meth)))) | |
| 504 | 504 | (declare (type fixnum num-args) |
| 505 | (type list strat)) | |
| 505 | (type list strat)) | |
| 506 | 506 | (if (<= num-args 10) |
| 507 | (aref .demod-strat. num-args) | |
| 507 | (aref .demod-strat. num-args) | |
| 508 | 508 | (progn |
| 509 | (dotimes (x num-args) | |
| 510 | (push (1+ x) strat)) | |
| 511 | (push 0 strat) | |
| 512 | (nreverse strat))))) | |
| 509 | (dotimes (x num-args) | |
| 510 | (push (1+ x) strat)) | |
| 511 | (push 0 strat) | |
| 512 | (nreverse strat))))) | |
| 513 | 513 | |
| 514 | 514 | (defun demod-normalize-term (term) |
| 515 | 515 | (declare (type term term)) |
| 516 | 516 | (let ((strategy nil)) |
| 517 | 517 | (declare (type list strategy)) |
| 518 | 518 | (cond ((term-is-reduced? term) |
| 519 | (when (term-is-builtin-constant? term) | |
| 520 | (update-lowest-parse term)) | |
| 521 | t) | |
| 522 | ((null (setq strategy | |
| 523 | (demod-method-rewrite-strategy (term-head term)))) | |
| 524 | (mark-term-as-reduced term) | |
| 525 | t) | |
| 526 | ;; | |
| 527 | (t (demod-reduce-term term strategy) | |
| 528 | nil)))) | |
| 519 | (when (term-is-builtin-constant? term) | |
| 520 | (update-lowest-parse term)) | |
| 521 | t) | |
| 522 | ((null (setq strategy | |
| 523 | (demod-method-rewrite-strategy (term-head term)))) | |
| 524 | (mark-term-as-reduced term) | |
| 525 | t) | |
| 526 | ;; | |
| 527 | (t (demod-reduce-term term strategy) | |
| 528 | nil)))) | |
| 529 | 529 | |
| 530 | 530 | (defun clean-reduced-flag (term) |
| 531 | 531 | (declare (type term term) |
| 532 | (values t)) | |
| 532 | (values t)) | |
| 533 | 533 | (when (or (term-is-builtin-constant? term) |
| 534 | (term-is-variable? term)) | |
| 534 | (term-is-variable? term)) | |
| 535 | 535 | (return-from clean-reduced-flag nil)) |
| 536 | 536 | (mark-term-as-not-reduced term) |
| 537 | 537 | (when (term-is-application-form? term) |
| 540 | 540 | |
| 541 | 541 | (defun demod-rewrite (term &optional (module *current-module*)) |
| 542 | 542 | (declare (type term term) |
| 543 | (type module module) | |
| 544 | (values term)) | |
| 543 | (type module module) | |
| 544 | (values term)) | |
| 545 | 545 | ;; case of back demodulation |
| 546 | 546 | (when .demod-to-be-used. |
| 547 | 547 | (clean-reduced-flag term)) |
| 548 | 548 | ;; |
| 549 | 549 | (with-in-module (module) |
| 550 | 550 | (let ((*beh-rewrite* (and (not *rewrite-semantic-reduce*) |
| 551 | (module-has-behavioural-axioms module)))) | |
| 551 | (module-has-behavioural-axioms module)))) | |
| 552 | 552 | (declare (special *beh-rewrite*)) |
| 553 | 553 | (set-term-color-top term) |
| 554 | 554 | (demod-normalize-term term))) |
| 560 | 560 | (defun demodulate-clause (clause) |
| 561 | 561 | (declare (type clause clause)) |
| 562 | 562 | (let ((.demod-target-clause. clause) |
| 563 | (.demod-used-clauses. nil) | |
| 564 | (.current-demod-clause. nil) | |
| 565 | (rwc (pn-stat rewrites))) | |
| 563 | (.demod-used-clauses. nil) | |
| 564 | (.current-demod-clause. nil) | |
| 565 | (rwc (pn-stat rewrites))) | |
| 566 | 566 | (declare (type clause .demod-target-clause.) |
| 567 | (type fixnum rwc)) | |
| 567 | (type fixnum rwc)) | |
| 568 | 568 | (setq *term-memo-hash-hit* 0) |
| 569 | 569 | (let ((*current-cafeobj-rule* (clause-axiom clause))) |
| 570 | 570 | (dolist (lit (clause-literals clause)) |
| 571 | (declare (type literal lit)) | |
| 572 | (demod-atom (literal-atom lit)))) | |
| 571 | (declare (type literal lit)) | |
| 572 | (demod-atom (literal-atom lit)))) | |
| 573 | 573 | (unless (= (pn-stat rewrites) rwc) |
| 574 | 574 | ;; there happened some rewrites |
| 575 | 575 | (dolist (lit (clause-literals clause)) |
| 576 | (mark-literal lit)) | |
| 576 | (mark-literal lit)) | |
| 577 | 577 | (setf (clause-parents clause) |
| 578 | (nconc (clause-parents clause) | |
| 579 | (list (cons :demod-rule (nreverse .demod-used-clauses.))))) | |
| 578 | (nconc (clause-parents clause) | |
| 579 | (list (cons :demod-rule (nreverse .demod-used-clauses.))))) | |
| 580 | 580 | ))) |
| 581 | 581 | |
| 582 | 582 | (defun demod-atom (atom) |
| 586 | 586 | #|| |
| 587 | 587 | (if (sort<= (term-sort atom) *fopl-sentence-sort* *current-sort-order*) |
| 588 | 588 | (dolist (sub (term-subterms atom)) |
| 589 | (if (not (term-is-variable? sub)) | |
| 590 | (demod-atom sub))) | |
| 589 | (if (not (term-is-variable? sub)) | |
| 590 | (demod-atom sub))) | |
| 591 | 591 | (demod-rewrite atom)) |
| 592 | 592 | ||# |
| 593 | 593 | (demod-rewrite atom) |
| 600 | 600 | (let ((.demod-to-be-used. (list demod))) |
| 601 | 601 | (declare (type list .demod-to-be-used.)) |
| 602 | 602 | (let ((.demod-target-clause. clause) |
| 603 | (.demod-used-clauses. nil) | |
| 604 | (.current-demod-clause. nil) | |
| 605 | (rwc (pn-stat rewrites))) | |
| 603 | (.demod-used-clauses. nil) | |
| 604 | (.current-demod-clause. nil) | |
| 605 | (rwc (pn-stat rewrites))) | |
| 606 | 606 | (declare (type fixnum rwc)) |
| 607 | 607 | (setq *term-memo-hash-hit* 0) |
| 608 | 608 | (let ((*current-cafeobj-rule* (clause-axiom clause))) |
| 609 | (dolist (lit (clause-literals clause)) | |
| 610 | (declare (type literal lit)) | |
| 611 | (demod-atom (literal-atom lit)))) | |
| 609 | (dolist (lit (clause-literals clause)) | |
| 610 | (declare (type literal lit)) | |
| 611 | (demod-atom (literal-atom lit)))) | |
| 612 | 612 | (unless (= rwc (pn-stat rewrites)) |
| 613 | ;; there happened some rewrites | |
| 614 | (dolist (lit (clause-literals clause)) | |
| 615 | (mark-literal lit)) | |
| 616 | (return-from apply-demod-to-clause clause)) | |
| 613 | ;; there happened some rewrites | |
| 614 | (dolist (lit (clause-literals clause)) | |
| 615 | (mark-literal lit)) | |
| 616 | (return-from apply-demod-to-clause clause)) | |
| 617 | 617 | nil))) |
| 618 | 618 | |
| 619 | 619 | ;;; |
| 621 | 621 | ;;; |
| 622 | 622 | (defun back-demodulate (demod-list clause input list-marker) |
| 623 | 623 | (declare (type list demod-list) |
| 624 | (type clause clause) | |
| 625 | (type symbol list-marker)) | |
| 624 | (type clause clause) | |
| 625 | (type symbol list-marker)) | |
| 626 | 626 | (let ((demod (cdr (assq clause demod-list))) |
| 627 | (*demod-is-back-demod* t)) | |
| 627 | (*demod-is-back-demod* t)) | |
| 628 | 628 | (declare (type (or null demod) demod)) |
| 629 | 629 | (when demod |
| 630 | 630 | (let ((cls (get-clashable-clauses-from-atom |
| 631 | *full-lit-table* | |
| 632 | (demod-lhs demod)))) | |
| 633 | (declare (type list cls)) | |
| 634 | (dolist (cl cls) | |
| 635 | (declare (type clause cl)) | |
| 636 | (when (apply-demod-to-clause demod cl) | |
| 637 | (incf (pn-stat cl-back-demod)) | |
| 638 | (unless (pn-flag quiet) | |
| 639 | (when (or input (pn-flag print-back-demod)) | |
| 640 | (with-output-simple-msg () | |
| 641 | (format t "* back demodulating ~d with ~d" | |
| 642 | (clause-id cl) | |
| 643 | (clause-id clause))))) | |
| 644 | (clause-full-un-index-slow cl) | |
| 645 | (setf (clause-container cl) nil) ; ** | |
| 646 | (setf (clause-parents cl) | |
| 647 | (nconc (clause-parents cl) | |
| 648 | (list (list :back-demod-rule (clause-id clause))))) | |
| 649 | ;; (pre-process cl input list-marker) | |
| 650 | (let ((new-cl (copy-clause cl))) | |
| 651 | (declare (type clause new-cl)) | |
| 652 | (setf (clause-parents new-cl) | |
| 653 | (list (cons :back-demod-rule | |
| 654 | (list (clause-id clause) (clause-id cl))))) | |
| 655 | (pre-process new-cl input list-marker) | |
| 656 | ) | |
| 657 | )) | |
| 658 | )) | |
| 631 | *full-lit-table* | |
| 632 | (demod-lhs demod)))) | |
| 633 | (declare (type list cls)) | |
| 634 | (dolist (cl cls) | |
| 635 | (declare (type clause cl)) | |
| 636 | (when (apply-demod-to-clause demod cl) | |
| 637 | (incf (pn-stat cl-back-demod)) | |
| 638 | (unless (pn-flag quiet) | |
| 639 | (when (or input (pn-flag print-back-demod)) | |
| 640 | (with-output-simple-msg () | |
| 641 | (format t "* back demodulating ~d with ~d" | |
| 642 | (clause-id cl) | |
| 643 | (clause-id clause))))) | |
| 644 | (clause-full-un-index-slow cl) | |
| 645 | (setf (clause-container cl) nil) ; ** | |
| 646 | (setf (clause-parents cl) | |
| 647 | (nconc (clause-parents cl) | |
| 648 | (list (list :back-demod-rule (clause-id clause))))) | |
| 649 | ;; (pre-process cl input list-marker) | |
| 650 | (let ((new-cl (copy-clause cl))) | |
| 651 | (declare (type clause new-cl)) | |
| 652 | (setf (clause-parents new-cl) | |
| 653 | (list (cons :back-demod-rule | |
| 654 | (list (clause-id clause) (clause-id cl))))) | |
| 655 | (pre-process new-cl input list-marker) | |
| 656 | ) | |
| 657 | )) | |
| 658 | )) | |
| 659 | 659 | )) |
| 660 | 660 | |
| 661 | 661 | #| |
| 662 | 662 | (defun back-demodulate (demod-list clause input list-marker) |
| 663 | 663 | (declare (type list demod-list) |
| 664 | (type clause clause) | |
| 665 | (type symbol list-marker)) | |
| 664 | (type clause clause) | |
| 665 | (type symbol list-marker)) | |
| 666 | 666 | (let ((demod (cdr (assq clause demod-list))) |
| 667 | (*demod-is-back-demod* t)) | |
| 667 | (*demod-is-back-demod* t)) | |
| 668 | 668 | (declare (type (or null demod) demod)) |
| 669 | 669 | (when demod |
| 670 | 670 | (let ((cls (get-clashable-clauses-from-atom |
| 671 | *full-lit-table* | |
| 672 | (demod-lhs demod)))) | |
| 673 | (declare (type list cls)) | |
| 674 | (dolist (cl cls) | |
| 675 | (declare (type clause cl)) | |
| 676 | (let ((new-cl (copy-clause cl))) | |
| 677 | (declare (type clause new-cl)) | |
| 678 | (when (apply-demod-to-clause demod new-cl) | |
| 679 | (incf (pn-stat cl-back-demod)) | |
| 680 | (unless (pn-flag quiet) | |
| 681 | (when (or input (pn-flag print-back-demod)) | |
| 682 | (with-output-simple-msg () | |
| 683 | (format t "* back demodulating ~d with ~d" | |
| 684 | (clause-id cl) | |
| 685 | (clause-id clause))))) | |
| 686 | (clause-full-un-index-slow cl) | |
| 687 | (setf (clause-container cl) nil) ; ** | |
| 688 | (setf (clause-parents new-cl) | |
| 689 | (list (cons :back-demod-rule | |
| 690 | (list (clause-id clause) (clause-id cl))))) | |
| 691 | (pre-process new-cl input list-marker) | |
| 692 | ) | |
| 693 | )) | |
| 694 | )) | |
| 671 | *full-lit-table* | |
| 672 | (demod-lhs demod)))) | |
| 673 | (declare (type list cls)) | |
| 674 | (dolist (cl cls) | |
| 675 | (declare (type clause cl)) | |
| 676 | (let ((new-cl (copy-clause cl))) | |
| 677 | (declare (type clause new-cl)) | |
| 678 | (when (apply-demod-to-clause demod new-cl) | |
| 679 | (incf (pn-stat cl-back-demod)) | |
| 680 | (unless (pn-flag quiet) | |
| 681 | (when (or input (pn-flag print-back-demod)) | |
| 682 | (with-output-simple-msg () | |
| 683 | (format t "* back demodulating ~d with ~d" | |
| 684 | (clause-id cl) | |
| 685 | (clause-id clause))))) | |
| 686 | (clause-full-un-index-slow cl) | |
| 687 | (setf (clause-container cl) nil) ; ** | |
| 688 | (setf (clause-parents new-cl) | |
| 689 | (list (cons :back-demod-rule | |
| 690 | (list (clause-id clause) (clause-id cl))))) | |
| 691 | (pre-process new-cl input list-marker) | |
| 692 | ) | |
| 693 | )) | |
| 694 | )) | |
| 695 | 695 | )) |
| 696 | 696 | |# |
| 697 | 697 | |
| 704 | 704 | |
| 705 | 705 | (defmacro pn-is-true? (atom) |
| 706 | 706 | (once-only (atom) |
| 707 | `(or (and (term-is-application-form? ,atom) | |
| 708 | (is-true? ,atom)) | |
| 709 | (and (term-is-variable? ,atom) | |
| 710 | (sort= (term-sort ,atom) *bool-sort*))))) | |
| 707 | `(or (and (term-is-application-form? ,atom) | |
| 708 | (is-true? ,atom)) | |
| 709 | (and (term-is-variable? ,atom) | |
| 710 | (sort= (term-sort ,atom) *bool-sort*))))) | |
| 711 | 711 | |
| 712 | 712 | (defmacro safe-is-true? (term) |
| 713 | 713 | (once-only (term) |
| 714 | `(and (term-is-applform? ,term) | |
| 715 | (is-true? ,term)))) | |
| 714 | `(and (term-is-applform? ,term) | |
| 715 | (is-true? ,term)))) | |
| 716 | 716 | |
| 717 | 717 | (defmacro safe-is-false? (term) |
| 718 | 718 | (once-only (term) |
| 719 | `(and (term-is-applform? ,term) | |
| 720 | (is-false? ,term)))) | |
| 719 | `(and (term-is-applform? ,term) | |
| 720 | (is-false? ,term)))) | |
| 721 | 721 | |
| 722 | 722 | (defun pn-is-false? (lit) |
| 723 | 723 | (declare (type literal lit)) |
| 731 | 731 | (format t "type = ~s" (literal-type lit))) |
| 732 | 732 | ||# |
| 733 | 733 | (and (term-is-application-form? atom) |
| 734 | (or (is-false? atom) | |
| 735 | (and (eq-literal? lit) | |
| 736 | (let ((a1 (term-arg-1 atom)) | |
| 737 | (a2 (term-arg-2 atom))) | |
| 738 | (or (and (term-is-builtin-constant? a1) | |
| 739 | (term-is-builtin-constant? a2) | |
| 740 | (not (term-builtin-equal a1 a2))) | |
| 741 | (and (safe-is-true? a1) (safe-is-false? a2)) | |
| 742 | (and (safe-is-false? a1) (safe-is-true? a2)))))))) | |
| 734 | (or (is-false? atom) | |
| 735 | (and (eq-literal? lit) | |
| 736 | (let ((a1 (term-arg-1 atom)) | |
| 737 | (a2 (term-arg-2 atom))) | |
| 738 | (or (and (term-is-builtin-constant? a1) | |
| 739 | (term-is-builtin-constant? a2) | |
| 740 | (not (term-builtin-equal a1 a2))) | |
| 741 | (and (safe-is-true? a1) (safe-is-false? a2)) | |
| 742 | (and (safe-is-false? a1) (safe-is-true? a2)))))))) | |
| 743 | 743 | ) |
| 744 | 744 | |
| 745 | 745 | (defun literal-true-false-reduce (clause) |
| 746 | 746 | (declare (type clause clause)) |
| 747 | 747 | (let ((literals nil) |
| 748 | (delete? nil)) | |
| 748 | (delete? nil)) | |
| 749 | 749 | (declare (type list literals)) |
| 750 | 750 | (dolist (lit (clause-literals clause)) |
| 751 | 751 | (declare (type literal lit)) |
| 752 | 752 | (let ((atom (literal-atom lit)) |
| 753 | (true? nil) | |
| 754 | (false? nil)) | |
| 755 | (declare (type term atom)) | |
| 756 | (setq true? (pn-is-true? atom)) | |
| 757 | (setq false? (pn-is-false? lit)) | |
| 758 | ;; | |
| 759 | (if (or true? false?) | |
| 760 | (if (or (and true? | |
| 761 | (positive-literal? lit)) | |
| 762 | (and false? | |
| 763 | (negative-literal? lit))) | |
| 764 | ;; literal is true, so clause is true. | |
| 765 | (return-from literal-true-false-reduce t) | |
| 766 | (if (or (and false? | |
| 767 | (positive-literal? lit)) | |
| 768 | (and true? | |
| 769 | (negative-literal? lit))) | |
| 770 | ;; literal is false, so delete it | |
| 771 | (setq delete? t) | |
| 772 | ;; else store it as is | |
| 773 | (push lit literals))) | |
| 774 | (push lit literals)))) | |
| 753 | (true? nil) | |
| 754 | (false? nil)) | |
| 755 | (declare (type term atom)) | |
| 756 | (setq true? (pn-is-true? atom)) | |
| 757 | (setq false? (pn-is-false? lit)) | |
| 758 | ;; | |
| 759 | (if (or true? false?) | |
| 760 | (if (or (and true? | |
| 761 | (positive-literal? lit)) | |
| 762 | (and false? | |
| 763 | (negative-literal? lit))) | |
| 764 | ;; literal is true, so clause is true. | |
| 765 | (return-from literal-true-false-reduce t) | |
| 766 | (if (or (and false? | |
| 767 | (positive-literal? lit)) | |
| 768 | (and true? | |
| 769 | (negative-literal? lit))) | |
| 770 | ;; literal is false, so delete it | |
| 771 | (setq delete? t) | |
| 772 | ;; else store it as is | |
| 773 | (push lit literals))) | |
| 774 | (push lit literals)))) | |
| 775 | 775 | ;; done |
| 776 | 776 | (when delete? |
| 777 | 777 | (setf (clause-literals clause) (nreverse literals)) |
| 784 | 784 | (with-in-module (mod) |
| 785 | 785 | (let ((opinfos (module-all-operators mod))) |
| 786 | 786 | (dolist (opinfo opinfos) |
| 787 | (dolist (m (opinfo-methods opinfo)) | |
| 788 | (when (method-is-meta-demod m) | |
| 789 | (let ((rules (method-all-rules m))) | |
| 790 | (dolist (rule rules) | |
| 791 | (let ((demod (make-demod :axiom rule | |
| 792 | :order :builtin | |
| 793 | :clause :builtin))) | |
| 794 | (push demod (gethash (term-head (rule-lhs rule)) | |
| 795 | *demodulators*))))))))))) | |
| 787 | (dolist (m (opinfo-methods opinfo)) | |
| 788 | (when (method-is-meta-demod m) | |
| 789 | (let ((rules (method-all-rules m))) | |
| 790 | (dolist (rule rules) | |
| 791 | (let ((demod (make-demod :axiom rule | |
| 792 | :order :builtin | |
| 793 | :clause :builtin))) | |
| 794 | (push demod (gethash (term-head (rule-lhs rule)) | |
| 795 | *demodulators*))))))))))) | |
| 796 | 796 | |
| 797 | 797 | ;;; SETUP-DEMODULATORS |
| 798 | 798 | |
| 0 | 0 | ** -*- Mode:CafeOBJ -*- |
| 1 | 1 | ** |
| 2 | ** Copyright (c) 2000-2014, Toshimi Sawada. All rights reserved. | |
| 2 | ** Copyright (c) 2000-2015, Toshimi Sawada. All rights reserved. | |
| 3 | 3 | ** |
| 4 | 4 | ** Redistribution and use in source and binary forms, with or without |
| 5 | 5 | ** modification, are permitted provided that the following conditions |
| 330 | 330 | make FOPLE-SENTENCE |
| 331 | 331 | (MFOPL+EQ-1(bool-as-truth-value, |
| 332 | 332 | FOPL-BASIC+EQ-1 { sort Sentence -> FoplSentence, |
| 333 | sort Var -> Cosmos, | |
| 334 | op and -> _&_, | |
| 335 | op or -> _|_, | |
| 336 | op imply -> (_->_), | |
| 337 | op iff -> _<->_, | |
| 338 | op forall -> \A[_]_, | |
| 339 | op exists -> \E[_]_, | |
| 340 | op not -> ~_, | |
| 341 | op eq -> _=_})) | |
| 333 | sort Var -> Cosmos, | |
| 334 | op and -> _&_, | |
| 335 | op or -> _|_, | |
| 336 | op imply -> (_->_), | |
| 337 | op iff -> _<->_, | |
| 338 | op forall -> \A[_]_, | |
| 339 | op exists -> \E[_]_, | |
| 340 | op not -> ~_, | |
| 341 | op eq -> _=_})) | |
| 342 | 342 | |
| 343 | 343 | ** |
| 344 | 344 | ** We need some Lisp accessible values for PigNose engine. |
| 378 | 378 | |
| 379 | 379 | eq[:BDEMOD]: EQ(X:Cosmos, Y:Cosmos) |
| 380 | 380 | = #!! (coerce-to-bool |
| 381 | (term-equational-equal x y)) . | |
| 381 | (term-equational-equal x y)) . | |
| 382 | 382 | eq[:BDEMOD]: NE(X:Cosmos, Y:Cosmos) |
| 383 | 383 | = #!! (coerce-to-bool |
| 384 | (not (term-equational-equal x y))) . | |
| 384 | (not (term-equational-equal x y))) . | |
| 385 | 385 | |
| 386 | 386 | } |
| 387 | 387 | |
| 0 | 0 | ;;;-*-Mode:LISP; Package: CHAOS; Base:10; Syntax:Common-lisp -*- |
| 1 | 1 | ;;; |
| 2 | ;;; Copyright (c) 2000-2014, Toshimi Sawada. All rights reserved. | |
| 2 | ;;; Copyright (c) 2000-2015, Toshimi Sawada. All rights reserved. | |
| 3 | 3 | ;;; |
| 4 | 4 | ;;; Redistribution and use in source and binary forms, with or without |
| 5 | 5 | ;;; modification, are permitted provided that the following conditions |
| 28 | 28 | ;;; |
| 29 | 29 | (in-package :chaos) |
| 30 | 30 | #|============================================================================= |
| 31 | System:Chaos | |
| 32 | Module:BigPink | |
| 33 | File:formula.lisp | |
| 31 | System:Chaos | |
| 32 | Module:BigPink | |
| 33 | File:formula.lisp | |
| 34 | 34 | =============================================================================|# |
| 35 | 35 | #-:chaos-debug |
| 36 | 36 | (declaim (optimize (speed 3) (safety 0) #-GCL (debug 0))) |
| 38 | 38 | (declaim (optimize (speed 1) (safety 3) #-GCL (debug 3))) |
| 39 | 39 | |
| 40 | 40 | ;;;***************************************************************************** |
| 41 | ;;; ALL ABOUT FOPL FORMULA | |
| 41 | ;;; ALL ABOUT FOPL FORMULA | |
| 42 | 42 | ;;;***************************************************************************** |
| 43 | 43 | |
| 44 | 44 | (defvar *debug-formula* nil) |
| 45 | 45 | (declaim (special *debug-formula-nest*) |
| 46 | (type fixnum *debug-formula-nest*)) | |
| 46 | (type fixnum *debug-formula-nest*)) | |
| 47 | 47 | (defvar *debug-formula-nest* 0) |
| 48 | 48 | |
| 49 | 49 | ;;;** golobals moved to `glob.lisp' |
| 65 | 65 | ;;; |
| 66 | 66 | (defun pn-term-equational-equal (t1 t2) |
| 67 | 67 | (declare (type term t1 t2) |
| 68 | (values (or null t))) | |
| 68 | (values (or null t))) | |
| 69 | 69 | (or (term-eq t1 t2) |
| 70 | 70 | (let ((t1-body (term-body t1)) |
| 71 | (t2-body (term-body t2))) | |
| 72 | (cond ((term$is-applform? t1-body) | |
| 73 | (let ((f1 (term$head t1-body))) | |
| 74 | ;; (break) | |
| 75 | (if (theory-info-empty-for-matching | |
| 76 | (method-theory-info-for-matching f1)) | |
| 77 | (match-with-empty-theory t1 t2) | |
| 78 | (E-equal-in-theory (method-theory f1) t1 t2))) | |
| 79 | ) | |
| 80 | ((term$is-builtin-constant? t1-body) | |
| 81 | (term$builtin-equal t1-body t2-body)) | |
| 82 | ((term$is-builtin-constant? t2-body) nil) | |
| 83 | ;; | |
| 84 | ((term$is-variable? t1-body) | |
| 85 | (setq *used==* t) | |
| 86 | (or (eq t1-body t2-body) | |
| 87 | (and (term$is-variable? t2-body) | |
| 88 | (eq (variable$name t1-body) (variable$name t2-body)) | |
| 89 | (eq (term$sort t1-body) (term$sort t2-body))) | |
| 90 | )) | |
| 91 | ((term$is-variable? t2-body) | |
| 92 | (setq *used==* t) | |
| 93 | nil) | |
| 94 | ((term$is-lisp-form? t1-body) | |
| 95 | (and (term$is-lisp-form? t2-body) | |
| 96 | (equal (term$lisp-code-original-form t1-body) | |
| 97 | (term$lisp-code-original-form t2-body)))) | |
| 98 | (t (break "pn-term-equational-equal: not-implemented ~s" t1)) | |
| 99 | )))) | |
| 71 | (t2-body (term-body t2))) | |
| 72 | (cond ((term$is-applform? t1-body) | |
| 73 | (let ((f1 (term$head t1-body))) | |
| 74 | ;; (break) | |
| 75 | (if (theory-info-empty-for-matching | |
| 76 | (method-theory-info-for-matching f1)) | |
| 77 | (match-with-empty-theory t1 t2) | |
| 78 | (E-equal-in-theory (method-theory f1) t1 t2))) | |
| 79 | ) | |
| 80 | ((term$is-builtin-constant? t1-body) | |
| 81 | (term$builtin-equal t1-body t2-body)) | |
| 82 | ((term$is-builtin-constant? t2-body) nil) | |
| 83 | ;; | |
| 84 | ((term$is-variable? t1-body) | |
| 85 | (setq *used==* t) | |
| 86 | (or (eq t1-body t2-body) | |
| 87 | (and (term$is-variable? t2-body) | |
| 88 | (eq (variable$name t1-body) (variable$name t2-body)) | |
| 89 | (eq (term$sort t1-body) (term$sort t2-body))) | |
| 90 | )) | |
| 91 | ((term$is-variable? t2-body) | |
| 92 | (setq *used==* t) | |
| 93 | nil) | |
| 94 | ((term$is-lisp-form? t1-body) | |
| 95 | (and (term$is-lisp-form? t2-body) | |
| 96 | (equal (term$lisp-code-original-form t1-body) | |
| 97 | (term$lisp-code-original-form t2-body)))) | |
| 98 | (t (break "pn-term-equational-equal: not-implemented ~s" t1)) | |
| 99 | )))) | |
| 100 | 100 | |
| 101 | 101 | ;;; ======================================== |
| 102 | 102 | ;;; FOPL FORMULA --> CLAUSE FORM TRANSLATION |
| 106 | 106 | ;;; given a fopl sentence translates it to list of clauses. |
| 107 | 107 | ;;; |
| 108 | 108 | (declaim (special *current-formula*) |
| 109 | (type (or null term) *current-formula*)) | |
| 109 | (type (or null term) *current-formula*)) | |
| 110 | 110 | (defvar *current-formula* nil) |
| 111 | 111 | |
| 112 | 112 | (defun formula->clause-1 (sentence psys &optional (axiom nil)) |
| 113 | 113 | (declare (type (or null term) sentence) |
| 114 | (type psystem psys) | |
| 115 | (type (or null axiom) axiom) | |
| 116 | (values list)) | |
| 114 | (type psystem psys) | |
| 115 | (type (or null axiom) axiom) | |
| 116 | (values list)) | |
| 117 | 117 | (if sentence |
| 118 | 118 | (let ((*current-formula* sentence)) |
| 119 | ;; translate to Conjunctive Normal Form. | |
| 120 | (cnf sentence psys) | |
| 121 | ;; to clause list | |
| 122 | (setq $$raw-clause (cnf-to-list sentence psys)) | |
| 123 | ;; | |
| 124 | (dolist (cl $$raw-clause) | |
| 125 | (setf (clause-axiom cl) axiom) | |
| 126 | (cl-unique-variables cl)) | |
| 127 | $$raw-clause) | |
| 119 | ;; translate to Conjunctive Normal Form. | |
| 120 | (cnf sentence psys) | |
| 121 | ;; to clause list | |
| 122 | (setq $$raw-clause (cnf-to-list sentence psys)) | |
| 123 | ;; | |
| 124 | (dolist (cl $$raw-clause) | |
| 125 | (setf (clause-axiom cl) axiom) | |
| 126 | (cl-unique-variables cl)) | |
| 127 | $$raw-clause) | |
| 128 | 128 | nil)) |
| 129 | 129 | |
| 130 | 130 | ;;; CNF : FoplSentence -> FoplSentence' |
| 132 | 132 | ;;; |
| 133 | 133 | (defun cnf (sentence psys) |
| 134 | 134 | (declare (type term sentence) |
| 135 | (type psystem psys) | |
| 136 | (values term)) | |
| 135 | (type psystem psys) | |
| 136 | (values term)) | |
| 137 | 137 | (when *debug-formula* |
| 138 | (format t "~&** start formula to cnf translation **") | |
| 138 | (format t "~%** start formula to cnf translation **") | |
| 139 | 139 | (print-next) |
| 140 | 140 | (with-in-module ((psystem-module psys)) |
| 141 | 141 | (term-print sentence))) |
| 144 | 144 | (let ((type (fopl-sentence-type sentence))) |
| 145 | 145 | (declare (type symbol type)) |
| 146 | 146 | (when (and (memq type '(:eq :beq)) |
| 147 | (term-is-lisp-form? (term-arg-2 sentence))) | |
| 147 | (term-is-lisp-form? (term-arg-2 sentence))) | |
| 148 | 148 | (return-from cnf sentence))) |
| 149 | 149 | |
| 150 | 150 | ;; normalize quantified formula |
| 169 | 169 | ;; convert to CNF(conjunctive normal form). |
| 170 | 170 | (conj-normal-form sentence) |
| 171 | 171 | (when *debug-formula* |
| 172 | (format t "~&*** done ***")) | |
| 172 | (format t "~%*** done ***")) | |
| 173 | 173 | sentence |
| 174 | 174 | ) |
| 175 | 175 | |
| 178 | 178 | ;;; skolemize then apply nnf. |
| 179 | 179 | (defun nnf-skolemize (sentence) |
| 180 | 180 | (declare (type term sentence) |
| 181 | (values term)) | |
| 181 | (values term)) | |
| 182 | 182 | (check-fopl-syntax sentence) |
| 183 | 183 | (unique-all-variables |
| 184 | 184 | (skolemize (neg-normal-form (normalize-quantifiers sentence)))) |
| 190 | 190 | ;;; |
| 191 | 191 | (defun cafeobj-term->formula (f) |
| 192 | 192 | (declare (type term f) |
| 193 | (values term)) | |
| 193 | (values term)) | |
| 194 | 194 | (when *debug-formula* |
| 195 | (format t "~&[cafeobj-term->formula]: ") | |
| 195 | (format t "~%[cafeobj-term->formula]: ") | |
| 196 | 196 | (term-print f)) |
| 197 | 197 | (let ((res nil)) |
| 198 | 198 | (declare (type (or null term) res)) |
| 199 | 199 | (cond ((term-is-application-form? f) |
| 200 | (let ((args (mapcar #'(lambda (x) (cafeobj-term->formula x)) | |
| 201 | (term-subterms f))) | |
| 202 | (head (term-head f))) | |
| 203 | (declare (type list args) | |
| 204 | (type method head)) | |
| 205 | (setq f (make-applform-simple (term-sort f) | |
| 206 | head | |
| 207 | args)) | |
| 208 | (cond ((memq head (list *bool-equal* *beh-equal* *eql-op*)) | |
| 209 | #|| | |
| 210 | (when (eq head *beh-eq-pred*) | |
| 211 | (with-output-chaos-warning () | |
| 212 | (format t "=*= cannot be used: ") | |
| 213 | (term-print f))) | |
| 214 | ||# | |
| 215 | (setq res | |
| 216 | (make-term-with-sort-check *fopl-eq* | |
| 217 | (list (term-arg-1 f) | |
| 218 | (term-arg-2 f))))) | |
| 219 | ((eq head *bool-nonequal*) | |
| 220 | (setq res | |
| 221 | (make-term-with-sort-check | |
| 222 | *fopl-neg* | |
| 223 | (list | |
| 224 | (make-term-with-sort-check *fopl-eq* | |
| 225 | (list (term-arg-1 f) | |
| 226 | (term-arg-2 f))))))) | |
| 227 | ((memq head (list *bool-and* | |
| 228 | *bool-or* | |
| 229 | *bool-imply* | |
| 230 | *bool-iff* | |
| 231 | *bool-and-also* | |
| 232 | *bool-or-else* | |
| 233 | )) | |
| 234 | (setq res | |
| 235 | (make-term-with-sort-check | |
| 236 | (if (or (eq head *bool-and*) | |
| 237 | (eq head *bool-and-also*)) | |
| 238 | *fopl-and* | |
| 239 | (if (or (eq head *bool-or*) | |
| 240 | (eq head *bool-or-else*)) | |
| 241 | *fopl-or* | |
| 242 | ;; *bool-imply* | |
| 243 | (if (eq head *bool-imply*) | |
| 244 | *fopl-imply* | |
| 245 | ;; else *bool-iff* | |
| 246 | *fopl-iff*) | |
| 247 | )) | |
| 248 | (list (term-arg-1 f) | |
| 249 | (term-arg-2 f)))) | |
| 250 | (when (or (eq head *bool-and-also*) | |
| 251 | (eq head *bool-or-else*)) | |
| 252 | (with-output-chaos-warning () | |
| 253 | (format t "operator ~{~a~} is appeared in FOPL sentence, replacing..." | |
| 254 | (method-symbol head)))) | |
| 255 | ) | |
| 256 | ;; | |
| 257 | ((eq head *bool-not*) | |
| 258 | (setq res | |
| 259 | (make-term-with-sort-check | |
| 260 | *fopl-neg* | |
| 261 | (list (term-arg-1 f))))) | |
| 262 | ((eq head *bool-xor*) | |
| 263 | ;; p xor q --> (~p | ~q)&(p | q) | |
| 264 | (setq res | |
| 265 | (make-term-with-sort-check | |
| 266 | *fopl-and* | |
| 267 | (list | |
| 268 | (make-term-with-sort-check | |
| 269 | *fopl-or* | |
| 270 | (list | |
| 271 | (make-term-with-sort-check | |
| 272 | *fopl-neg* | |
| 273 | (list (term-arg-1 f))) | |
| 274 | (make-term-with-sort-check | |
| 275 | *fopl-neg* | |
| 276 | (list (term-arg-2 f))))) | |
| 277 | (make-term-with-sort-check | |
| 278 | *fopl-or* | |
| 279 | (list (allocate-new-term-cell (term-arg-1 f)) | |
| 280 | (allocate-new-term-cell (term-arg-2 f)))))) | |
| 281 | )) | |
| 282 | ;;; | |
| 283 | #|| | |
| 284 | ((eq head *bool-if*) | |
| 285 | (when (and (sort= (term-sort (term-arg-1 f)) *bool-sort*) | |
| 286 | (sort= (term-sort (term-arg-2 f)) *bool-sort*)) | |
| 287 | )) | |
| 288 | ||# | |
| 289 | ;;; | |
| 290 | ((memq head (list *bool-if* | |
| 291 | *beh-eq-pred* | |
| 292 | ;; *bool-and-also* | |
| 293 | ;; *bool-or-else* | |
| 294 | *sort-membership*)) | |
| 295 | (with-output-chaos-warning () | |
| 296 | (format t "you cannot use ~a: " (method-symbol head)) | |
| 297 | (term-print f)) | |
| 298 | (setq res (copy-term-reusing-variables f | |
| 299 | (term-variables f)))) | |
| 300 | ;; | |
| 301 | (t (setq res | |
| 302 | (copy-term-reusing-variables f | |
| 303 | (term-variables f))))) | |
| 304 | )) | |
| 305 | ;; | |
| 306 | ((term-is-variable? f) | |
| 307 | (setq res f)) | |
| 308 | ;; | |
| 309 | (t (setq res (simple-copy-term f)))) | |
| 200 | (let ((args (mapcar #'(lambda (x) (cafeobj-term->formula x)) | |
| 201 | (term-subterms f))) | |
| 202 | (head (term-head f))) | |
| 203 | (declare (type list args) | |
| 204 | (type method head)) | |
| 205 | (setq f (make-applform-simple (term-sort f) | |
| 206 | head | |
| 207 | args)) | |
| 208 | (cond ((memq head (list *bool-equal* *beh-equal* *eql-op*)) | |
| 209 | #|| | |
| 210 | (when (eq head *beh-eq-pred*) | |
| 211 | (with-output-chaos-warning () | |
| 212 | (format t "=*= cannot be used: ") | |
| 213 | (term-print f))) | |
| 214 | ||# | |
| 215 | (setq res | |
| 216 | (make-term-with-sort-check *fopl-eq* | |
| 217 | (list (term-arg-1 f) | |
| 218 | (term-arg-2 f))))) | |
| 219 | ((eq head *bool-nonequal*) | |
| 220 | (setq res | |
| 221 | (make-term-with-sort-check | |
| 222 | *fopl-neg* | |
| 223 | (list | |
| 224 | (make-term-with-sort-check *fopl-eq* | |
| 225 | (list (term-arg-1 f) | |
| 226 | (term-arg-2 f))))))) | |
| 227 | ((memq head (list *bool-and* | |
| 228 | *bool-or* | |
| 229 | *bool-imply* | |
| 230 | *bool-iff* | |
| 231 | *bool-and-also* | |
| 232 | *bool-or-else* | |
| 233 | )) | |
| 234 | (setq res | |
| 235 | (make-term-with-sort-check | |
| 236 | (if (or (eq head *bool-and*) | |
| 237 | (eq head *bool-and-also*)) | |
| 238 | *fopl-and* | |
| 239 | (if (or (eq head *bool-or*) | |
| 240 | (eq head *bool-or-else*)) | |
| 241 | *fopl-or* | |
| 242 | ;; *bool-imply* | |
| 243 | (if (eq head *bool-imply*) | |
| 244 | *fopl-imply* | |
| 245 | ;; else *bool-iff* | |
| 246 | *fopl-iff*) | |
| 247 | )) | |
| 248 | (list (term-arg-1 f) | |
| 249 | (term-arg-2 f)))) | |
| 250 | (when (or (eq head *bool-and-also*) | |
| 251 | (eq head *bool-or-else*)) | |
| 252 | (with-output-chaos-warning () | |
| 253 | (format t "operator ~{~a~} is appeared in FOPL sentence, replacing..." | |
| 254 | (method-symbol head)))) | |
| 255 | ) | |
| 256 | ;; | |
| 257 | ((eq head *bool-not*) | |
| 258 | (setq res | |
| 259 | (make-term-with-sort-check | |
| 260 | *fopl-neg* | |
| 261 | (list (term-arg-1 f))))) | |
| 262 | ((eq head *bool-xor*) | |
| 263 | ;; p xor q --> (~p | ~q)&(p | q) | |
| 264 | (setq res | |
| 265 | (make-term-with-sort-check | |
| 266 | *fopl-and* | |
| 267 | (list | |
| 268 | (make-term-with-sort-check | |
| 269 | *fopl-or* | |
| 270 | (list | |
| 271 | (make-term-with-sort-check | |
| 272 | *fopl-neg* | |
| 273 | (list (term-arg-1 f))) | |
| 274 | (make-term-with-sort-check | |
| 275 | *fopl-neg* | |
| 276 | (list (term-arg-2 f))))) | |
| 277 | (make-term-with-sort-check | |
| 278 | *fopl-or* | |
| 279 | (list (allocate-new-term-cell (term-arg-1 f)) | |
| 280 | (allocate-new-term-cell (term-arg-2 f)))))) | |
| 281 | )) | |
| 282 | ;;; | |
| 283 | #|| | |
| 284 | ((eq head *bool-if*) | |
| 285 | (when (and (sort= (term-sort (term-arg-1 f)) *bool-sort*) | |
| 286 | (sort= (term-sort (term-arg-2 f)) *bool-sort*)) | |
| 287 | )) | |
| 288 | ||# | |
| 289 | ;;; | |
| 290 | ((memq head (list *bool-if* | |
| 291 | *beh-eq-pred* | |
| 292 | ;; *bool-and-also* | |
| 293 | ;; *bool-or-else* | |
| 294 | *sort-membership*)) | |
| 295 | (with-output-chaos-warning () | |
| 296 | (format t "you cannot use ~a: " (method-symbol head)) | |
| 297 | (term-print f)) | |
| 298 | (setq res (copy-term-reusing-variables f | |
| 299 | (term-variables f)))) | |
| 300 | ;; | |
| 301 | (t (setq res | |
| 302 | (copy-term-reusing-variables f | |
| 303 | (term-variables f))))) | |
| 304 | )) | |
| 305 | ;; | |
| 306 | ((term-is-variable? f) | |
| 307 | (setq res f)) | |
| 308 | ;; | |
| 309 | (t (setq res (simple-copy-term f)))) | |
| 310 | 310 | (when *debug-formula* |
| 311 | 311 | (print-next) |
| 312 | 312 | (term-print res)) |
| 318 | 318 | (defun normalize-quantifiers (form) |
| 319 | 319 | (declare (type term form)) |
| 320 | 320 | (let ((bound-vars nil) |
| 321 | (all-vars (term-variables form)) | |
| 322 | (free-vars nil) | |
| 323 | (res nil)) | |
| 321 | (all-vars (term-variables form)) | |
| 322 | (free-vars nil) | |
| 323 | (res nil)) | |
| 324 | 324 | (declare (type list bound-vars all-vars free-vars) |
| 325 | (type (or null term) res)) | |
| 325 | (type (or null term) res)) | |
| 326 | 326 | (labels ((nq (sentence) |
| 327 | (let ((type (fopl-sentence-type sentence)) | |
| 328 | (*debug-formula-nest* (1+ *debug-formula-nest*))) | |
| 329 | (declare (type symbol type)) | |
| 330 | (when *debug-formula* | |
| 331 | (format t "~&~d>[normalize-quantifiers]: " | |
| 332 | *debug-formula-nest*) | |
| 333 | (term-print sentence)) | |
| 334 | (case type | |
| 335 | (:atom) ; nothing to do | |
| 336 | ((:forall :exists) | |
| 337 | (let ((vardecls (term-arg-1 sentence))) | |
| 338 | (cond ((term-is-variable? vardecls) | |
| 339 | (pushnew vardecls bound-vars | |
| 340 | :test #'variable-eq) | |
| 341 | sentence) | |
| 342 | (t (let ((vars (reverse (term-variables vardecls))) | |
| 343 | (new-form nil)) | |
| 344 | (dolist (v vars) | |
| 345 | (pushnew v bound-vars :test #'variable-eq)) | |
| 346 | (setq new-form | |
| 347 | (make-term-with-sort-check | |
| 348 | (if (eq type :forall) | |
| 349 | *fopl-forall* | |
| 350 | *fopl-exists*) | |
| 351 | (list (car vars) | |
| 352 | (term-arg-2 sentence)))) | |
| 353 | (dolist (v (cdr vars)) | |
| 354 | (setq new-form | |
| 355 | (make-term-with-sort-check | |
| 356 | (if (eq type :forall) | |
| 357 | *fopl-forall* | |
| 358 | *fopl-exists*) | |
| 359 | (list v new-form)))) | |
| 360 | (term-replace sentence new-form) | |
| 361 | )))) | |
| 362 | ;; recurse | |
| 363 | (nq (term-arg-2 sentence)) | |
| 364 | ) | |
| 365 | (:not (nq (term-arg-1 sentence))) | |
| 366 | (otherwise | |
| 367 | (nq (term-arg-1 sentence)) | |
| 368 | (nq (term-arg-2 sentence)) | |
| 369 | )) | |
| 370 | ;; | |
| 371 | (when *debug-formula* | |
| 372 | (format t "~&<~d " *debug-formula-nest*) | |
| 373 | (term-print sentence)) | |
| 374 | ;; | |
| 375 | sentence))) | |
| 327 | (let ((type (fopl-sentence-type sentence)) | |
| 328 | (*debug-formula-nest* (1+ *debug-formula-nest*))) | |
| 329 | (declare (type symbol type)) | |
| 330 | (when *debug-formula* | |
| 331 | (format t "~%~d>[normalize-quantifiers]: " | |
| 332 | *debug-formula-nest*) | |
| 333 | (term-print sentence)) | |
| 334 | (case type | |
| 335 | (:atom) ; nothing to do | |
| 336 | ((:forall :exists) | |
| 337 | (let ((vardecls (term-arg-1 sentence))) | |
| 338 | (cond ((term-is-variable? vardecls) | |
| 339 | (pushnew vardecls bound-vars | |
| 340 | :test #'variable-eq) | |
| 341 | sentence) | |
| 342 | (t (let ((vars (reverse (term-variables vardecls))) | |
| 343 | (new-form nil)) | |
| 344 | (dolist (v vars) | |
| 345 | (pushnew v bound-vars :test #'variable-eq)) | |
| 346 | (setq new-form | |
| 347 | (make-term-with-sort-check | |
| 348 | (if (eq type :forall) | |
| 349 | *fopl-forall* | |
| 350 | *fopl-exists*) | |
| 351 | (list (car vars) | |
| 352 | (term-arg-2 sentence)))) | |
| 353 | (dolist (v (cdr vars)) | |
| 354 | (setq new-form | |
| 355 | (make-term-with-sort-check | |
| 356 | (if (eq type :forall) | |
| 357 | *fopl-forall* | |
| 358 | *fopl-exists*) | |
| 359 | (list v new-form)))) | |
| 360 | (term-replace sentence new-form) | |
| 361 | )))) | |
| 362 | ;; recurse | |
| 363 | (nq (term-arg-2 sentence)) | |
| 364 | ) | |
| 365 | (:not (nq (term-arg-1 sentence))) | |
| 366 | (otherwise | |
| 367 | (nq (term-arg-1 sentence)) | |
| 368 | (nq (term-arg-2 sentence)) | |
| 369 | )) | |
| 370 | ;; | |
| 371 | (when *debug-formula* | |
| 372 | (format t "~%<~d " *debug-formula-nest*) | |
| 373 | (term-print sentence)) | |
| 374 | ;; | |
| 375 | sentence))) | |
| 376 | 376 | ;; |
| 377 | 377 | (setq res (nq form)) |
| 378 | 378 | (setq free-vars (set-difference all-vars |
| 379 | bound-vars | |
| 380 | :test #'variable-eq)) | |
| 379 | bound-vars | |
| 380 | :test #'variable-eq)) | |
| 381 | 381 | (when free-vars |
| 382 | (let ((new-form (copy-term-reusing-variables | |
| 383 | (make-universal-closure free-vars res) | |
| 384 | all-vars))) | |
| 385 | (term-replace res new-form))) | |
| 382 | (let ((new-form (copy-term-reusing-variables | |
| 383 | (make-universal-closure free-vars res) | |
| 384 | all-vars))) | |
| 385 | (term-replace res new-form))) | |
| 386 | 386 | ))) |
| 387 | ||
| 387 | ||
| 388 | 388 | (defun make-universal-closure (var-list sentence) |
| 389 | 389 | (declare (type list var-list) |
| 390 | (type term)) | |
| 390 | (type term)) | |
| 391 | 391 | (let ((res nil)) |
| 392 | 392 | (declare (type (or null term) res)) |
| 393 | 393 | (dolist (var var-list) |
| 394 | 394 | (declare (type term var)) |
| 395 | 395 | (if res |
| 396 | (setq res (make-term-with-sort-check *fopl-forall* | |
| 397 | (list var res))) | |
| 398 | (setq res (make-term-with-sort-check *fopl-forall* | |
| 399 | (list var sentence))))) | |
| 396 | (setq res (make-term-with-sort-check *fopl-forall* | |
| 397 | (list var res))) | |
| 398 | (setq res (make-term-with-sort-check *fopl-forall* | |
| 399 | (list var sentence))))) | |
| 400 | 400 | res)) |
| 401 | 401 | |
| 402 | 402 | ;;; NETGATE-SENTENCE : Sentence -> Sentence |
| 406 | 406 | ;;; |
| 407 | 407 | (defun negate-sentence (sentence &optional copy variables) |
| 408 | 408 | (declare (type term sentence) |
| 409 | (type list variables)) | |
| 409 | (type list variables)) | |
| 410 | 410 | (let ((type (fopl-sentence-type sentence))) |
| 411 | 411 | (declare (type symbol type)) |
| 412 | 412 | (when *debug-formula* |
| 413 | 413 | (with-output-msg() |
| 414 | (princ "> negate-sentence: ") | |
| 415 | (term-print sentence))) | |
| 414 | (princ "> negate-sentence: ") | |
| 415 | (term-print sentence))) | |
| 416 | 416 | (case type |
| 417 | 417 | (:not |
| 418 | 418 | (let ((new-term (if copy |
| 419 | (copy-term-reusing-variables (term-arg-1 | |
| 420 | sentence) | |
| 421 | variables) | |
| 422 | (allocate-new-term-cell (term-arg-1 sentence))))) | |
| 423 | ;; (term-replace sentence new-term) | |
| 424 | (setq sentence new-term))) | |
| 419 | (copy-term-reusing-variables (term-arg-1 | |
| 420 | sentence) | |
| 421 | variables) | |
| 422 | (allocate-new-term-cell (term-arg-1 sentence))))) | |
| 423 | ;; (term-replace sentence new-term) | |
| 424 | (setq sentence new-term))) | |
| 425 | 425 | (otherwise |
| 426 | 426 | (let ((new-term (make-term-with-sort-check |
| 427 | *fopl-neg* | |
| 428 | (list (if copy | |
| 429 | (copy-term-reusing-variables sentence variables) | |
| 430 | (allocate-new-term-cell sentence)))))) | |
| 431 | ;; (term-replace sentence new-term) | |
| 432 | (setq sentence new-term) | |
| 433 | ))) | |
| 427 | *fopl-neg* | |
| 428 | (list (if copy | |
| 429 | (copy-term-reusing-variables sentence variables) | |
| 430 | (allocate-new-term-cell sentence)))))) | |
| 431 | ;; (term-replace sentence new-term) | |
| 432 | (setq sentence new-term) | |
| 433 | ))) | |
| 434 | 434 | (when *debug-formula* |
| 435 | 435 | (with-output-msg () |
| 436 | (princ "< negate-sentence: ") | |
| 437 | (term-print sentence))) | |
| 436 | (princ "< negate-sentence: ") | |
| 437 | (term-print sentence))) | |
| 438 | 438 | sentence)) |
| 439 | 439 | |
| 440 | 440 | ;;; NEG-NORMAL-FORM : Sentence -> Sentence' |
| 452 | 452 | |
| 453 | 453 | (defun neg-normal-form (sentence &optional variables) |
| 454 | 454 | (declare (type term sentence) |
| 455 | (type list variables)) | |
| 455 | (type list variables)) | |
| 456 | 456 | (let ((type (fopl-sentence-type sentence)) |
| 457 | (*debug-formula-nest* (1+ *debug-formula-nest*))) | |
| 457 | (*debug-formula-nest* (1+ *debug-formula-nest*))) | |
| 458 | 458 | (declare (type symbol type)) |
| 459 | 459 | (when *debug-formula* |
| 460 | (format t "~&~d>[neg-normal-form]: " | |
| 461 | *debug-formula-nest*) | |
| 460 | (format t "~%~d>[neg-normal-form]: " | |
| 461 | *debug-formula-nest*) | |
| 462 | 462 | (term-print sentence)) |
| 463 | 463 | (case type |
| 464 | 464 | (:atom sentence) |
| 465 | 465 | ;; A <-> B ---> neg-normal-form((~A | B) & (~B | A)) |
| 466 | 466 | (:iff |
| 467 | 467 | (let ((old-arg1 (allocate-new-term-cell (term-arg-1 sentence))) ; A |
| 468 | (old-arg2 (allocate-new-term-cell (term-arg-2 sentence)))) ; B | |
| 469 | (let* ((new-arg1 ; ~A | B | |
| 470 | (make-term-with-sort-check | |
| 471 | *fopl-or* | |
| 472 | (list (negate-sentence old-arg1 :copy variables) ; ~A | |
| 473 | (copy-term-reusing-variables old-arg2 ; B | |
| 474 | variables) | |
| 475 | ))) | |
| 476 | (new-arg2 | |
| 477 | (make-term-with-sort-check | |
| 478 | *fopl-or* | |
| 479 | (list (negate-sentence old-arg2 :copy variables) ; ~B | |
| 480 | (copy-term-reusing-variables (term-arg-1 sentence) | |
| 481 | variables) ; A | |
| 482 | )))) | |
| 483 | (term-replace sentence | |
| 484 | (make-term-with-sort-check | |
| 485 | *fopl-and* | |
| 486 | (list new-arg1 new-arg2))) | |
| 487 | (neg-normal-form sentence variables) | |
| 488 | sentence))) | |
| 468 | (old-arg2 (allocate-new-term-cell (term-arg-2 sentence)))) ; B | |
| 469 | (let* ((new-arg1 ; ~A | B | |
| 470 | (make-term-with-sort-check | |
| 471 | *fopl-or* | |
| 472 | (list (negate-sentence old-arg1 :copy variables) ; ~A | |
| 473 | (copy-term-reusing-variables old-arg2 ; B | |
| 474 | variables) | |
| 475 | ))) | |
| 476 | (new-arg2 | |
| 477 | (make-term-with-sort-check | |
| 478 | *fopl-or* | |
| 479 | (list (negate-sentence old-arg2 :copy variables) ; ~B | |
| 480 | (copy-term-reusing-variables (term-arg-1 sentence) | |
| 481 | variables) ; A | |
| 482 | )))) | |
| 483 | (term-replace sentence | |
| 484 | (make-term-with-sort-check | |
| 485 | *fopl-and* | |
| 486 | (list new-arg1 new-arg2))) | |
| 487 | (neg-normal-form sentence variables) | |
| 488 | sentence))) | |
| 489 | 489 | ;; A -> B ---> neg-normal-form(~A | B) |
| 490 | 490 | (:imply |
| 491 | 491 | (term-replace |
| 492 | sentence | |
| 493 | (make-term-with-sort-check | |
| 494 | *fopl-or* | |
| 495 | (list (negate-sentence (term-arg-1 sentence) :copy variables) | |
| 496 | (copy-term-reusing-variables (term-arg-2 sentence) | |
| 497 | variables)))) | |
| 492 | sentence | |
| 493 | (make-term-with-sort-check | |
| 494 | *fopl-or* | |
| 495 | (list (negate-sentence (term-arg-1 sentence) :copy variables) | |
| 496 | (copy-term-reusing-variables (term-arg-2 sentence) | |
| 497 | variables)))) | |
| 498 | 498 | (neg-normal-form sentence variables) |
| 499 | 499 | sentence) |
| 500 | 500 | ;; \A[Vars]Formula ---> \A[Vars] neg-normal-form(Formula) |
| 501 | 501 | ;; same as for \E |
| 502 | 502 | ((:forall :exists) |
| 503 | 503 | (setf (term-arg-2 sentence) |
| 504 | (neg-normal-form (term-arg-2 sentence) variables)) | |
| 504 | (neg-normal-form (term-arg-2 sentence) variables)) | |
| 505 | 505 | sentence) |
| 506 | 506 | ;; A & B ---> neg-normal-form(A) & neg-normal-form(B) |
| 507 | 507 | ;; same as for | |
| 508 | 508 | ((:and :or :eq :beq) |
| 509 | 509 | (setf (term-arg-1 sentence) |
| 510 | (neg-normal-form (term-arg-1 sentence) variables)) | |
| 510 | (neg-normal-form (term-arg-1 sentence) variables)) | |
| 511 | 511 | (setf (term-arg-2 sentence) |
| 512 | (neg-normal-form (term-arg-2 sentence) variables)) | |
| 512 | (neg-normal-form (term-arg-2 sentence) variables)) | |
| 513 | 513 | sentence) |
| 514 | 514 | ;; not |
| 515 | 515 | (:not |
| 516 | 516 | (let* ((arg (term-arg-1 sentence)) |
| 517 | (arg-type (fopl-sentence-type arg))) | |
| 518 | (case arg-type | |
| 519 | ;; | |
| 520 | (:atom | |
| 521 | ;; ******************* | |
| 522 | (when (term-is-applform? arg) | |
| 523 | (if (is-true? arg) | |
| 524 | (term-replace sentence (new-term *bool-false*)) | |
| 525 | (if (is-false? arg) | |
| 526 | (term-replace sentence (new-term *bool-true*))))) | |
| 527 | ;; ******************* | |
| 528 | sentence) | |
| 529 | ||
| 530 | ;; ~(A -> B) --> neg-normal-form(~(~A | B)) | |
| 531 | (:imply | |
| 532 | (setf (term-arg-1 sentence) | |
| 533 | (make-term-with-sort-check | |
| 534 | *fopl-or* | |
| 535 | (list (negate-sentence (term-arg-1 arg) :copy variables) | |
| 536 | (allocate-new-term-cell (term-arg-2 arg))))) | |
| 537 | (neg-normal-form sentence variables) | |
| 538 | sentence) | |
| 539 | ;; ~(A <-> B) --> neg-normal-form((A|B) & (~A | ~B)) | |
| 540 | (:iff | |
| 541 | (let ((old-arg1 (allocate-new-term-cell (term-arg-1 arg))) | |
| 542 | (old-arg2 (allocate-new-term-cell (term-arg-2 arg)))) | |
| 543 | (term-replace | |
| 544 | sentence | |
| 545 | (make-term-with-sort-check | |
| 546 | *fopl-and* | |
| 547 | (list | |
| 548 | (make-term-with-sort-check ; A | B | |
| 549 | *fopl-or* | |
| 550 | (list old-arg1 old-arg2)) | |
| 551 | (make-term-with-sort-check ; ~A | ~B | |
| 552 | *fopl-or* | |
| 553 | (list (negate-sentence (term-arg-1 arg) :copy variables) | |
| 554 | (negate-sentence (term-arg-2 arg) :copy variables)))))) | |
| 555 | (neg-normal-form sentence variables) | |
| 556 | sentence)) | |
| 557 | ;; ~\A[Vars]S --> \E[Vars]neg-normal-form(~S) | |
| 558 | ;; ~\E[Vars]S --> \A[Vars]neg-normal-form(~S) | |
| 559 | ((:forall :exists) | |
| 560 | (term-replace sentence | |
| 561 | (make-term-with-sort-check | |
| 562 | (if (eq arg-type :forall) | |
| 563 | *fopl-exists* | |
| 564 | *fopl-forall*) | |
| 565 | (list (allocate-new-term-cell | |
| 566 | (term-arg-1 arg)) ; var list | |
| 567 | (neg-normal-form (negate-sentence | |
| 568 | (term-arg-2 arg) | |
| 569 | nil | |
| 570 | variables) | |
| 571 | variables)))) | |
| 572 | sentence) | |
| 573 | ;; ~(A & B) --> neg-normal-form(~A) | neg-normal-form(~B) | |
| 574 | ;; ~(A | B) --> neg-normal-form(~A) & neg-normal-form(~B) | |
| 575 | ((:and :or) | |
| 576 | (term-replace sentence | |
| 577 | (make-term-with-sort-check | |
| 578 | (if (eq arg-type :and) | |
| 579 | *fopl-or* | |
| 580 | *fopl-and*) | |
| 581 | (list | |
| 582 | (neg-normal-form (negate-sentence (term-arg-1 arg) | |
| 583 | :copy variables) | |
| 584 | variables) | |
| 585 | (neg-normal-form (negate-sentence (term-arg-2 arg) | |
| 586 | :copy variables) | |
| 587 | variables)))) | |
| 588 | sentence) | |
| 589 | ;; ~~A --> neg-normal-form(A) | |
| 590 | (:not ; double negation | |
| 591 | (term-replace sentence | |
| 592 | (neg-normal-form (term-arg-1 arg) variables)) | |
| 593 | sentence) | |
| 594 | ))) | |
| 517 | (arg-type (fopl-sentence-type arg))) | |
| 518 | (case arg-type | |
| 519 | ;; | |
| 520 | (:atom | |
| 521 | ;; ******************* | |
| 522 | (when (term-is-applform? arg) | |
| 523 | (if (is-true? arg) | |
| 524 | (term-replace sentence (new-term *bool-false*)) | |
| 525 | (if (is-false? arg) | |
| 526 | (term-replace sentence (new-term *bool-true*))))) | |
| 527 | ;; ******************* | |
| 528 | sentence) | |
| 529 | ||
| 530 | ;; ~(A -> B) --> neg-normal-form(~(~A | B)) | |
| 531 | (:imply | |
| 532 | (setf (term-arg-1 sentence) | |
| 533 | (make-term-with-sort-check | |
| 534 | *fopl-or* | |
| 535 | (list (negate-sentence (term-arg-1 arg) :copy variables) | |
| 536 | (allocate-new-term-cell (term-arg-2 arg))))) | |
| 537 | (neg-normal-form sentence variables) | |
| 538 | sentence) | |
| 539 | ;; ~(A <-> B) --> neg-normal-form((A|B) & (~A | ~B)) | |
| 540 | (:iff | |
| 541 | (let ((old-arg1 (allocate-new-term-cell (term-arg-1 arg))) | |
| 542 | (old-arg2 (allocate-new-term-cell (term-arg-2 arg)))) | |
| 543 | (term-replace | |
| 544 | sentence | |
| 545 | (make-term-with-sort-check | |
| 546 | *fopl-and* | |
| 547 | (list | |
| 548 | (make-term-with-sort-check ; A | B | |
| 549 | *fopl-or* | |
| 550 | (list old-arg1 old-arg2)) | |
| 551 | (make-term-with-sort-check ; ~A | ~B | |
| 552 | *fopl-or* | |
| 553 | (list (negate-sentence (term-arg-1 arg) :copy variables) | |
| 554 | (negate-sentence (term-arg-2 arg) :copy variables)))))) | |
| 555 | (neg-normal-form sentence variables) | |
| 556 | sentence)) | |
| 557 | ;; ~\A[Vars]S --> \E[Vars]neg-normal-form(~S) | |
| 558 | ;; ~\E[Vars]S --> \A[Vars]neg-normal-form(~S) | |
| 559 | ((:forall :exists) | |
| 560 | (term-replace sentence | |
| 561 | (make-term-with-sort-check | |
| 562 | (if (eq arg-type :forall) | |
| 563 | *fopl-exists* | |
| 564 | *fopl-forall*) | |
| 565 | (list (allocate-new-term-cell | |
| 566 | (term-arg-1 arg)) ; var list | |
| 567 | (neg-normal-form (negate-sentence | |
| 568 | (term-arg-2 arg) | |
| 569 | nil | |
| 570 | variables) | |
| 571 | variables)))) | |
| 572 | sentence) | |
| 573 | ;; ~(A & B) --> neg-normal-form(~A) | neg-normal-form(~B) | |
| 574 | ;; ~(A | B) --> neg-normal-form(~A) & neg-normal-form(~B) | |
| 575 | ((:and :or) | |
| 576 | (term-replace sentence | |
| 577 | (make-term-with-sort-check | |
| 578 | (if (eq arg-type :and) | |
| 579 | *fopl-or* | |
| 580 | *fopl-and*) | |
| 581 | (list | |
| 582 | (neg-normal-form (negate-sentence (term-arg-1 arg) | |
| 583 | :copy variables) | |
| 584 | variables) | |
| 585 | (neg-normal-form (negate-sentence (term-arg-2 arg) | |
| 586 | :copy variables) | |
| 587 | variables)))) | |
| 588 | sentence) | |
| 589 | ;; ~~A --> neg-normal-form(A) | |
| 590 | (:not ; double negation | |
| 591 | (term-replace sentence | |
| 592 | (neg-normal-form (term-arg-1 arg) variables)) | |
| 593 | sentence) | |
| 594 | ))) | |
| 595 | 595 | ) |
| 596 | 596 | ;; |
| 597 | 597 | (when *debug-formula* |
| 598 | (format t "~&~d< " *debug-formula-nest*) | |
| 598 | (format t "~%~d< " *debug-formula-nest*) | |
| 599 | 599 | (term-print sentence)) |
| 600 | 600 | ;; |
| 601 | 601 | sentence)) |
| 609 | 609 | ;;; |
| 610 | 610 | (defun make-skolem-function-name (sort variables) |
| 611 | 611 | (declare (type sort* sort) |
| 612 | (type list variables)) | |
| 612 | (type list variables)) | |
| 613 | 613 | (let* ((sname (sort-name sort)) |
| 614 | (num-ent (assq sname *sk-function-num*)) | |
| 615 | (num nil)) | |
| 614 | (num-ent (assq sname *sk-function-num*)) | |
| 615 | (num nil)) | |
| 616 | 616 | (declare (type symbol sname) |
| 617 | (type list num-ent) | |
| 618 | (type (or null fixnum) num)) | |
| 617 | (type list num-ent) | |
| 618 | (type (or null fixnum) num)) | |
| 619 | 619 | (if num-ent |
| 620 | (progn | |
| 621 | (setq num (the fixnum (cdr num-ent))) | |
| 622 | (incf (the fixnum (cdr num-ent)))) | |
| 620 | (progn | |
| 621 | (setq num (the fixnum (cdr num-ent))) | |
| 622 | (incf (the fixnum (cdr num-ent)))) | |
| 623 | 623 | (progn |
| 624 | (push (cons sname 2) *sk-function-num*) | |
| 625 | (setq num 1))) | |
| 624 | (push (cons sname 2) *sk-function-num*) | |
| 625 | (setq num 1))) | |
| 626 | 626 | (if variables |
| 627 | (format nil "#f~d.~a" (the fixnum num) (string sname)) | |
| 628 | (format nil "#c~d.~a" (the fixnum num) (string sname))) | |
| 627 | (format nil "#f~d@~a" (the fixnum num) (string sname)) | |
| 628 | (format nil "#c~d@~a" (the fixnum num) (string sname))) | |
| 629 | 629 | )) |
| 630 | 630 | |
| 631 | 631 | (defun skolemize (formula) |
| 632 | 632 | (declare (type term formula) |
| 633 | (values term)) | |
| 633 | (values term)) | |
| 634 | 634 | (let ((variables nil)) |
| 635 | 635 | (declare (type list variables)) |
| 636 | 636 | (labels ((skolem (sentence) |
| 637 | (declare (type term sentence)) | |
| 638 | ;; skolemize given sentence w.r.t universally quantified | |
| 639 | ;; vars (assumes `variables' holds them). | |
| 640 | (let ((type (fopl-sentence-type sentence))) | |
| 641 | (declare (type symbol type)) | |
| 642 | (case type | |
| 643 | ((:and :or) | |
| 644 | (skolem (term-arg-1 sentence)) | |
| 645 | (skolem (term-arg-2 sentence))) | |
| 646 | (:forall | |
| 647 | (when (member (term-arg-1 sentence) variables | |
| 648 | :test #'variable=) | |
| 649 | ;; rename current variable, because we are | |
| 650 | ;; already in the scope of universaly quantified | |
| 651 | ;; variable with that name and sort. | |
| 652 | (let ((new-var (pn-make-new-variable (term-arg-1 sentence)))) | |
| 653 | ;; in our setting, all variables are shared, | |
| 654 | ;; thus we must make brand new variables here. | |
| 655 | ;; and substitute every occurences with the | |
| 656 | ;; new one. | |
| 657 | (rename-free-formula (term-arg-2 sentence) | |
| 658 | (term-arg-1 sentence) | |
| 659 | new-var) | |
| 660 | (setf (term-arg-1 sentence) new-var))) | |
| 661 | ;; entry current bound variable | |
| 662 | (push (term-arg-1 sentence) variables) | |
| 663 | (skolem (term-arg-2 sentence)) | |
| 664 | ;; delete current var | |
| 665 | (pop variables)) | |
| 666 | (:exists | |
| 667 | ;; must skolemize subformula first to avoid | |
| 668 | ;; problem in \Ax...\Ey...\Ex F(x,y) | |
| 669 | (skolem (term-arg-2 sentence)) | |
| 670 | (let* ((mod (or *current-module* *last-module*)) | |
| 671 | (skfun-name | |
| 672 | (make-skolem-function-name (term-sort | |
| 673 | (term-arg-1 sentence)) | |
| 674 | variables)) | |
| 675 | ) | |
| 676 | (multiple-value-bind (op meth) | |
| 677 | (declare-operator-in-module | |
| 678 | (list skfun-name) | |
| 679 | (mapcar #'(lambda (x) | |
| 680 | (variable-sort x)) | |
| 681 | (reverse variables)) | |
| 682 | (variable-sort (term-arg-1 sentence)) | |
| 683 | mod | |
| 684 | nil ; constructor? | |
| 685 | nil ; behavioural? always nil. | |
| 686 | ;; set coherent iff having hidden sort arguments | |
| 687 | (some #'(lambda (x) | |
| 688 | (sort-is-hidden (variable-sort x))) | |
| 689 | variables) | |
| 690 | ) | |
| 691 | (declare (ignore op)) | |
| 692 | ;; we may need to check given operation is a | |
| 693 | ;; skolem function at later stages. | |
| 694 | (pushnew meth (module-skolem-functions mod) :test #'eq) | |
| 695 | ;; | |
| 696 | (let ((sk-form (make-term-with-sort-check | |
| 697 | meth | |
| 698 | (reverse variables)))) | |
| 699 | (term-replace sentence | |
| 700 | (subst-free-formula (term-arg-2 sentence) | |
| 701 | (term-arg-1 sentence) | |
| 702 | sk-form)) | |
| 703 | )))) | |
| 704 | ||
| 705 | ;; following cases handles bad situations. | |
| 706 | ;; given sentence should be a NNF. | |
| 707 | (:not | |
| 708 | (unless (memq (fopl-sentence-type (term-arg-1 sentence)) | |
| 709 | '(:atom :eq :beq)) | |
| 710 | (with-output-chaos-error ('invalid-formula) | |
| 711 | (princ "skolemize gets negated non-atom") | |
| 712 | (term-print sentence))) | |
| 713 | sentence) | |
| 714 | ((:imply :iff) | |
| 715 | (with-output-chaos-error ('invalid-formula) | |
| 716 | (princ "skolemize gets: ") | |
| 717 | (term-print sentence))) | |
| 718 | ;; atom. | |
| 719 | (otherwise sentence)) | |
| 720 | ;; done | |
| 721 | sentence))) | |
| 637 | (declare (type term sentence)) | |
| 638 | ;; skolemize given sentence w.r.t universally quantified | |
| 639 | ;; vars (assumes `variables' holds them). | |
| 640 | (let ((type (fopl-sentence-type sentence))) | |
| 641 | (declare (type symbol type)) | |
| 642 | (case type | |
| 643 | ((:and :or) | |
| 644 | (skolem (term-arg-1 sentence)) | |
| 645 | (skolem (term-arg-2 sentence))) | |
| 646 | (:forall | |
| 647 | (when (member (term-arg-1 sentence) variables | |
| 648 | :test #'variable=) | |
| 649 | ;; rename current variable, because we are | |
| 650 | ;; already in the scope of universaly quantified | |
| 651 | ;; variable with that name and sort. | |
| 652 | (let ((new-var (pn-make-new-variable (term-arg-1 sentence)))) | |
| 653 | ;; in our setting, all variables are shared, | |
| 654 | ;; thus we must make brand new variables here. | |
| 655 | ;; and substitute every occurences with the | |
| 656 | ;; new one. | |
| 657 | (rename-free-formula (term-arg-2 sentence) | |
| 658 | (term-arg-1 sentence) | |
| 659 | new-var) | |
| 660 | (setf (term-arg-1 sentence) new-var))) | |
| 661 | ;; entry current bound variable | |
| 662 | (push (term-arg-1 sentence) variables) | |
| 663 | (skolem (term-arg-2 sentence)) | |
| 664 | ;; delete current var | |
| 665 | (pop variables)) | |
| 666 | (:exists | |
| 667 | ;; must skolemize subformula first to avoid | |
| 668 | ;; problem in \Ax...\Ey...\Ex F(x,y) | |
| 669 | (skolem (term-arg-2 sentence)) | |
| 670 | (let* ((mod (get-context-module)) | |
| 671 | (skfun-name | |
| 672 | (make-skolem-function-name (term-sort | |
| 673 | (term-arg-1 sentence)) | |
| 674 | variables))) | |
| 675 | (multiple-value-bind (op meth) | |
| 676 | (declare-operator-in-module | |
| 677 | (list skfun-name) | |
| 678 | (mapcar #'(lambda (x) | |
| 679 | (variable-sort x)) | |
| 680 | (reverse variables)) | |
| 681 | (variable-sort (term-arg-1 sentence)) | |
| 682 | mod | |
| 683 | nil ; constructor? | |
| 684 | nil ; behavioural? always nil. | |
| 685 | ;; set coherent iff having hidden sort arguments | |
| 686 | (some #'(lambda (x) | |
| 687 | (sort-is-hidden (variable-sort x))) | |
| 688 | variables) | |
| 689 | ) | |
| 690 | (declare (ignore op)) | |
| 691 | ;; we may need to check given operation is a | |
| 692 | ;; skolem function at later stages. | |
| 693 | (pushnew meth (module-skolem-functions mod) :test #'eq) | |
| 694 | ;; | |
| 695 | (let ((sk-form (make-term-with-sort-check | |
| 696 | meth | |
| 697 | (reverse variables)))) | |
| 698 | (term-replace sentence | |
| 699 | (subst-free-formula (term-arg-2 sentence) | |
| 700 | (term-arg-1 sentence) | |
| 701 | sk-form)) | |
| 702 | )))) | |
| 703 | ||
| 704 | ;; following cases handles bad situations. | |
| 705 | ;; given sentence should be a NNF. | |
| 706 | (:not | |
| 707 | (unless (memq (fopl-sentence-type (term-arg-1 sentence)) | |
| 708 | '(:atom :eq :beq)) | |
| 709 | (with-output-chaos-error ('invalid-formula) | |
| 710 | (princ "skolemize gets negated non-atom") | |
| 711 | (term-print sentence))) | |
| 712 | sentence) | |
| 713 | ((:imply :iff) | |
| 714 | (with-output-chaos-error ('invalid-formula) | |
| 715 | (princ "skolemize gets: ") | |
| 716 | (term-print sentence))) | |
| 717 | ;; atom. | |
| 718 | (otherwise sentence)) | |
| 719 | ;; done | |
| 720 | sentence))) | |
| 722 | 721 | ;; |
| 723 | 722 | (skolem formula) |
| 724 | 723 | ))) |
| 733 | 732 | (case type |
| 734 | 733 | ((:forall :exists) |
| 735 | 734 | (unless (variable-eq (term-arg-1 sentence) old) |
| 736 | (rename-free-formula (term-arg-2 sentence) old new))) | |
| 735 | (rename-free-formula (term-arg-2 sentence) old new))) | |
| 737 | 736 | (otherwise |
| 738 | 737 | (subst-free-term sentence old new))))) |
| 739 | 738 | |
| 741 | 740 | ;;; |
| 742 | 741 | (defun subst-free-formula (sentence var form) |
| 743 | 742 | (declare (type term sentence var form) |
| 744 | (values term)) | |
| 743 | (values term)) | |
| 745 | 744 | (let ((type (fopl-sentence-type sentence))) |
| 746 | 745 | (declare (type symbol type)) |
| 747 | 746 | (case type |
| 750 | 749 | sentence) |
| 751 | 750 | ((:forall :exists) |
| 752 | 751 | (when (variable-eq var (term-arg-1 sentence)) |
| 753 | (setf (term-arg-1 sentence) form)) | |
| 752 | (setf (term-arg-1 sentence) form)) | |
| 754 | 753 | (subst-free-formula (term-arg-2 sentence) var form)) |
| 755 | 754 | ((:and :or) |
| 756 | 755 | (subst-free-formula (term-arg-1 sentence) |
| 757 | var form) | |
| 756 | var form) | |
| 758 | 757 | (subst-free-formula (term-arg-2 sentence) var form)) |
| 759 | 758 | (:not |
| 760 | 759 | (subst-free-formula (term-arg-1 sentence) var form)) |
| 767 | 766 | ) |
| 768 | 767 | (otherwise |
| 769 | 768 | (with-output-panic-message() |
| 770 | (princ "illegal formula appeared process subst-free-formula") | |
| 771 | (term-print sentence)))) | |
| 769 | (princ "illegal formula appeared process subst-free-formula") | |
| 770 | (term-print sentence)))) | |
| 772 | 771 | sentence)) |
| 773 | 772 | |
| 774 | 773 | (defun subst-free-term (term var form) |
| 775 | 774 | (declare (type term term term) |
| 776 | (values term)) | |
| 775 | (values term)) | |
| 777 | 776 | (when *debug-formula* |
| 778 | (format t "~&>[subst-free-term]:") | |
| 777 | (format t "~%>[subst-free-term]:") | |
| 779 | 778 | (term-print term)) |
| 780 | 779 | (when (term-is-application-form? term) |
| 781 | 780 | (dotimes (x (length (term-subterms term))) |
| 782 | 781 | (let ((sub (term-arg-n term x))) |
| 783 | (cond ((term-is-variable? sub) | |
| 784 | (when (variable-eq var sub) | |
| 785 | (setf (term-arg-n term x) | |
| 786 | (copy-term-reusing-variables form)))) | |
| 787 | (t (subst-free-term sub var form)))))) | |
| 782 | (cond ((term-is-variable? sub) | |
| 783 | (when (variable-eq var sub) | |
| 784 | (setf (term-arg-n term x) | |
| 785 | (copy-term-reusing-variables form)))) | |
| 786 | (t (subst-free-term sub var form)))))) | |
| 788 | 787 | (when *debug-formula* |
| 789 | (format t "~&<[subst-free-term]:") | |
| 788 | (format t "~%<[subst-free-term]:") | |
| 790 | 789 | (term-print term)) |
| 791 | 790 | term) |
| 792 | 791 | |
| 800 | 799 | (let ((variables nil)) |
| 801 | 800 | (declare (type list variables)) |
| 802 | 801 | (labels ((unique (f) |
| 803 | (declare (type term f)) | |
| 804 | (let ((type (fopl-sentence-type f))) | |
| 805 | (declare (type symbol type)) | |
| 806 | (when *debug-formula* | |
| 807 | (format t "~&>[unique-all-variables]: ~a" type) | |
| 808 | (term-print f)) | |
| 809 | (case type | |
| 810 | (:atom) ; do nothing | |
| 811 | ((:not :and :or :eq :beq) | |
| 812 | (dolist (s (term-subterms f)) | |
| 813 | (unique s))) | |
| 814 | (otherwise ; forall | |
| 815 | (if (member (term-arg-1 f) | |
| 816 | variables | |
| 817 | :test #'variable=) | |
| 818 | ;; rename current variable, because already have a | |
| 819 | ;; quantified var with that name | |
| 820 | (let ((new-var (pn-make-new-variable (term-arg-1 f)))) | |
| 821 | (rename-free-formula (term-arg-2 f) | |
| 822 | (term-arg-1 f) | |
| 823 | new-var) | |
| 824 | (setf (term-arg-1 f) new-var)) | |
| 825 | ;; else | |
| 826 | (let ((new-var (pn-make-new-variable | |
| 827 | (term-arg-1 f)))) | |
| 828 | (rename-free-formula (term-arg-2 f) | |
| 829 | (term-arg-1 f) | |
| 830 | new-var) | |
| 831 | (setf (term-arg-1 f) new-var) | |
| 832 | (push (term-arg-1 f) variables))) | |
| 833 | ;; recurse | |
| 834 | (unique (term-arg-2 f)) | |
| 835 | )) | |
| 836 | (when *debug-formula* | |
| 837 | (format t "~&<[unique-var..]:") | |
| 838 | (term-print f)) | |
| 839 | ))) | |
| 802 | (declare (type term f)) | |
| 803 | (let ((type (fopl-sentence-type f))) | |
| 804 | (declare (type symbol type)) | |
| 805 | (when *debug-formula* | |
| 806 | (format t "~%>[unique-all-variables]: ~a" type) | |
| 807 | (term-print f)) | |
| 808 | (case type | |
| 809 | (:atom) ; do nothing | |
| 810 | ((:not :and :or :eq :beq) | |
| 811 | (dolist (s (term-subterms f)) | |
| 812 | (unique s))) | |
| 813 | (otherwise ; forall | |
| 814 | (if (member (term-arg-1 f) | |
| 815 | variables | |
| 816 | :test #'variable=) | |
| 817 | ;; rename current variable, because already have a | |
| 818 | ;; quantified var with that name | |
| 819 | (let ((new-var (pn-make-new-variable (term-arg-1 f)))) | |
| 820 | (rename-free-formula (term-arg-2 f) | |
| 821 | (term-arg-1 f) | |
| 822 | new-var) | |
| 823 | (setf (term-arg-1 f) new-var)) | |
| 824 | ;; else | |
| 825 | (let ((new-var (pn-make-new-variable | |
| 826 | (term-arg-1 f)))) | |
| 827 | (rename-free-formula (term-arg-2 f) | |
| 828 | (term-arg-1 f) | |
| 829 | new-var) | |
| 830 | (setf (term-arg-1 f) new-var) | |
| 831 | (push (term-arg-1 f) variables))) | |
| 832 | ;; recurse | |
| 833 | (unique (term-arg-2 f)) | |
| 834 | )) | |
| 835 | (when *debug-formula* | |
| 836 | (format t "~%<[unique-var..]:") | |
| 837 | (term-print f)) | |
| 838 | ))) | |
| 840 | 839 | ;; |
| 841 | 840 | (unique sentence) |
| 842 | 841 | sentence))) |
| 848 | 847 | ;;; |
| 849 | 848 | (defun zap-quantifiers (sentence) |
| 850 | 849 | (declare (type term sentence) |
| 851 | (values term)) | |
| 850 | (values term)) | |
| 852 | 851 | (let ((type (fopl-sentence-type sentence)) |
| 853 | (*debug-formula-nest* (1+ *debug-formula-nest*))) | |
| 852 | (*debug-formula-nest* (1+ *debug-formula-nest*))) | |
| 854 | 853 | (declare (type symbol type)) |
| 855 | 854 | (when *debug-formula* |
| 856 | (format t "~&~d>[zap-quantifiers]: " *debug-formula-nest*) | |
| 855 | (format t "~%~d>[zap-quantifiers]: " *debug-formula-nest*) | |
| 857 | 856 | (term-print sentence)) |
| 858 | 857 | ;; |
| 859 | 858 | (case type |
| 860 | 859 | ((:not :and :or :eq :beq) |
| 861 | 860 | (map nil #'(lambda (x) |
| 862 | (zap-quantifiers x)) | |
| 863 | (term-subterms sentence)) | |
| 861 | (zap-quantifiers x)) | |
| 862 | (term-subterms sentence)) | |
| 864 | 863 | sentence) |
| 865 | 864 | (:forall |
| 866 | 865 | (term-replace sentence (zap-quantifiers (term-arg-2 sentence))) |
| 868 | 867 | (:atom) |
| 869 | 868 | (otherwise |
| 870 | 869 | (with-output-panic-message () |
| 871 | (format t "zap-quantifiers accepted illegal formula type ~a: " type) | |
| 872 | (term-print sentence)))) | |
| 870 | (format t "zap-quantifiers accepted illegal formula type ~a: " type) | |
| 871 | (term-print sentence)))) | |
| 873 | 872 | ;; |
| 874 | 873 | (when *debug-formula* |
| 875 | (format t "~&~d< " *debug-formula-nest*) | |
| 874 | (format t "~%~d< " *debug-formula-nest*) | |
| 876 | 875 | (term-print sentence)) |
| 877 | 876 | sentence)) |
| 878 | 877 | |
| 884 | 883 | |
| 885 | 884 | (defun conj-normal-form (sentence) |
| 886 | 885 | (declare (type term sentence) |
| 887 | (values term)) | |
| 886 | (values term)) | |
| 888 | 887 | (let ((type (fopl-sentence-type sentence)) |
| 889 | (*debug-formula-nest* (1+ *debug-formula-nest*))) | |
| 888 | (*debug-formula-nest* (1+ *debug-formula-nest*))) | |
| 890 | 889 | (declare (type symbol type)) |
| 891 | 890 | (when *debug-formula* |
| 892 | (format t "~&~d>[cnj-normal-form]: " *debug-formula-nest*) | |
| 891 | (format t "~%~d>[cnj-normal-form]: " *debug-formula-nest*) | |
| 893 | 892 | (term-print sentence)) |
| 894 | 893 | (case type |
| 895 | 894 | ((:and :or) |
| 898 | 897 | (conj-normal-form (term-arg-2 sentence)) |
| 899 | 898 | ;; then itself |
| 900 | 899 | (cond ((eq type :and) |
| 901 | (when (pn-flag simplify-fol) | |
| 902 | (conflict-tautology sentence) | |
| 903 | (subsume-conjuncts sentence))) | |
| 904 | (t ; or | |
| 905 | ;; or ditribution | |
| 906 | (distribute-or sentence)))) | |
| 900 | (when (pn-flag simplify-fol) | |
| 901 | (conflict-tautology sentence) | |
| 902 | (subsume-conjuncts sentence))) | |
| 903 | (t ; or | |
| 904 | ;; or ditribution | |
| 905 | (distribute-or sentence)))) | |
| 907 | 906 | (otherwise sentence)) |
| 908 | 907 | (when *debug-formula* |
| 909 | (format t "~&~d< " *debug-formula-nest*) | |
| 908 | (format t "~%~d< " *debug-formula-nest*) | |
| 910 | 909 | (term-print sentence)) |
| 911 | 910 | sentence)) |
| 912 | 911 | |
| 918 | 917 | ;;; |
| 919 | 918 | (defun distribute-or (sentence) |
| 920 | 919 | (declare (type term sentence) |
| 921 | (values term)) | |
| 920 | (values term)) | |
| 922 | 921 | (unless (eq :or (fopl-sentence-type sentence)) |
| 923 | 922 | (return-from distribute-or sentence)) |
| 924 | 923 | (let ((*debug-formula-nest* (1+ *debug-formula-nest*))) |
| 925 | 924 | (when *debug-formula* |
| 926 | (format t "~&~d>*distribute | over &: " | |
| 927 | *debug-formula-nest*) | |
| 925 | (format t "~%~d>*distribute | over &: " | |
| 926 | *debug-formula-nest*) | |
| 928 | 927 | (term-print sentence)) |
| 929 | 928 | (when (pn-flag simplify-fol) |
| 930 | 929 | ;; simplify |
| 933 | 932 | ;; |
| 934 | 933 | (unless (eq (fopl-sentence-type sentence) :or) |
| 935 | 934 | (when *debug-formula* |
| 936 | (format t "~&~d< " *debug-formula-nest*) | |
| 937 | (term-print sentence)) | |
| 935 | (format t "~%~d< " *debug-formula-nest*) | |
| 936 | (term-print sentence)) | |
| 938 | 937 | (return-from distribute-or sentence)) |
| 939 | 938 | (let* ((args (gather-subterms-with-top (term-head sentence) |
| 940 | sentence)) | |
| 941 | (and-form (find-if #'(lambda (x) | |
| 942 | (eq :and | |
| 943 | (fopl-sentence-type x))) | |
| 944 | args))) | |
| 939 | sentence)) | |
| 940 | (and-form (find-if #'(lambda (x) | |
| 941 | (eq :and | |
| 942 | (fopl-sentence-type x))) | |
| 943 | args))) | |
| 945 | 944 | (if and-form |
| 946 | (setq args (delete and-form args))) | |
| 945 | (setq args (delete and-form args))) | |
| 947 | 946 | (unless and-form |
| 948 | ;; there's no and-form in subterms. | |
| 949 | (when *debug-formula* | |
| 950 | (format t "~&~d< " *debug-formula-nest*) | |
| 951 | (term-print sentence)) | |
| 952 | (return-from distribute-or sentence)) | |
| 947 | ;; there's no and-form in subterms. | |
| 948 | (when *debug-formula* | |
| 949 | (format t "~%~d< " *debug-formula-nest*) | |
| 950 | (term-print sentence)) | |
| 951 | (return-from distribute-or sentence)) | |
| 953 | 952 | ;; |
| 954 | 953 | (let ((arg-1 (pop args)) |
| 955 | (new-form nil)) | |
| 956 | (setq new-form | |
| 957 | (make-term-with-sort-check | |
| 958 | *fopl-and* | |
| 959 | (list (distribute-or | |
| 960 | (make-term-with-sort-check | |
| 961 | *fopl-or* | |
| 962 | (list arg-1 ; known to be not :or form | |
| 963 | (distribute-or (term-arg-1 and-form)) | |
| 964 | ))) | |
| 965 | (distribute-or | |
| 966 | (make-term-with-sort-check | |
| 967 | *fopl-or* | |
| 968 | (list (copy-term-reusing-variables arg-1) | |
| 969 | (distribute-or (term-arg-2 and-form)))))))) | |
| 970 | (unless args | |
| 971 | (term-replace sentence new-form) | |
| 972 | (when *debug-formula* | |
| 973 | (format t "~&~d< " *debug-formula-nest*) | |
| 974 | (term-print sentence)) | |
| 975 | (return-from distribute-or sentence)) | |
| 976 | ;; | |
| 977 | (setq new-form | |
| 978 | (make-right-assoc-normal-form-with-sort-check | |
| 979 | *fopl-or* | |
| 980 | (cons new-form args))) | |
| 981 | ;; | |
| 982 | (term-replace sentence | |
| 983 | (distribute-or (allocate-new-term-cell new-form))) | |
| 984 | (when (pn-flag simplify-fol) | |
| 985 | ;; simplify | |
| 986 | (conflict-tautology sentence) | |
| 987 | (subsume-conjuncts sentence)) | |
| 988 | ;; | |
| 989 | (when *debug-formula* | |
| 990 | (format t "~&~d< " *debug-formula-nest*) | |
| 991 | (term-print sentence)) | |
| 992 | sentence)))) | |
| 954 | (new-form nil)) | |
| 955 | (setq new-form | |
| 956 | (make-term-with-sort-check | |
| 957 | *fopl-and* | |
| 958 | (list (distribute-or | |
| 959 | (make-term-with-sort-check | |
| 960 | *fopl-or* | |
| 961 | (list arg-1 ; known to be not :or form | |
| 962 | (distribute-or (term-arg-1 and-form)) | |
| 963 | ))) | |
| 964 | (distribute-or | |
| 965 | (make-term-with-sort-check | |
| 966 | *fopl-or* | |
| 967 | (list (copy-term-reusing-variables arg-1) | |
| 968 | (distribute-or (term-arg-2 and-form)))))))) | |
| 969 | (unless args | |
| 970 | (term-replace sentence new-form) | |
| 971 | (when *debug-formula* | |
| 972 | (format t "~%~d< " *debug-formula-nest*) | |
| 973 | (term-print sentence)) | |
| 974 | (return-from distribute-or sentence)) | |
| 975 | ;; | |
| 976 | (setq new-form | |
| 977 | (make-right-assoc-normal-form-with-sort-check | |
| 978 | *fopl-or* | |
| 979 | (cons new-form args))) | |
| 980 | ;; | |
| 981 | (term-replace sentence | |
| 982 | (distribute-or (allocate-new-term-cell new-form))) | |
| 983 | (when (pn-flag simplify-fol) | |
| 984 | ;; simplify | |
| 985 | (conflict-tautology sentence) | |
| 986 | (subsume-conjuncts sentence)) | |
| 987 | ;; | |
| 988 | (when *debug-formula* | |
| 989 | (format t "~%~d< " *debug-formula-nest*) | |
| 990 | (term-print sentence)) | |
| 991 | sentence)))) | |
| 993 | 992 | |
| 994 | 993 | |
| 995 | 994 | ;;; GATHER-SUBTERMS-WITH-TOP : op sentence -> List[sentence] |
| 996 | 995 | ;;; |
| 997 | 996 | (defun gather-subterms-with-top (op sentence) |
| 998 | 997 | (declare (type method op) |
| 999 | (type term sentence)) | |
| 998 | (type term sentence)) | |
| 1000 | 999 | (list-assoc-subterms sentence op)) |
| 1001 | 1000 | |
| 1002 | 1001 | ;;; CONFLICT-TAUTOLOGY : Sentence -> Sentence' |
| 1009 | 1008 | ;;; |
| 1010 | 1009 | (defun conflict-tautology (sentence) |
| 1011 | 1010 | (declare (type term sentence) |
| 1012 | (values term)) | |
| 1011 | (values term)) | |
| 1013 | 1012 | (let ((type (fopl-sentence-type sentence)) |
| 1014 | (*debug-formula-nest* (1+ *debug-formula-nest*))) | |
| 1013 | (*debug-formula-nest* (1+ *debug-formula-nest*))) | |
| 1015 | 1014 | (declare (type symbol type)) |
| 1016 | 1015 | (unless (or (eq type :and) |
| 1017 | (eq type :or)) | |
| 1016 | (eq type :or)) | |
| 1018 | 1017 | (return-from conflict-tautology sentence)) |
| 1019 | 1018 | ;; |
| 1020 | 1019 | (when *debug-formula* |
| 1021 | (format t "~&~d>*conflict-tautology: " *debug-formula-nest*) | |
| 1020 | (format t "~%~d>*conflict-tautology: " *debug-formula-nest*) | |
| 1022 | 1021 | (term-print sentence)) |
| 1023 | 1022 | ;; |
| 1024 | 1023 | (let ((subs (gather-subterms-with-top (term-head sentence) |
| 1025 | sentence))) | |
| 1024 | sentence))) | |
| 1026 | 1025 | (declare (type list subs)) |
| 1027 | 1026 | (let ((org-sub-len (length subs)) |
| 1028 | (confliction nil)) | |
| 1029 | (declare (type fixnum org-sub-len)) | |
| 1030 | (case type | |
| 1031 | (:and (when (find-if #'(lambda (x) | |
| 1032 | (is-false? x)) | |
| 1033 | subs) | |
| 1034 | (setq confliction t)) | |
| 1035 | (unless confliction | |
| 1036 | (setq subs (remove-if | |
| 1037 | #'(lambda (x) | |
| 1038 | (is-true? x)) | |
| 1039 | subs))) | |
| 1040 | ) | |
| 1041 | (:or (when (find-if #'(lambda (x) | |
| 1042 | (is-true? x)) | |
| 1043 | subs) | |
| 1044 | (setq confliction t)) | |
| 1045 | (unless confliction | |
| 1046 | (setq subs (remove-if | |
| 1047 | #'(lambda (x) | |
| 1048 | (is-false? x)) | |
| 1049 | subs))) | |
| 1050 | )) | |
| 1051 | ;; | |
| 1052 | (unless confliction | |
| 1053 | (dolist (s subs) | |
| 1054 | (let ((sign (eq (fopl-sentence-type s) :not))) | |
| 1055 | (when (setq confliction | |
| 1056 | (find-if #'(lambda (x) | |
| 1057 | (and (not (eq s x)) | |
| 1058 | (cond (sign ; s is negation | |
| 1059 | (pn-term-equational-equal | |
| 1060 | (term-arg-1 s) | |
| 1061 | x)) | |
| 1062 | (t ; s is not negation | |
| 1063 | (and (eq (fopl-sentence-type x) | |
| 1064 | :not) | |
| 1065 | (pn-term-equational-equal | |
| 1066 | s | |
| 1067 | (term-arg-1 x))))))) | |
| 1068 | subs)) | |
| 1069 | (return))))) | |
| 1070 | ;; | |
| 1071 | (when confliction | |
| 1072 | (if (eq type :and) | |
| 1073 | (term-replace sentence (new-term *bool-false*)) | |
| 1074 | (term-replace sentence (new-term *bool-true*))) | |
| 1075 | (when *debug-formula* | |
| 1076 | (format t "~&<~d: " *debug-formula-nest*) | |
| 1077 | (term-print sentence)) | |
| 1078 | (return-from conflict-tautology sentence) | |
| 1079 | ) | |
| 1080 | ;; | |
| 1081 | (unless (= org-sub-len (the fixnum (length subs))) | |
| 1082 | (let ((new-form nil)) | |
| 1083 | (if (cdr subs) | |
| 1084 | (setq new-form | |
| 1085 | (make-right-assoc-normal-form | |
| 1086 | (if (eq type :and) | |
| 1087 | *fopl-and* | |
| 1088 | *fopl-or*) | |
| 1089 | subs)) | |
| 1090 | (if subs | |
| 1091 | (setq new-form (car subs)) | |
| 1092 | (setq new-form | |
| 1093 | (if (eq type :and) | |
| 1094 | (new-term *bool-true*) | |
| 1095 | (new-term *bool-false*))))) | |
| 1096 | (term-replace sentence new-form))) | |
| 1097 | ;; | |
| 1098 | (when *debug-formula* | |
| 1099 | (format t "~&<~d: " *debug-formula-nest*) | |
| 1100 | (term-print sentence)) | |
| 1101 | sentence)))) | |
| 1027 | (confliction nil)) | |
| 1028 | (declare (type fixnum org-sub-len)) | |
| 1029 | (case type | |
| 1030 | (:and (when (find-if #'(lambda (x) | |
| 1031 | (is-false? x)) | |
| 1032 | subs) | |
| 1033 | (setq confliction t)) | |
| 1034 | (unless confliction | |
| 1035 | (setq subs (remove-if | |
| 1036 | #'(lambda (x) | |
| 1037 | (is-true? x)) | |
| 1038 | subs))) | |
| 1039 | ) | |
| 1040 | (:or (when (find-if #'(lambda (x) | |
| 1041 | (is-true? x)) | |
| 1042 | subs) | |
| 1043 | (setq confliction t)) | |
| 1044 | (unless confliction | |
| 1045 | (setq subs (remove-if | |
| 1046 | #'(lambda (x) | |
| 1047 | (is-false? x)) | |
| 1048 | subs))) | |
| 1049 | )) | |
| 1050 | ;; | |
| 1051 | (unless confliction | |
| 1052 | (dolist (s subs) | |
| 1053 | (let ((sign (eq (fopl-sentence-type s) :not))) | |
| 1054 | (when (setq confliction | |
| 1055 | (find-if #'(lambda (x) | |
| 1056 | (and (not (eq s x)) | |
| 1057 | (cond (sign ; s is negation | |
| 1058 | (pn-term-equational-equal | |
| 1059 | (term-arg-1 s) | |
| 1060 | x)) | |
| 1061 | (t ; s is not negation | |
| 1062 | (and (eq (fopl-sentence-type x) | |
| 1063 | :not) | |
| 1064 | (pn-term-equational-equal | |
| 1065 | s | |
| 1066 | (term-arg-1 x))))))) | |
| 1067 | subs)) | |
| 1068 | (return))))) | |
| 1069 | ;; | |
| 1070 | (when confliction | |
| 1071 | (if (eq type :and) | |
| 1072 | (term-replace sentence (new-term *bool-false*)) | |
| 1073 | (term-replace sentence (new-term *bool-true*))) | |
| 1074 | (when *debug-formula* | |
| 1075 | (format t "~%<~d: " *debug-formula-nest*) | |
| 1076 | (term-print sentence)) | |
| 1077 | (return-from conflict-tautology sentence) | |
| 1078 | ) | |
| 1079 | ;; | |
| 1080 | (unless (= org-sub-len (the fixnum (length subs))) | |
| 1081 | (let ((new-form nil)) | |
| 1082 | (if (cdr subs) | |
| 1083 | (setq new-form | |
| 1084 | (make-right-assoc-normal-form | |
| 1085 | (if (eq type :and) | |
| 1086 | *fopl-and* | |
| 1087 | *fopl-or*) | |
| 1088 | subs)) | |
| 1089 | (if subs | |
| 1090 | (setq new-form (car subs)) | |
| 1091 | (setq new-form | |
| 1092 | (if (eq type :and) | |
| 1093 | (new-term *bool-true*) | |
| 1094 | (new-term *bool-false*))))) | |
| 1095 | (term-replace sentence new-form))) | |
| 1096 | ;; | |
| 1097 | (when *debug-formula* | |
| 1098 | (format t "~%<~d: " *debug-formula-nest*) | |
| 1099 | (term-print sentence)) | |
| 1100 | sentence)))) | |
| 1102 | 1101 | |
| 1103 | 1102 | ;;; SUBSUME-CONJUNCTS : Sentence -> Sentence' |
| 1104 | 1103 | ;;; - given a conjuction, discard weaker conjuncts. |
| 1109 | 1108 | (unless (eq (fopl-sentence-type c) :and) |
| 1110 | 1109 | (return-from subsume-conjuncts c)) |
| 1111 | 1110 | (let ((subs (gather-subterms-with-top (term-head c) c)) |
| 1112 | (*debug-formula-nest* (1+ *debug-formula-nest*))) | |
| 1111 | (*debug-formula-nest* (1+ *debug-formula-nest*))) | |
| 1113 | 1112 | (declare (type list subs)) |
| 1114 | 1113 | (when *debug-formula* |
| 1115 | (format t "~&~d>*subsume-conjuncts: " *debug-formula-nest*) | |
| 1114 | (format t "~%~d>*subsume-conjuncts: " *debug-formula-nest*) | |
| 1116 | 1115 | (term-print c)) |
| 1117 | 1116 | (let ((res (copy-list subs))) |
| 1118 | 1117 | (declare (type list res)) |
| 1119 | 1118 | (dolist (s subs) |
| 1120 | (declare (type term s)) | |
| 1121 | (if (find-if #'(lambda (x) | |
| 1122 | (and (not (term-eq s x)) | |
| 1123 | (gen-subsume-prop x s))) | |
| 1124 | res) | |
| 1125 | (setq res (delete s res)) | |
| 1126 | ;; | |
| 1127 | (setq res (delete-if #'(lambda (x) | |
| 1128 | (and (not (term-eq s x)) | |
| 1129 | (gen-subsume-prop s x))) | |
| 1130 | res)))) | |
| 1119 | (declare (type term s)) | |
| 1120 | (if (find-if #'(lambda (x) | |
| 1121 | (and (not (term-eq s x)) | |
| 1122 | (gen-subsume-prop x s))) | |
| 1123 | res) | |
| 1124 | (setq res (delete s res)) | |
| 1125 | ;; | |
| 1126 | (setq res (delete-if #'(lambda (x) | |
| 1127 | (and (not (term-eq s x)) | |
| 1128 | (gen-subsume-prop s x))) | |
| 1129 | res)))) | |
| 1131 | 1130 | ;; |
| 1132 | 1131 | (unless (= (the fixnum (length subs)) (the fixnum (length res))) |
| 1133 | (if (cdr res) | |
| 1134 | (let ((new-and-term | |
| 1135 | (make-term-with-sort-check | |
| 1136 | *fopl-and* | |
| 1137 | (list (car res) (cadr res))))) | |
| 1138 | (dolist (arg (cddr res)) | |
| 1139 | (setq new-and-term | |
| 1140 | (make-term-with-sort-check | |
| 1141 | *fopl-and* | |
| 1142 | (list new-and-term arg)))) | |
| 1143 | (term-replace c new-and-term)) | |
| 1144 | (term-replace c (car res)))) | |
| 1132 | (if (cdr res) | |
| 1133 | (let ((new-and-term | |
| 1134 | (make-term-with-sort-check | |
| 1135 | *fopl-and* | |
| 1136 | (list (car res) (cadr res))))) | |
| 1137 | (dolist (arg (cddr res)) | |
| 1138 | (setq new-and-term | |
| 1139 | (make-term-with-sort-check | |
| 1140 | *fopl-and* | |
| 1141 | (list new-and-term arg)))) | |
| 1142 | (term-replace c new-and-term)) | |
| 1143 | (term-replace c (car res)))) | |
| 1145 | 1144 | ;; |
| 1146 | 1145 | (when *debug-formula* |
| 1147 | (format t "~&~d< " *debug-formula-nest*) | |
| 1148 | (term-print c)) | |
| 1146 | (format t "~%~d< " *debug-formula-nest*) | |
| 1147 | (term-print c)) | |
| 1149 | 1148 | ;; |
| 1150 | 1149 | c))) |
| 1151 | 1150 | |
| 1156 | 1155 | ;;; |
| 1157 | 1156 | (defun subsume-disjuncts (d) |
| 1158 | 1157 | (declare (type term d) |
| 1159 | (values term)) | |
| 1158 | (values term)) | |
| 1160 | 1159 | (unless (eq (fopl-sentence-type d) :or) |
| 1161 | 1160 | (return-from subsume-disjuncts d)) |
| 1162 | 1161 | (let ((subs (gather-subterms-with-top (term-head d) d)) |
| 1163 | (*debug-formula-nest* (1+ *debug-formula-nest*))) | |
| 1162 | (*debug-formula-nest* (1+ *debug-formula-nest*))) | |
| 1164 | 1163 | (declare (type list subs)) |
| 1165 | 1164 | (when *debug-formula* |
| 1166 | (format t "~&~d>*subsume-disjuncts: " *debug-formula-nest*) | |
| 1165 | (format t "~%~d>*subsume-disjuncts: " *debug-formula-nest*) | |
| 1167 | 1166 | (term-print d)) |
| 1168 | 1167 | ;; |
| 1169 | 1168 | (let ((res (copy-list subs))) |
| 1170 | 1169 | (declare (type list res)) |
| 1171 | 1170 | (dolist (s subs) |
| 1172 | (declare (type term s)) | |
| 1173 | (if (find-if #'(lambda (x) | |
| 1174 | (and (not (term-eq s x)) | |
| 1175 | (gen-subsume-prop s x))) | |
| 1176 | res) | |
| 1177 | (setq res (delete s res)) | |
| 1178 | (setq res (delete-if #'(lambda (x) | |
| 1179 | (and (not (term-eq x s)) | |
| 1180 | (gen-subsume-prop x s))) | |
| 1181 | res)))) | |
| 1171 | (declare (type term s)) | |
| 1172 | (if (find-if #'(lambda (x) | |
| 1173 | (and (not (term-eq s x)) | |
| 1174 | (gen-subsume-prop s x))) | |
| 1175 | res) | |
| 1176 | (setq res (delete s res)) | |
| 1177 | (setq res (delete-if #'(lambda (x) | |
| 1178 | (and (not (term-eq x s)) | |
| 1179 | (gen-subsume-prop x s))) | |
| 1180 | res)))) | |
| 1182 | 1181 | (unless (= (the fixnum (length res)) (the fixnum (length subs))) |
| 1183 | (if (cdr res) | |
| 1184 | (let ((new-or-term | |
| 1185 | (make-term-with-sort-check | |
| 1186 | *fopl-or* | |
| 1187 | (list (car res) (cadr res))))) | |
| 1188 | (dolist (arg (cddr res)) | |
| 1189 | (setq new-or-term | |
| 1190 | (make-term-with-sort-check | |
| 1191 | *fopl-or* | |
| 1192 | (list new-or-term arg)))) | |
| 1193 | (term-replace d new-or-term)) | |
| 1194 | (term-replace d (car res)))) | |
| 1182 | (if (cdr res) | |
| 1183 | (let ((new-or-term | |
| 1184 | (make-term-with-sort-check | |
| 1185 | *fopl-or* | |
| 1186 | (list (car res) (cadr res))))) | |
| 1187 | (dolist (arg (cddr res)) | |
| 1188 | (setq new-or-term | |
| 1189 | (make-term-with-sort-check | |
| 1190 | *fopl-or* | |
| 1191 | (list new-or-term arg)))) | |
| 1192 | (term-replace d new-or-term)) | |
| 1193 | (term-replace d (car res)))) | |
| 1195 | 1194 | ;; |
| 1196 | 1195 | (when *debug-formula* |
| 1197 | (format t "~&~d< " *debug-formula-nest*) | |
| 1198 | (term-print d)) | |
| 1196 | (format t "~%~d< " *debug-formula-nest*) | |
| 1197 | (term-print d)) | |
| 1199 | 1198 | ;; |
| 1200 | 1199 | d))) |
| 1201 | 1200 | |
| 1211 | 1210 | (defun gen-subsume-prop (c d) |
| 1212 | 1211 | (declare (type term c d)) |
| 1213 | 1212 | (let ((c-type (fopl-sentence-type c)) |
| 1214 | (d-type (fopl-sentence-type d))) | |
| 1213 | (d-type (fopl-sentence-type d))) | |
| 1215 | 1214 | (declare (type symbol c-type d-type)) |
| 1216 | 1215 | (let ((res nil) |
| 1217 | (*debug-subsume-prop-nest* (1+ *debug-subsume-prop-nest*))) | |
| 1216 | (*debug-subsume-prop-nest* (1+ *debug-subsume-prop-nest*))) | |
| 1218 | 1217 | (when *debug-subsume-prop* |
| 1219 | (format t "~&~d>[subsume prop]: " *debug-subsume-prop-nest*) | |
| 1220 | (format t "~&c = ")(term-print c) | |
| 1221 | (format t "~&d = ")(term-print d)) | |
| 1218 | (format t "~%~d>[subsume prop]: " *debug-subsume-prop-nest*) | |
| 1219 | (format t "~&c = ")(term-print c) | |
| 1220 | (format t "~&d = ")(term-print d)) | |
| 1222 | 1221 | (setq res |
| 1223 | (if (eq c-type :or) | |
| 1224 | ;; test each c_i subsumes d | |
| 1225 | (every #'(lambda (x) | |
| 1226 | (or (is-true? x) | |
| 1227 | (gen-subsume-prop x d))) | |
| 1228 | (term-subterms c)) | |
| 1229 | ;; c-type = :and or others | |
| 1230 | (if (eq d-type :and) | |
| 1231 | ;; test c subsumes each d_i | |
| 1232 | (every #'(lambda (x) | |
| 1233 | (gen-subsume-prop c x)) | |
| 1234 | (term-subterms d)) | |
| 1235 | (if (eq c-type :and) | |
| 1236 | ;; test one c_i subsumes d | |
| 1237 | (some #'(lambda (x) | |
| 1238 | (or (is-false? x) | |
| 1239 | (gen-subsume-prop x d))) | |
| 1240 | (term-subterms c)) | |
| 1241 | (if (eq d-type :or) | |
| 1242 | ;; test c subsumes one d_i | |
| 1243 | (some #'(lambda (x) | |
| 1244 | (gen-subsume-prop c x)) | |
| 1245 | (term-subterms d)) | |
| 1246 | ;; c and d are :not, :atom, :forall, or :exists | |
| 1247 | (formula-is-identical c d) | |
| 1248 | ))))) | |
| 1222 | (if (eq c-type :or) | |
| 1223 | ;; test each c_i subsumes d | |
| 1224 | (every #'(lambda (x) | |
| 1225 | (or (is-true? x) | |
| 1226 | (gen-subsume-prop x d))) | |
| 1227 | (term-subterms c)) | |
| 1228 | ;; c-type = :and or others | |
| 1229 | (if (eq d-type :and) | |
| 1230 | ;; test c subsumes each d_i | |
| 1231 | (every #'(lambda (x) | |
| 1232 | (gen-subsume-prop c x)) | |
| 1233 | (term-subterms d)) | |
| 1234 | (if (eq c-type :and) | |
| 1235 | ;; test one c_i subsumes d | |
| 1236 | (some #'(lambda (x) | |
| 1237 | (or (is-false? x) | |
| 1238 | (gen-subsume-prop x d))) | |
| 1239 | (term-subterms c)) | |
| 1240 | (if (eq d-type :or) | |
| 1241 | ;; test c subsumes one d_i | |
| 1242 | (some #'(lambda (x) | |
| 1243 | (gen-subsume-prop c x)) | |
| 1244 | (term-subterms d)) | |
| 1245 | ;; c and d are :not, :atom, :forall, or :exists | |
| 1246 | (formula-is-identical c d) | |
| 1247 | ))))) | |
| 1249 | 1248 | (when *debug-subsume-prop* |
| 1250 | (format t "~&~d< ~a" *debug-subsume-prop-nest* res)) | |
| 1249 | (format t "~%~d< ~a" *debug-subsume-prop-nest* res)) | |
| 1251 | 1250 | ;; |
| 1252 | res | |
| 1253 | ))) | |
| 1251 | res))) | |
| 1254 | 1252 | |
| 1255 | 1253 | ;;; FORMULA-IS-IDENTICAL : Sentence Sentence -> Bool |
| 1256 | 1254 | ;;; |
| 1262 | 1260 | ;;; |
| 1263 | 1261 | (defun term->clause (f psys) |
| 1264 | 1262 | (declare (type term f) |
| 1265 | (type psystem psys)) | |
| 1263 | (type psystem psys)) | |
| 1266 | 1264 | (let ((type (fopl-sentence-type f)) |
| 1267 | (c (new-clause psys *current-formula*))) | |
| 1265 | (c (new-clause psys *current-formula*))) | |
| 1268 | 1266 | (declare (type symbol type) |
| 1269 | (type clause c)) | |
| 1267 | (type clause c)) | |
| 1270 | 1268 | (when *debug-formula* |
| 1271 | (format t "~&>>*term->clause: ") | |
| 1269 | (format t "~%>>*term->clause: ") | |
| 1272 | 1270 | (term-print f)) |
| 1273 | 1271 | (when (is-true? f) |
| 1274 | 1272 | (return-from term->clause nil)) |
| 1276 | 1274 | (case type |
| 1277 | 1275 | ((:atom :not :eq :beq) |
| 1278 | 1276 | (let ((lit (make-literal :sign (not (eq type :not)) |
| 1279 | :atom (if (not (eq type :not)) | |
| 1280 | f | |
| 1281 | ;; ~ P | |
| 1282 | (term-arg-1 f)) | |
| 1283 | :clause c))) | |
| 1284 | (declare (type literal lit)) | |
| 1285 | (mark-literal lit) | |
| 1286 | (if (is-false? f) | |
| 1287 | ;; make empty clause | |
| 1288 | (setf (clause-literals c) nil) | |
| 1289 | (setf (clause-literals c) (list lit))))) | |
| 1277 | :atom (if (not (eq type :not)) | |
| 1278 | f | |
| 1279 | ;; ~ P | |
| 1280 | (term-arg-1 f)) | |
| 1281 | :clause c))) | |
| 1282 | (declare (type literal lit)) | |
| 1283 | (mark-literal lit) | |
| 1284 | (if (is-false? f) | |
| 1285 | ;; make empty clause | |
| 1286 | (setf (clause-literals c) nil) | |
| 1287 | (setf (clause-literals c) (list lit))))) | |
| 1290 | 1288 | ;; |
| 1291 | 1289 | (:or |
| 1292 | 1290 | (let ((subs (gather-subterms-with-top (term-head f) f)) |
| 1293 | (res nil)) | |
| 1294 | (declare (type list subs res)) | |
| 1295 | (dolist (sub subs) | |
| 1296 | (let* ((stype (fopl-sentence-type sub)) | |
| 1297 | (lit (if (is-false? sub) | |
| 1298 | :false | |
| 1299 | (make-literal :sign (not (eq stype :not)) | |
| 1300 | :atom (if (not (eq stype :not)) | |
| 1301 | sub | |
| 1302 | (term-arg-1 sub)) | |
| 1303 | :clause c)))) | |
| 1304 | (declare (type symbol stype) | |
| 1305 | (type (or symbol literal) lit)) | |
| 1306 | (push lit res))) | |
| 1307 | (setq res (delete :false res :test #'eq)) | |
| 1308 | (dolist (l res) | |
| 1309 | (mark-literal l) | |
| 1310 | (push l (clause-literals c))) | |
| 1311 | )) | |
| 1291 | (res nil)) | |
| 1292 | (declare (type list subs res)) | |
| 1293 | (dolist (sub subs) | |
| 1294 | (let* ((stype (fopl-sentence-type sub)) | |
| 1295 | (lit (if (is-false? sub) | |
| 1296 | :false | |
| 1297 | (make-literal :sign (not (eq stype :not)) | |
| 1298 | :atom (if (not (eq stype :not)) | |
| 1299 | sub | |
| 1300 | (term-arg-1 sub)) | |
| 1301 | :clause c)))) | |
| 1302 | (declare (type symbol stype) | |
| 1303 | (type (or symbol literal) lit)) | |
| 1304 | (push lit res))) | |
| 1305 | (setq res (delete :false res :test #'eq)) | |
| 1306 | (dolist (l res) | |
| 1307 | (mark-literal l) | |
| 1308 | (push l (clause-literals c))) | |
| 1309 | )) | |
| 1312 | 1310 | ;; |
| 1313 | 1311 | (otherwise (with-output-panic-message () |
| 1314 | (format t "term->clause: accepted illegal formula~%") | |
| 1315 | (term-print f)))) | |
| 1312 | (format t "term->clause: accepted illegal formula~%") | |
| 1313 | (term-print f)))) | |
| 1316 | 1314 | ;; merge identical literals |
| 1317 | 1315 | (merge-clause c) |
| 1318 | 1316 | c)) |
| 1322 | 1320 | ;;; |
| 1323 | 1321 | (defun cnf-to-list (sentence psys) |
| 1324 | 1322 | (declare (type term sentence) |
| 1325 | (type psystem psys)) | |
| 1323 | (type psystem psys)) | |
| 1326 | 1324 | (let ((stype (fopl-sentence-type sentence))) |
| 1327 | 1325 | (declare (type symbol stype)) |
| 1328 | 1326 | (if (eq stype :and) |
| 1329 | (let ((subs (gather-subterms-with-top (term-head sentence) | |
| 1330 | sentence)) | |
| 1331 | (res nil)) | |
| 1332 | (declare (type list subs res)) | |
| 1333 | (dolist (s subs) | |
| 1334 | (declare (type term s)) | |
| 1335 | (unless (is-true? s) | |
| 1336 | (setq res (nconc res | |
| 1337 | (list (term->clause s psys)))))) | |
| 1338 | res) | |
| 1327 | (let ((subs (gather-subterms-with-top (term-head sentence) | |
| 1328 | sentence)) | |
| 1329 | (res nil)) | |
| 1330 | (declare (type list subs res)) | |
| 1331 | (dolist (s subs) | |
| 1332 | (declare (type term s)) | |
| 1333 | (unless (is-true? s) | |
| 1334 | (setq res (nconc res | |
| 1335 | (list (term->clause s psys)))))) | |
| 1336 | res) | |
| 1339 | 1337 | (let ((res (term->clause sentence psys))) |
| 1340 | (declare (type (or null clause) res)) | |
| 1341 | (if res | |
| 1342 | (list res) | |
| 1343 | nil)) | |
| 1338 | (declare (type (or null clause) res)) | |
| 1339 | (if res | |
| 1340 | (list res) | |
| 1341 | nil)) | |
| 1344 | 1342 | ))) |
| 1345 | 1343 | |
| 1346 | 1344 | ;;; EOF |
| 0 | 0 | ;;;-*-Mode:LISP; Package: CHAOS; Base:10; Syntax:Common-lisp -*- |
| 1 | 1 | ;;; |
| 2 | ;;; Copyright (c) 2000-2014, Toshimi Sawada. All rights reserved. | |
| 2 | ;;; Copyright (c) 2000-2015, Toshimi Sawada. All rights reserved. | |
| 3 | 3 | ;;; |
| 4 | 4 | ;;; Redistribution and use in source and binary forms, with or without |
| 5 | 5 | ;;; modification, are permitted provided that the following conditions |
| 28 | 28 | ;;; |
| 29 | 29 | (in-package :chaos) |
| 30 | 30 | #|============================================================================= |
| 31 | System:Chaos | |
| 32 | Module:BigPink | |
| 33 | File:glob.lisp | |
| 31 | System:Chaos | |
| 32 | Module:BigPink | |
| 33 | File:glob.lisp | |
| 34 | 34 | =============================================================================|# |
| 35 | 35 | #-:chaos-debug |
| 36 | 36 | (declaim (optimize (speed 3) (safety 0) #-GCL (debug 0))) |
| 41 | 41 | ;;; FOPL SYNTAX --------------------------------------------------------------- |
| 42 | 42 | ;;; *********** |
| 43 | 43 | |
| 44 | #|| | |
| 44 | #| | |
| 45 | 45 | ;;; t if our logic has two diffrent types of equality. |
| 46 | 46 | ;; (declaim (type boolean *fopl-two-equalities*)) |
| 47 | 47 | (defvar *fopl-two-equalities* nil) |
| 72 | 72 | (defvar *clause-constructor2* nil) |
| 73 | 73 | (defvar *fopl-sentence-seq* nil) |
| 74 | 74 | |
| 75 | ||# | |
| 75 | |# | |
| 76 | 76 | ;;; ******* |
| 77 | 77 | ;;; FORMULA ---------------------------------------------------------------- |
| 78 | 78 | ;;; ******* |
| 100 | 100 | ;;; PROOF SYSTEM |
| 101 | 101 | ;;; ------------ |
| 102 | 102 | (declaim (special *current-proof-system*)) |
| 103 | (defvar *current-proof-system* nil) ; current module | |
| 104 | (defvar *current-psys* nil) ; current psystem | |
| 105 | (defvar *given-clause* nil) ; current given clause | |
| 106 | ||
| 107 | (defvar *pn-proof-module* nil) ; built-in for invariance check | |
| 103 | (defvar *current-proof-system* nil) ; current module | |
| 104 | (defvar *current-psys* nil) ; current psystem | |
| 105 | (defvar *given-clause* nil) ; current given clause | |
| 106 | ||
| 107 | (defvar *pn-proof-module* nil) ; built-in for invariance check | |
| 108 | 108 | |
| 109 | 109 | (defvar *pn-refinement-check-module* nil) |
| 110 | ; built-in for refinement check | |
| 110 | ; built-in for refinement check | |
| 111 | 111 | |
| 112 | 112 | (defvar *pn-no-db-reset* nil) |
| 113 | 113 | |
| 117 | 117 | (defvar .pn-clause-deleted. 0) |
| 118 | 118 | |
| 119 | 119 | ;;; hash table of all clauses generated so far. |
| 120 | (defvar *clause-hash* nil) ; from *current-psys* | |
| 120 | (defvar *clause-hash* nil) ; from *current-psys* | |
| 121 | 121 | |
| 122 | 122 | ;;; Set of support (SOS) |
| 123 | 123 | (declaim (type list *sos*)) |
| 124 | (defvar *sos* nil) ; from *current-psys* | |
| 124 | (defvar *sos* nil) ; from *current-psys* | |
| 125 | 125 | |
| 126 | 126 | ;;; usable clauses |
| 127 | 127 | (declaim (type list *usable*)) |
| 128 | (defvar *usable* nil) ; from *current-psys* | |
| 128 | (defvar *usable* nil) ; from *current-psys* | |
| 129 | 129 | |
| 130 | 130 | ;;; demodulators |
| 131 | (defvar *demodulators* nil) ; from *current-psys* | |
| 131 | (defvar *demodulators* nil) ; from *current-psys* | |
| 132 | 132 | (defvar *new-demodulator* nil) |
| 133 | 133 | |
| 134 | 134 | (declaim (type list *passive*)) |
| 135 | (defvar *passive* nil) ; from *current-psys* | |
| 135 | (defvar *passive* nil) ; from *current-psys* | |
| 136 | 136 | |
| 137 | 137 | ;;; binds the last clause id given as input. |
| 138 | 138 | ;;; |
| 195 | 195 | |
| 196 | 196 | ;;; parameter index |
| 197 | 197 | |
| 198 | ; (defconstant REPORT 0) ; output stats and times every | |
| 199 | ; n seconds | |
| 200 | (defconstant MAX-GEN 0) ; stop search after this many | |
| 201 | ; generated clauses | |
| 202 | (defconstant MAX-KEPT 1) ; stop search after this many | |
| 203 | ; kept clauses | |
| 204 | (defconstant MAX-GIVEN 2) ; stop search after this many | |
| 205 | ; given clauses | |
| 206 | ; (defconstant MAX-LITERALS 5) ; max # of lits in kept clause | |
| 207 | ; (0 -> no limit) | |
| 208 | (defconstant MAX-WEIGHT 3) ; maximum weight of kept clauses | |
| 209 | ; (defconstant MAX-DISTINCT-VARS 7) ; max # of variables in kept | |
| 210 | ; clause | |
| 211 | (defconstant PICK-GIVEN-RATIO 4) ; pick lightest n times, then | |
| 212 | ; pick first | |
| 213 | ;(defconstant INTERRUPT-GIVEN 9) ; call interact after this | |
| 214 | ; many given cls | |
| 215 | (defconstant DEMOD-LIMIT 5) ; Limit on number of rewrites | |
| 216 | ; per clause | |
| 217 | (defconstant MAX-PROOFS 6) ; stop search after this many | |
| 218 | ; empty clauses | |
| 219 | ;(defconstant MIN-BIT-WIDTH 7) ; minimum field for bit strings | |
| 220 | (defconstant NEG-WEIGHT 8) ; add this value to wight of | |
| 221 | ; negative literals | |
| 222 | ;(defconstant PRETTY-PRINT-INDENT 9) ; indent for pretty print | |
| 223 | (defconstant STATS-LEVEL 10) ; higher stats-level -> output | |
| 224 | ; more statistics | |
| 225 | (defconstant CHANGE-LIMIT-AFTER 11) ; replace reduce-weight-limit | |
| 226 | (defconstant NEW-MAX-WEIGHT 12) ; replace reduce-weight-limit | |
| 227 | ;(defconstant HEAT 13) ; maximum heat level | |
| 228 | ;(defconstant DYNAMIC-HEAT-WEIGHT 14) ; max weigth of dynamic hot clause | |
| 229 | (defconstant MAX-ANSWERS 13) ; maximum number of answer literals | |
| 230 | ||
| 231 | ;(defconstant FSUB-HINT-ADD-WT 16) ; add to pick-given wt | |
| 232 | ;(defconstant BSUB-HINT-ADD-WT 17) ; add to pick-given wt | |
| 233 | ;(defconstant EQUIV-HINT-ADD-WT 23) ; add to pick-given wt | |
| 234 | ;(defconstant VERBOSE-DEMOD-SKIP 24) ; debugging option | |
| 235 | ||
| 236 | ;(defconstant FSUB-HINT-WT 25) ; pick-given wt | |
| 237 | ;(defconstant BSUB-HINT-WT 26) ; pick-given wt | |
| 238 | ;(defconstant EQUIV-HINT-WT 27) ; pick-given wt | |
| 239 | ||
| 240 | ;(defconstant AGE-FACTOR 30) ; to adjust the pick-given weight | |
| 241 | ;(defconstant DISTINCT-VARS-FACTOR 31) ; to adjust the pick-given weight | |
| 198 | ; (defconstant REPORT 0) ; output stats and times every | |
| 199 | ; n seconds | |
| 200 | (defconstant MAX-GEN 0) ; stop search after this many | |
| 201 | ; generated clauses | |
| 202 | (defconstant MAX-KEPT 1) ; stop search after this many | |
| 203 | ; kept clauses | |
| 204 | (defconstant MAX-GIVEN 2) ; stop search after this many | |
| 205 | ; given clauses | |
| 206 | ; (defconstant MAX-LITERALS 5) ; max # of lits in kept clause | |
| 207 | ; (0 -> no limit) | |
| 208 | (defconstant MAX-WEIGHT 3) ; maximum weight of kept clauses | |
| 209 | ; (defconstant MAX-DISTINCT-VARS 7) ; max # of variables in kept | |
| 210 | ; clause | |
| 211 | (defconstant PICK-GIVEN-RATIO 4) ; pick lightest n times, then | |
| 212 | ; pick first | |
| 213 | ;(defconstant INTERRUPT-GIVEN 9) ; call interact after this | |
| 214 | ; many given cls | |
| 215 | (defconstant DEMOD-LIMIT 5) ; Limit on number of rewrites | |
| 216 | ; per clause | |
| 217 | (defconstant MAX-PROOFS 6) ; stop search after this many | |
| 218 | ; empty clauses | |
| 219 | ;(defconstant MIN-BIT-WIDTH 7) ; minimum field for bit strings | |
| 220 | (defconstant NEG-WEIGHT 8) ; add this value to wight of | |
| 221 | ; negative literals | |
| 222 | ;(defconstant PRETTY-PRINT-INDENT 9) ; indent for pretty print | |
| 223 | (defconstant STATS-LEVEL 10) ; higher stats-level -> output | |
| 224 | ; more statistics | |
| 225 | (defconstant CHANGE-LIMIT-AFTER 11) ; replace reduce-weight-limit | |
| 226 | (defconstant NEW-MAX-WEIGHT 12) ; replace reduce-weight-limit | |
| 227 | ;(defconstant HEAT 13) ; maximum heat level | |
| 228 | ;(defconstant DYNAMIC-HEAT-WEIGHT 14) ; max weigth of dynamic hot clause | |
| 229 | (defconstant MAX-ANSWERS 13) ; maximum number of answer literals | |
| 230 | ||
| 231 | ;(defconstant FSUB-HINT-ADD-WT 16) ; add to pick-given wt | |
| 232 | ;(defconstant BSUB-HINT-ADD-WT 17) ; add to pick-given wt | |
| 233 | ;(defconstant EQUIV-HINT-ADD-WT 23) ; add to pick-given wt | |
| 234 | ;(defconstant VERBOSE-DEMOD-SKIP 24) ; debugging option | |
| 235 | ||
| 236 | ;(defconstant FSUB-HINT-WT 25) ; pick-given wt | |
| 237 | ;(defconstant BSUB-HINT-WT 26) ; pick-given wt | |
| 238 | ;(defconstant EQUIV-HINT-WT 27) ; pick-given wt | |
| 239 | ||
| 240 | ;(defconstant AGE-FACTOR 30) ; to adjust the pick-given weight | |
| 241 | ;(defconstant DISTINCT-VARS-FACTOR 31) ; to adjust the pick-given weight | |
| 242 | 242 | ;(defconstant NEW-SYMBOL-LEX-POSITION 32) |
| 243 | 243 | (defconstant MAX-SOS 14) |
| 244 | (defconstant MAX-SECONDS 15) ; stop search after this many | |
| 244 | (defconstant MAX-SECONDS 15) ; stop search after this many | |
| 245 | 245 | (defconstant DYNAMIC-DEMOD-DEPTH 16) |
| 246 | 246 | (defconstant DYNAMIC-DEMOD-RHS 17) |
| 247 | 247 | ;; |
| 434 | 434 | `(pignose-flag-hook (aref *pn-control-flags* ,flag-index))) |
| 435 | 435 | |
| 436 | 436 | ;;; IDEXES |
| 437 | (defconstant sos-queue 0) ; first clause on sos is given clause | |
| 438 | (defconstant sos-stack 1) ; pick last sos clause as given clause | |
| 439 | (defconstant input-sos-first 2) ; use input sos before generated sos | |
| 440 | ||
| 441 | (defconstant print-given 3) ; print given clauses | |
| 442 | (defconstant print-lists-at-end 4) ; print clause lists at end of run | |
| 443 | ||
| 444 | (defconstant binary-res 5) ; binary resolution | |
| 445 | (defconstant hyper-res 6) ; hyperresolution | |
| 446 | (defconstant neg-hyper-res 7) ; negatve hyperresolution inf rule | |
| 447 | ;(defconstant ur-res 8) ; UR-resolution. | |
| 448 | (defconstant para-into 8) ; `into' paramodulation inference rule | |
| 449 | (defconstant para-from 9) ; `from' paramodulation inference rule | |
| 450 | (defconstant demod-inf 10) ; apply demodulation as an inference rule | |
| 437 | (defconstant sos-queue 0) ; first clause on sos is given clause | |
| 438 | (defconstant sos-stack 1) ; pick last sos clause as given clause | |
| 439 | (defconstant input-sos-first 2) ; use input sos before generated sos | |
| 440 | ||
| 441 | (defconstant print-given 3) ; print given clauses | |
| 442 | (defconstant print-lists-at-end 4) ; print clause lists at end of run | |
| 443 | ||
| 444 | (defconstant binary-res 5) ; binary resolution | |
| 445 | (defconstant hyper-res 6) ; hyperresolution | |
| 446 | (defconstant neg-hyper-res 7) ; negatve hyperresolution inf rule | |
| 447 | ;(defconstant ur-res 8) ; UR-resolution. | |
| 448 | (defconstant para-into 8) ; `into' paramodulation inference rule | |
| 449 | (defconstant para-from 9) ; `from' paramodulation inference rule | |
| 450 | (defconstant demod-inf 10) ; apply demodulation as an inference rule | |
| 451 | 451 | |
| 452 | (defconstant para-from-left 11) ; allow paramodulation from left sides | |
| 453 | (defconstant para-from-right 12) ; allow paramodulation from right sides | |
| 454 | (defconstant para-into-left 13) ; allow paramodulation into | |
| 455 | ; left args of = | |
| 456 | (defconstant para-into-right 14) ; allow paramodulation into | |
| 457 | ; right args of = | |
| 458 | (defconstant para-from-vars 15) ; allow paramodulation from variables | |
| 459 | (defconstant para-into-vars 16) ; allow paramodulation into variables | |
| 460 | (defconstant para-from-units-only 17) ; from clause must be unit | |
| 461 | (defconstant para-into-units-only 18) ; into clause must be unit | |
| 462 | (defconstant para-skip-skolem 19) ; Skolem function restriction strategy | |
| 463 | (defconstant para-ones-rule 20) ; paramod only into first args of terms | |
| 464 | (defconstant para-all 21) ; paramodulate all occurrences | |
| 465 | ; of into term | |
| 466 | ;(defconstant detailed-history 23) ; store literal position vectors | |
| 467 | ;(defconstant order-history 24) ; Nucleus number first for | |
| 468 | ; hyper, UR. | |
| 469 | (defconstant unit-deletion 22) ; unit deletion processing | |
| 452 | (defconstant para-from-left 11) ; allow paramodulation from left sides | |
| 453 | (defconstant para-from-right 12) ; allow paramodulation from right sides | |
| 454 | (defconstant para-into-left 13) ; allow paramodulation into | |
| 455 | ; left args of = | |
| 456 | (defconstant para-into-right 14) ; allow paramodulation into | |
| 457 | ; right args of = | |
| 458 | (defconstant para-from-vars 15) ; allow paramodulation from variables | |
| 459 | (defconstant para-into-vars 16) ; allow paramodulation into variables | |
| 460 | (defconstant para-from-units-only 17) ; from clause must be unit | |
| 461 | (defconstant para-into-units-only 18) ; into clause must be unit | |
| 462 | (defconstant para-skip-skolem 19) ; Skolem function restriction strategy | |
| 463 | (defconstant para-ones-rule 20) ; paramod only into first args of terms | |
| 464 | (defconstant para-all 21) ; paramodulate all occurrences | |
| 465 | ; of into term | |
| 466 | ;(defconstant detailed-history 23) ; store literal position vectors | |
| 467 | ;(defconstant order-history 24) ; Nucleus number first for | |
| 468 | ; hyper, UR. | |
| 469 | (defconstant unit-deletion 22) ; unit deletion processing | |
| 470 | 470 | (defconstant delete-identical-nested-skolem 23) ; delete clauses containing |
| 471 | (defconstant sort-literals 24) ; sort literals in pre-process | |
| 472 | (defconstant for-sub 25) ; forward subsumption | |
| 473 | (defconstant back-sub 26) ; back subsumption | |
| 474 | (defconstant factor 27) ; factor during post-process | |
| 475 | ||
| 476 | ;(defconstant demod-history 31) ; build history in demodulation | |
| 477 | (defconstant order-eq 28) ; flip equalities (+ and -) if | |
| 478 | ; right arg heavier | |
| 479 | (defconstant eq-units-both-ways 29) ; non-oriented eq units both ways | |
| 480 | ||
| 481 | (defconstant dynamic-demod 30) ; dynamic addition of demodulators | |
| 482 | (defconstant dynamic-demod-all 31) ; try to make all equalities | |
| 483 | ; into demodulators | |
| 484 | (defconstant dynamic-demod-lex-dep 32) ; allow lex-dep dynamic demodulators | |
| 485 | (defconstant back-demod 33) ; back demodulation | |
| 486 | (defconstant kb 34) ; Attempt Knuth-Bendix completion | |
| 487 | (defconstant lrpo 35) ; lexicographic recursive path | |
| 488 | ; ordering | |
| 489 | (defconstant lex-order-vars 36) ; consider variables when | |
| 490 | ; lex-checking terms | |
| 491 | (defconstant simplify-fol 37) ; attempt to simplify during | |
| 492 | ; cnf translation | |
| 471 | (defconstant sort-literals 24) ; sort literals in pre-process | |
| 472 | (defconstant for-sub 25) ; forward subsumption | |
| 473 | (defconstant back-sub 26) ; back subsumption | |
| 474 | (defconstant factor 27) ; factor during post-process | |
| 475 | ||
| 476 | ;(defconstant demod-history 31) ; build history in demodulation | |
| 477 | (defconstant order-eq 28) ; flip equalities (+ and -) if | |
| 478 | ; right arg heavier | |
| 479 | (defconstant eq-units-both-ways 29) ; non-oriented eq units both ways | |
| 480 | ||
| 481 | (defconstant dynamic-demod 30) ; dynamic addition of demodulators | |
| 482 | (defconstant dynamic-demod-all 31) ; try to make all equalities | |
| 483 | ; into demodulators | |
| 484 | (defconstant dynamic-demod-lex-dep 32) ; allow lex-dep dynamic demodulators | |
| 485 | (defconstant back-demod 33) ; back demodulation | |
| 486 | (defconstant kb 34) ; Attempt Knuth-Bendix completion | |
| 487 | (defconstant lrpo 35) ; lexicographic recursive path | |
| 488 | ; ordering | |
| 489 | (defconstant lex-order-vars 36) ; consider variables when | |
| 490 | ; lex-checking terms | |
| 491 | (defconstant simplify-fol 37) ; attempt to simplify during | |
| 492 | ; cnf translation | |
| 493 | 493 | (defconstant new-variable-name 38) |
| 494 | (defconstant process-input 39) ; process input usable and sos | |
| 494 | (defconstant process-input 39) ; process input usable and sos | |
| 495 | 495 | (defconstant quiet 40) |
| 496 | (defconstant very-verbose 41) ; print generated clauses | |
| 497 | (defconstant print-kept 42) ; print kept clauses | |
| 498 | (defconstant print-proofs 43) ; print all proofs found | |
| 499 | (defconstant print-new-demod 44) ; print new demodultors | |
| 500 | (defconstant print-back-demod 45) ; print back demodulated clauses | |
| 501 | (defconstant print-back-sub 46) ; print back subsumed clauses | |
| 502 | ||
| 503 | (defconstant order-hyper 47) ; ordered hyperresolution | |
| 504 | ; (satellites) | |
| 505 | (defconstant propositional 48) ; some propositional | |
| 506 | ; optimizations | |
| 507 | ;(defconstant atom-wt-max-args 53) ; weight of atom is max of | |
| 508 | ; weights of arguments | |
| 509 | ;(defconstant term-wt-max-args 54) ; weight of term is max of | |
| 510 | ; weights of arguments | |
| 511 | (defconstant AUTO 49) ; select the current AUTO mode | |
| 512 | ;(defconstant proof-weight 56) ; Calculate proof weight (ancestor bag). | |
| 513 | (defconstant hyper-symmetry-kludge 50) ; Secret flag | |
| 514 | ;(defconstant gl-demod 58) ; Delay demodulation. | |
| 496 | (defconstant very-verbose 41) ; print generated clauses | |
| 497 | (defconstant print-kept 42) ; print kept clauses | |
| 498 | (defconstant print-proofs 43) ; print all proofs found | |
| 499 | (defconstant print-new-demod 44) ; print new demodultors | |
| 500 | (defconstant print-back-demod 45) ; print back demodulated clauses | |
| 501 | (defconstant print-back-sub 46) ; print back subsumed clauses | |
| 502 | ||
| 503 | (defconstant order-hyper 47) ; ordered hyperresolution | |
| 504 | ; (satellites) | |
| 505 | (defconstant propositional 48) ; some propositional | |
| 506 | ; optimizations | |
| 507 | ;(defconstant atom-wt-max-args 53) ; weight of atom is max of | |
| 508 | ; weights of arguments | |
| 509 | ;(defconstant term-wt-max-args 54) ; weight of term is max of | |
| 510 | ; weights of arguments | |
| 511 | (defconstant AUTO 49) ; select the current AUTO mode | |
| 512 | ;(defconstant proof-weight 56) ; Calculate proof weight (ancestor bag). | |
| 513 | (defconstant hyper-symmetry-kludge 50) ; Secret flag | |
| 514 | ;(defconstant gl-demod 58) ; Delay demodulation. | |
| 515 | 515 | (defconstant discard-non-orientable-eq 51) ; Secret flag |
| 516 | (defconstant discard-xx-resolvable 52) ; Secret flag | |
| 517 | (defconstant back-unit-deletion 53) ; like back demodulation, but | |
| 518 | ; for literals | |
| 516 | (defconstant discard-xx-resolvable 52) ; Secret flag | |
| 517 | (defconstant back-unit-deletion 53) ; like back demodulation, but | |
| 518 | ; for literals | |
| 519 | 519 | (defconstant auto2 54) |
| 520 | 520 | (defconstant auto1 55) |
| 521 | 521 | (defconstant auto3 56) |
| 539 | 539 | (defconstant no-new-demod 74) |
| 540 | 540 | ;;; new flags |
| 541 | 541 | (defconstant prop-res 75) |
| 542 | (defconstant no-junk 76) ; obsolete | |
| 543 | (defconstant no-confusion 77) ; obsolete | |
| 542 | (defconstant no-junk 76) ; obsolete | |
| 543 | (defconstant no-confusion 77) ; obsolete | |
| 544 | 544 | (defconstant meta-paramod 78) |
| 545 | 545 | (defconstant debug-inv-check 79) |
| 546 | 546 | (defconstant dist-const 80) |
| 669 | 669 | |
| 670 | 670 | ;;; BINARY-RES |
| 671 | 671 | #| |
| 672 | default off | |
| 673 | if set, inference rule binary resolution is used to | |
| 674 | generate new clauses. | |
| 675 | effected flags | |
| 676 | *factor* on | |
| 677 | *unit-del* on | |
| 672 | default off | |
| 673 | if set, inference rule binary resolution is used to | |
| 674 | generate new clauses. | |
| 675 | effected flags | |
| 676 | *factor* on | |
| 677 | *unit-del* on | |
| 678 | 678 | |# |
| 679 | 679 | |
| 680 | 680 | ;;; HYPER-RES |
| 681 | 681 | #| |
| 682 | default off | |
| 683 | if set, inference rule (positive) hyper resolution is used to | |
| 684 | generate new clauses. | |
| 682 | default off | |
| 683 | if set, inference rule (positive) hyper resolution is used to | |
| 684 | generate new clauses. | |
| 685 | 685 | |# |
| 686 | 686 | |
| 687 | 687 | ;;; NEG-HYPER-RES |
| 688 | 688 | #| |
| 689 | default off | |
| 690 | if set, inference rule negative hyper resolution is used | |
| 691 | to generate new clauses. | |
| 689 | default off | |
| 690 | if set, inference rule negative hyper resolution is used | |
| 691 | to generate new clauses. | |
| 692 | 692 | |# |
| 693 | 693 | |
| 694 | 694 | ;;; UR-RES |
| 695 | 695 | #| |
| 696 | default off | |
| 697 | if set, inference rule UR-resolution is used to generate | |
| 698 | new clauses. | |
| 696 | default off | |
| 697 | if set, inference rule UR-resolution is used to generate | |
| 698 | new clauses. | |
| 699 | 699 | |# |
| 700 | 700 | |
| 701 | 701 | ;;; PARA-INTO |
| 702 | 702 | #| |
| 703 | default off | |
| 704 | if set, inference rule "paramodulation into the given clause" | |
| 705 | is used to generate new clauses. | |
| 703 | default off | |
| 704 | if set, inference rule "paramodulation into the given clause" | |
| 705 | is used to generate new clauses. | |
| 706 | 706 | |# |
| 707 | 707 | |
| 708 | 708 | ;;; PARA-FROM |
| 709 | 709 | #| |
| 710 | default off | |
| 711 | if set, inference rule "paramodulation from the given clause" | |
| 712 | is used to generate new clauses. | |
| 710 | default off | |
| 711 | if set, inference rule "paramodulation from the given clause" | |
| 712 | is used to generate new clauses. | |
| 713 | 713 | |# |
| 714 | 714 | |
| 715 | 715 | ;;; PARAMODULATION |
| 716 | 716 | |
| 717 | 717 | ;;; PARA-FROM-LEFT |
| 718 | 718 | #| |
| 719 | default set | |
| 720 | if set, paramodulation is allowed from the left sides of | |
| 721 | equality literals. | |
| 722 | applied to both *para-into* and *para-from* inference rules. | |
| 719 | default set | |
| 720 | if set, paramodulation is allowed from the left sides of | |
| 721 | equality literals. | |
| 722 | applied to both *para-into* and *para-from* inference rules. | |
| 723 | 723 | |# |
| 724 | 724 | |
| 725 | 725 | ;;; PARA-FROM-RIGHT |
| 726 | 726 | #| |
| 727 | default set | |
| 728 | if set, paramodulation is allowed the right sides of | |
| 729 | equality literals. | |
| 730 | applied to both *para-into* and *para-from* inference rules. | |
| 727 | default set | |
| 728 | if set, paramodulation is allowed the right sides of | |
| 729 | equality literals. | |
| 730 | applied to both *para-into* and *para-from* inference rules. | |
| 731 | 731 | |# |
| 732 | 732 | |
| 733 | 733 | ;;; PARA-INTO-LEFT |
| 734 | 734 | #| |
| 735 | default set | |
| 736 | if set, paramodulation is allowed into left sides of | |
| 737 | positive and negative literals. | |
| 738 | applied to both *para-into* and *para-from* inference rules. | |
| 735 | default set | |
| 736 | if set, paramodulation is allowed into left sides of | |
| 737 | positive and negative literals. | |
| 738 | applied to both *para-into* and *para-from* inference rules. | |
| 739 | 739 | |# |
| 740 | 740 | |
| 741 | 741 | ;;; PARA-INTO-RIGHT |
| 742 | 742 | #| |
| 743 | default set | |
| 744 | if set, paramodulation is allowed into right sides of | |
| 745 | positive and gengative equalities. | |
| 746 | applied to both *para-into* and *para-from* inference rules. | |
| 743 | default set | |
| 744 | if set, paramodulation is allowed into right sides of | |
| 745 | positive and gengative equalities. | |
| 746 | applied to both *para-into* and *para-from* inference rules. | |
| 747 | 747 | |# |
| 748 | 748 | |
| 749 | 749 | ;;; Flags handling generated clauses |
| 751 | 751 | |
| 752 | 752 | ;;; DETAILED-HISTORY |
| 753 | 753 | #| |
| 754 | default set | |
| 755 | affects the parent lists in clauses that are derived by | |
| 756 | *binary-res*, *para-from* or *para-into*. | |
| 757 | if set, the positions of the unified literals or terms are | |
| 758 | given alog with the IDs of the parents. | |
| 759 | |# | |
| 754 | default set | |
| 755 | affects the parent lists in clauses that are derived by | |
| 756 | *binary-res*, *para-from* or *para-into*. | |
| 757 | if set, the positions of the unified literals or terms are | |
| 758 | given alog with the IDs of the parents. | |
| 759 | |# | |
| 760 | 760 | |
| 761 | 761 | ;;; ORDER-HISTORY |
| 762 | 762 | #| |
| 763 | default off | |
| 764 | affects the order of parent lists in clauses that are derived | |
| 765 | by hyperresolition, negative hyperresolution, or | |
| 766 | UR-reaolution. | |
| 767 | if set, the nucleus is listed first, and the satellites are | |
| 768 | listed in the order in which the corresponding literals appear | |
| 769 | in the nucleus. | |
| 770 | if the flag is off (or if the clause was derived by some other | |
| 771 | inference rule), the given clause is listed first. | |
| 763 | default off | |
| 764 | affects the order of parent lists in clauses that are derived | |
| 765 | by hyperresolition, negative hyperresolution, or | |
| 766 | UR-reaolution. | |
| 767 | if set, the nucleus is listed first, and the satellites are | |
| 768 | listed in the order in which the corresponding literals appear | |
| 769 | in the nucleus. | |
| 770 | if the flag is off (or if the clause was derived by some other | |
| 771 | inference rule), the given clause is listed first. | |
| 772 | 772 | |# |
| 773 | 773 | |
| 774 | 774 | ;;; UNIT-DELETION |
| 775 | 775 | #| |
| 776 | default off | |
| 777 | if set, unit deletion is applied to newly generated clauses. | |
| 778 | this removes a literal from a newly generated clause if | |
| 779 | the literal is the negation of an instance of a unit clause | |
| 780 | that ocuurs in usable or sos. | |
| 781 | ex. the second literal of `p(a, x) \| q(a, x)' is removed by | |
| 782 | the unit `~q(u,v)'; but it is not removed by the unit | |
| 783 | `~q(u,b)', because that unification causes the instantiation of | |
| 784 | x. | |
| 785 | ||
| 786 | all such literals are removed from the newly generated clause, | |
| 787 | even if the reslult is is the empty clauses. | |
| 788 | unit deletion is not useful if all generated clauses are | |
| 789 | units. | |
| 776 | default off | |
| 777 | if set, unit deletion is applied to newly generated clauses. | |
| 778 | this removes a literal from a newly generated clause if | |
| 779 | the literal is the negation of an instance of a unit clause | |
| 780 | that ocuurs in usable or sos. | |
| 781 | ex. the second literal of `p(a, x) \| q(a, x)' is removed by | |
| 782 | the unit `~q(u,v)'; but it is not removed by the unit | |
| 783 | `~q(u,b)', because that unification causes the instantiation of | |
| 784 | x. | |
| 785 | ||
| 786 | all such literals are removed from the newly generated clause, | |
| 787 | even if the reslult is is the empty clauses. | |
| 788 | unit deletion is not useful if all generated clauses are | |
| 789 | units. | |
| 790 | 790 | |
| 791 | 791 | |# |
| 792 | 792 | |
| 793 | 793 | ;;; FOR-SUB |
| 794 | 794 | #| |
| 795 | default set | |
| 796 | if this flag is set, forward subsumption is applied during | |
| 797 | the processing of newly generated clauses -- delete the new | |
| 798 | clause if it is subsumed by any clause in usable or sos. | |
| 795 | default set | |
| 796 | if this flag is set, forward subsumption is applied during | |
| 797 | the processing of newly generated clauses -- delete the new | |
| 798 | clause if it is subsumed by any clause in usable or sos. | |
| 799 | 799 | |# |
| 800 | 800 | |
| 801 | 801 | ;;; BACK-SUB |
| 802 | 802 | #| |
| 803 | default set | |
| 804 | if set, back subsumption is applied during the processing of | |
| 805 | newly kept clauses -- delete all clauses in usable or sos | |
| 806 | that are subsumed by the newly kept clause. | |
| 803 | default set | |
| 804 | if set, back subsumption is applied during the processing of | |
| 805 | newly kept clauses -- delete all clauses in usable or sos | |
| 806 | that are subsumed by the newly kept clause. | |
| 807 | 807 | |# |
| 808 | 808 | |
| 809 | 809 | ;;; FACTOR |
| 810 | 810 | #| |
| 811 | default off | |
| 812 | if set, factoring is applied in two ways. first, factoring is | |
| 813 | applied as a simplification rule to newly generated clauses. | |
| 814 | if a generated clause C has factors that subsume C, it is | |
| 815 | replaced with its smallest subsuing factor. | |
| 816 | second, it is applied as an inference rule to newly kept | |
| 817 | clauses. note that unlike other inference rules, factoring is | |
| 818 | not applied to the given clause; it is applied to a new clause | |
| 819 | as soon as it is kept. | |
| 820 | all factors are generated in an iterative manner. | |
| 821 | if factor is set, a clause with n-literals will not cause | |
| 822 | a clause with fewer than n-literals to be deleted by | |
| 823 | subsumption. | |
| 811 | default off | |
| 812 | if set, factoring is applied in two ways. first, factoring is | |
| 813 | applied as a simplification rule to newly generated clauses. | |
| 814 | if a generated clause C has factors that subsume C, it is | |
| 815 | replaced with its smallest subsuing factor. | |
| 816 | second, it is applied as an inference rule to newly kept | |
| 817 | clauses. note that unlike other inference rules, factoring is | |
| 818 | not applied to the given clause; it is applied to a new clause | |
| 819 | as soon as it is kept. | |
| 820 | all factors are generated in an iterative manner. | |
| 821 | if factor is set, a clause with n-literals will not cause | |
| 822 | a clause with fewer than n-literals to be deleted by | |
| 823 | subsumption. | |
| 824 | 824 | |# |
| 825 | 825 | |
| 826 | 826 | ;;; demodulation and ordering flags |
| 978 | 978 | |
| 979 | 979 | (declaim (type (simple-array fixnum (50)) *pn-stats*)) |
| 980 | 980 | (defvar *pn-stats* (make-array *pn-stat-size* |
| 981 | :element-type 'fixnum | |
| 982 | :initial-element 0)) | |
| 981 | :element-type 'fixnum | |
| 982 | :initial-element 0)) | |
| 983 | 983 | |
| 984 | 984 | ;;; STATISTICS ACCESSOR |
| 985 | 985 | ;;; |
| 1036 | 1036 | (defvar *pn-clocks* (make-array *pn-max-clocks*)) |
| 1037 | 1037 | |
| 1038 | 1038 | (defstruct (pn-clock (:type list)) |
| 1039 | (accum 0 :type integer) ; accumlated time | |
| 1040 | (curr -1 :type integer)) ; time since clock has been turned on | |
| 1039 | (accum 0 :type integer) ; accumlated time | |
| 1040 | (curr -1 :type integer)) ; time since clock has been turned on | |
| 1041 | 1041 | |
| 1042 | 1042 | (defmacro clock-start (clock-num) |
| 1043 | 1043 | `(let ((clock (aref *pn-clocks* ,clock-num))) |
| 1044 | 1044 | (if (not (= (pn-clock-curr clock) -1)) |
| 1045 | (with-output-chaos-warning () | |
| 1046 | (format t "clock #~d already on." ,clock-num)) | |
| 1045 | (with-output-chaos-warning () | |
| 1046 | (format t "clock #~d already on." ,clock-num)) | |
| 1047 | 1047 | (setf (pn-clock-curr clock) (get-internal-real-time))))) |
| 1048 | 1048 | |
| 1049 | 1049 | (defmacro clock-stop (clock-num) |
| 1050 | 1050 | `(let ((clock (aref *pn-clocks* ,clock-num))) |
| 1051 | 1051 | (if (= (pn-clock-curr clock) -1) |
| 1052 | (with-output-chaos-warning () | |
| 1053 | (format t "clock #~d already stop." ,clock-num)) | |
| 1052 | (with-output-chaos-warning () | |
| 1053 | (format t "clock #~d already stop." ,clock-num)) | |
| 1054 | 1054 | (progn |
| 1055 | (incf (pn-clock-accum clock) | |
| 1056 | (- (get-internal-real-time) (pn-clock-curr clock))) | |
| 1057 | (setf (pn-clock-curr clock) -1))))) | |
| 1055 | (incf (pn-clock-accum clock) | |
| 1056 | (- (get-internal-real-time) (pn-clock-curr clock))) | |
| 1057 | (setf (pn-clock-curr clock) -1))))) | |
| 1058 | 1058 | |
| 1059 | 1059 | (defun reset-pn-clocks () |
| 1060 | 1060 | (dotimes (x *pn-max-clocks*) |
| 1106 | 1106 | |
| 1107 | 1107 | (defun pn-internal-run-time () |
| 1108 | 1108 | (elapsed-time-in-seconds *pn-internal-start-time* |
| 1109 | (get-internal-run-time))) | |
| 1109 | (get-internal-run-time))) | |
| 1110 | 1110 | |
| 1111 | 1111 | ;;; SETUP |
| 1112 | 1112 | ;;; |
| 1115 | 1115 | (defun setup-pignose () |
| 1116 | 1116 | (setq .pn-ignore-ops. |
| 1117 | 1117 | (list *bool-and* |
| 1118 | *bool-or* | |
| 1119 | *bool-not* | |
| 1120 | *sort-membership* | |
| 1121 | *bool-if* | |
| 1122 | *bool-imply* | |
| 1123 | *bool-iff* | |
| 1124 | *bool-xor* | |
| 1125 | *bool-equal* | |
| 1126 | *beh-equal* | |
| 1127 | *bool-nonequal* | |
| 1128 | *beh-eq-pred* | |
| 1129 | *bool-and-also* | |
| 1130 | *bool-or-else*)) | |
| 1118 | *bool-or* | |
| 1119 | *bool-not* | |
| 1120 | *sort-membership* | |
| 1121 | *bool-if* | |
| 1122 | *bool-imply* | |
| 1123 | *bool-iff* | |
| 1124 | *bool-xor* | |
| 1125 | *bool-equal* | |
| 1126 | *beh-equal* | |
| 1127 | *bool-nonequal* | |
| 1128 | *beh-eq-pred* | |
| 1129 | *bool-and-also* | |
| 1130 | *bool-or-else*)) | |
| 1131 | 1131 | ) |
| 1132 | 1132 | |
| 1133 | 1133 | ;;; EOF |
| 0 | 0 | ;;;-*-Mode:LISP; Package: CHAOS; Base:10; Syntax:Common-lisp -*- |
| 1 | 1 | ;;; |
| 2 | ;;; Copyright (c) 2000-2014, Toshimi Sawada. All rights reserved. | |
| 2 | ;;; Copyright (c) 2000-2015, Toshimi Sawada. All rights reserved. | |
| 3 | 3 | ;;; |
| 4 | 4 | ;;; Redistribution and use in source and binary forms, with or without |
| 5 | 5 | ;;; modification, are permitted provided that the following conditions |
| 28 | 28 | ;;; |
| 29 | 29 | (in-package :chaos) |
| 30 | 30 | #|============================================================================= |
| 31 | System:Chaos | |
| 32 | Module:BigPink | |
| 33 | File:index.lisp | |
| 31 | System:Chaos | |
| 32 | Module:BigPink | |
| 33 | File:index.lisp | |
| 34 | 34 | =============================================================================|# |
| 35 | 35 | #-:chaos-debug |
| 36 | 36 | (declaim (optimize (speed 3) (safety 0) #-GCL (debug 0))) |
| 38 | 38 | (declaim (optimize (speed 1) (safety 3) #-GCL (debug 3))) |
| 39 | 39 | |
| 40 | 40 | ;;; ********** |
| 41 | ;;; INDEXING | |
| 41 | ;;; INDEXING | |
| 42 | 42 | ;;; ********** |
| 43 | 43 | |
| 44 | 44 | ;;; ========================== |
| 94 | 94 | ;;; |
| 95 | 95 | (defun specialize-term (term module) |
| 96 | 96 | (declare (type term term) |
| 97 | (type module module)) | |
| 97 | (type module module)) | |
| 98 | 98 | (let* ((method (if (term-is-applform? term) |
| 99 | (term-head term) | |
| 100 | nil)) | |
| 101 | (mmod (if method (method-module method) nil)) | |
| 102 | (promod (if *ignore-protected-modules* | |
| 103 | nil | |
| 104 | (module-protected-modules module))) | |
| 105 | (opinfo-table (module-opinfo-table module)) | |
| 106 | (result nil)) | |
| 99 | (term-head term) | |
| 100 | nil)) | |
| 101 | (mmod (if method (method-module method) nil)) | |
| 102 | (promod (if *ignore-protected-modules* | |
| 103 | nil | |
| 104 | (module-protected-modules module))) | |
| 105 | (opinfo-table (module-opinfo-table module)) | |
| 106 | (result nil)) | |
| 107 | 107 | (declare (type (or null method method)) |
| 108 | (type module) | |
| 109 | (type (or null module) mmod promod) | |
| 110 | (type hash-table opinfo-table) | |
| 111 | (type list result)) | |
| 108 | (type module) | |
| 109 | (type (or null module) mmod promod) | |
| 110 | (type hash-table opinfo-table) | |
| 111 | (type list result)) | |
| 112 | 112 | ;; |
| 113 | 113 | (unless (term-is-variable? term) |
| 114 | 114 | (setq result |
| 115 | (specialize-term-for-methods | |
| 116 | term | |
| 117 | (if (method-is-universal method) | |
| 118 | (method-lower-methods method opinfo-table) | |
| 119 | (remove-if #'(lambda (meth) | |
| 120 | (let ((xmod (method-module meth))) | |
| 121 | (and (not (eq xmod mmod)) | |
| 122 | (if (assq mmod (module-all-submodules xmod)) | |
| 123 | (memq mmod (module-protected-modules xmod)) | |
| 124 | (memq xmod promod))))) | |
| 125 | (method-lower-methods method opinfo-table))) | |
| 115 | (specialize-term-for-methods | |
| 116 | term | |
| 117 | (if (method-is-universal method) | |
| 118 | (method-lower-methods method opinfo-table) | |
| 119 | (remove-if #'(lambda (meth) | |
| 120 | (let ((xmod (method-module meth))) | |
| 121 | (and (not (eq xmod mmod)) | |
| 122 | (if (assq mmod (module-all-submodules xmod)) | |
| 123 | (memq mmod (module-protected-modules xmod)) | |
| 124 | (memq xmod promod))))) | |
| 125 | (method-lower-methods method opinfo-table))) | |
| 126 | 126 | module))) |
| 127 | 127 | result )) |
| 128 | 128 | |
| 129 | 129 | (defun get-all-methods-of-sort (sort module) |
| 130 | 130 | (declare (type sort* sort) |
| 131 | (type module module)) | |
| 131 | (type module module)) | |
| 132 | 132 | (let ((so (module-sort-order module)) |
| 133 | (res nil)) | |
| 133 | (res nil)) | |
| 134 | 134 | (dolist (info (module-all-operators module)) |
| 135 | 135 | (dolist (m (opinfo-methods info)) |
| 136 | (unless (eq *void-method* m) | |
| 137 | (when (sort<= (method-coarity m) sort so) | |
| 138 | (push m res))))) | |
| 136 | (unless (eq *void-method* m) | |
| 137 | (when (sort<= (method-coarity m) sort so) | |
| 138 | (push m res))))) | |
| 139 | 139 | res)) |
| 140 | 140 | |
| 141 | 141 | (defun specialize-term-for-methods (term methods mod) |
| 142 | 142 | (declare (type term term) |
| 143 | (type list methods) | |
| 144 | (type module mod)) | |
| 143 | (type list methods) | |
| 144 | (type module mod)) | |
| 145 | 145 | (let ((res nil)) |
| 146 | 146 | (dolist (method methods) |
| 147 | 147 | (declare (type method method)) |
| 148 | 148 | (when (rule-check-down mod method (term-subterms term)) |
| 149 | (push method res))) | |
| 149 | (push method res))) | |
| 150 | 150 | #|| |
| 151 | 151 | (dolist (sub (term-subterms term)) |
| 152 | 152 | (if (term-is-variable? sub) |
| 153 | (setq res | |
| 154 | (nconc res (get-all-methods-of-sort (variable-sort sub) mod))) | |
| 155 | (let ((meth (term-head sub))) | |
| 156 | (push meth res) | |
| 157 | (setq res | |
| 158 | (nconc res | |
| 159 | (method-lower-methods meth (module-opinfo-table mod))))) | |
| 160 | )) | |
| 153 | (setq res | |
| 154 | (nconc res (get-all-methods-of-sort (variable-sort sub) mod))) | |
| 155 | (let ((meth (term-head sub))) | |
| 156 | (push meth res) | |
| 157 | (setq res | |
| 158 | (nconc res | |
| 159 | (method-lower-methods meth (module-opinfo-table mod))))) | |
| 160 | )) | |
| 161 | 161 | ||# |
| 162 | 162 | ;; |
| 163 | 163 | res)) |
| 169 | 169 | |
| 170 | 170 | (defun pn-const-pat (atom) |
| 171 | 171 | (declare (type (or term sort*) atom) |
| 172 | (values (or sort* method))) | |
| 172 | (values (or sort* method))) | |
| 173 | 173 | (if (sort-p atom) |
| 174 | 174 | atom |
| 175 | 175 | (if (term-is-variable? atom) |
| 176 | (variable-sort atom) | |
| 176 | (variable-sort atom) | |
| 177 | 177 | (term-head atom)))) |
| 178 | 178 | |
| 179 | 179 | ;;; construct keys for adding/deleting pattern |
| 182 | 182 | |
| 183 | 183 | (defun pn-const-possible-pat (atom module &optional full) |
| 184 | 184 | (declare (type term atom) |
| 185 | (type module module)) | |
| 185 | (type module module)) | |
| 186 | 186 | (if (term-is-variable? atom) |
| 187 | 187 | (sub-or-equal-sorts (term-sort atom) (module-sort-order module)) |
| 188 | 188 | (let ((ops (if full |
| 189 | (term-operators atom) | |
| 190 | (list (term-head atom)))) | |
| 191 | (opinfo-table (module-opinfo-table module)) | |
| 192 | (ans nil)) | |
| 189 | (term-operators atom) | |
| 190 | (list (term-head atom)))) | |
| 191 | (opinfo-table (module-opinfo-table module)) | |
| 192 | (ans nil)) | |
| 193 | 193 | (declare (type list ops) |
| 194 | (type hash-table opinfo-table) | |
| 195 | (type list ans)) | |
| 194 | (type hash-table opinfo-table) | |
| 195 | (type list ans)) | |
| 196 | 196 | (dolist (op ops) |
| 197 | (declare (type method op)) | |
| 198 | (push op ans) | |
| 199 | (dolist (m (method-lower-methods op opinfo-table)) | |
| 200 | (pushnew m ans :test #'eq))) | |
| 197 | (declare (type method op)) | |
| 198 | (push op ans) | |
| 199 | (dolist (m (method-lower-methods op opinfo-table)) | |
| 200 | (pushnew m ans :test #'eq))) | |
| 201 | 201 | ans))) |
| 202 | 202 | |
| 203 | 203 | ;;; literal entry : literal |
| 214 | 214 | |
| 215 | 215 | (defun get-literal-entry-from-atom (db atom) |
| 216 | 216 | (declare (type hash-table db) (type (or term sort*) atom) |
| 217 | (values list)) | |
| 217 | (values list)) | |
| 218 | 218 | (get-indexed-data db (pn-const-pat atom))) |
| 219 | 219 | |
| 220 | 220 | (declaim (inline add-literal-to-table)) |
| 221 | 221 | |
| 222 | 222 | (defun add-literal-to-table (table lit &optional full) |
| 223 | 223 | (declare (type hash-table table) |
| 224 | (type literal lit)) | |
| 224 | (type literal lit)) | |
| 225 | 225 | (let ((keys (pn-const-possible-pat (literal-atom lit) *current-module* full))) |
| 226 | 226 | (declare (type list keys)) |
| 227 | 227 | (dolist (key keys) |
| 231 | 231 | |
| 232 | 232 | (defun delete-literal-from-table (table lit &optional full) |
| 233 | 233 | (declare (type hash-table table) |
| 234 | (type literal lit)) | |
| 234 | (type literal lit)) | |
| 235 | 235 | (let ((keys (pn-const-possible-pat (literal-atom lit) *current-module* full))) |
| 236 | 236 | (dolist (key keys) |
| 237 | 237 | (let ((new-data) |
| 238 | (lit-ent (get-indexed-data table key))) | |
| 239 | (dolist (l lit-ent) | |
| 240 | (unless (eq l lit) | |
| 241 | (push l new-data))) | |
| 242 | (set-to-index-table table key new-data))) | |
| 238 | (lit-ent (get-indexed-data table key))) | |
| 239 | (dolist (l lit-ent) | |
| 240 | (unless (eq l lit) | |
| 241 | (push l new-data))) | |
| 242 | (set-to-index-table table key new-data))) | |
| 243 | 243 | t)) |
| 244 | 244 | |
| 245 | 245 | (declaim (inline delete-literal-from-table-slow)) |
| 246 | 246 | |
| 247 | 247 | (defun delete-literal-from-table-slow (table lit) |
| 248 | 248 | (declare (type hash-table table) |
| 249 | (type literal lit)) | |
| 249 | (type literal lit)) | |
| 250 | 250 | (maphash #'(lambda (key data) |
| 251 | (declare (type list data)) | |
| 252 | (setf (gethash key table) | |
| 253 | (delete lit data :test #'eq))) | |
| 254 | table)) | |
| 251 | (declare (type list data)) | |
| 252 | (setf (gethash key table) | |
| 253 | (delete lit data :test #'eq))) | |
| 254 | table)) | |
| 255 | 255 | |
| 256 | 256 | ;;; --------------------------------------- |
| 257 | 257 | ;;; SPECIALIZED TABLE FUNCTIONS for CLAUSE |
| 259 | 259 | |
| 260 | 260 | (defun add-clause-to-table (table clause) |
| 261 | 261 | (declare (type hash-table table) |
| 262 | (type clause clause)) | |
| 262 | (type clause clause)) | |
| 263 | 263 | (dolist (lit (clause-literals clause)) |
| 264 | 264 | (declare (type literal lit)) |
| 265 | 265 | (add-literal-to-table table lit))) |
| 266 | 266 | |
| 267 | 267 | (defun delete-clause-from-table (table clause) |
| 268 | 268 | (declare (type hash-table table) |
| 269 | (type clause clause)) | |
| 269 | (type clause clause)) | |
| 270 | 270 | (dolist (lit (clause-literals clause)) |
| 271 | 271 | (declare (type literal lit)) |
| 272 | 272 | (delete-literal-from-table table lit))) |
| 331 | 331 | |
| 332 | 332 | (defmacro get-dtree (key hash) |
| 333 | 333 | (once-only (key hash) |
| 334 | `(or (gethash ,key ,hash) | |
| 335 | (let ((new-ent (make-dtree))) | |
| 336 | (setf (gethash ,key ,hash) new-ent) | |
| 337 | new-ent)))) | |
| 334 | `(or (gethash ,key ,hash) | |
| 335 | (let ((new-ent (make-dtree))) | |
| 336 | (setf (gethash ,key ,hash) new-ent) | |
| 337 | new-ent)))) | |
| 338 | 338 | |
| 339 | 339 | (defun is-insert (literal itable) |
| 340 | 340 | (let ((atom (literal-atom literal))) |
| 343 | 343 | |
| 344 | 344 | (defun dtree-index (key value dtree) |
| 345 | 345 | (flet ((lookup (atom dtree) |
| 346 | (or (cdr (assoc atom (dtree-atoms dtree))) | |
| 347 | (let ((new (make-empty-nlist))) | |
| 348 | (push (cons atom new) (dtree-atoms dtree)) | |
| 349 | new)))) | |
| 346 | (or (cdr (assoc atom (dtree-atoms dtree))) | |
| 347 | (let ((new (make-empty-nlist))) | |
| 348 | (push (cons atom new) (dtree-atoms dtree)) | |
| 349 | new)))) | |
| 350 | 350 | (cond ((null key)) |
| 351 | ((atom key) ; method/built-in value | |
| 352 | (nlist-push value (lookup key dtree))) | |
| 353 | ((not (termp key)) | |
| 354 | (dtree-index (first key) value | |
| 355 | (or (dtree-first dtree) | |
| 356 | (setf (dtree-first dtree) (make-dtree)))) | |
| 357 | (dtree-index (rest key) value | |
| 358 | (or (dtree-rest dtree) | |
| 359 | (setf (dtree-rest dtree) (make-dtree)))) | |
| 360 | ) | |
| 361 | ((term-is-applform? key) | |
| 362 | (dtree-index (term-head key) | |
| 363 | value | |
| 364 | (or (dtree-first dtree) | |
| 365 | (setf (dtree-first dtree) (make-dtree)))) | |
| 366 | (when (term-subterms key) | |
| 367 | (unless (dtree-rest dtree) | |
| 368 | (setf (dtree-rest dtree) (make-dtree))) | |
| 369 | (dtree-index (term-subterms key) value (dtree-rest dtree)))) | |
| 370 | ((term-is-variable? key) | |
| 371 | (nlist-push value (dtree-var dtree))) | |
| 372 | ((term-is-builtin-constant? key) | |
| 373 | (dtree-index (term-builtin-value key) value | |
| 374 | (or (dtree-first dtree) | |
| 375 | (setf (dtree-first dtree) (make-dtree)))) | |
| 376 | ;;(nlist-push value (lookup (term-builtin-value key) dtree)) | |
| 377 | ) | |
| 378 | (t (break "illegal key")) | |
| 379 | )) | |
| 351 | ((atom key) ; method/built-in value | |
| 352 | (nlist-push value (lookup key dtree))) | |
| 353 | ((not (termp key)) | |
| 354 | (dtree-index (first key) value | |
| 355 | (or (dtree-first dtree) | |
| 356 | (setf (dtree-first dtree) (make-dtree)))) | |
| 357 | (dtree-index (rest key) value | |
| 358 | (or (dtree-rest dtree) | |
| 359 | (setf (dtree-rest dtree) (make-dtree)))) | |
| 360 | ) | |
| 361 | ((term-is-applform? key) | |
| 362 | (dtree-index (term-head key) | |
| 363 | value | |
| 364 | (or (dtree-first dtree) | |
| 365 | (setf (dtree-first dtree) (make-dtree)))) | |
| 366 | (when (term-subterms key) | |
| 367 | (unless (dtree-rest dtree) | |
| 368 | (setf (dtree-rest dtree) (make-dtree))) | |
| 369 | (dtree-index (term-subterms key) value (dtree-rest dtree)))) | |
| 370 | ((term-is-variable? key) | |
| 371 | (nlist-push value (dtree-var dtree))) | |
| 372 | ((term-is-builtin-constant? key) | |
| 373 | (dtree-index (term-builtin-value key) value | |
| 374 | (or (dtree-first dtree) | |
| 375 | (setf (dtree-first dtree) (make-dtree)))) | |
| 376 | ;;(nlist-push value (lookup (term-builtin-value key) dtree)) | |
| 377 | ) | |
| 378 | (t (break "illegal key")) | |
| 379 | )) | |
| 380 | 380 | ) |
| 381 | 381 | |
| 382 | 382 | ;;; IS-FETCH |
| 384 | 384 | ;;; |
| 385 | 385 | (defun is-fetch (term is-table) |
| 386 | 386 | (dtree-fetch term (get-dtree (term-head term) is-table) |
| 387 | nil 0 nil most-positive-fixnum)) | |
| 387 | nil 0 nil most-positive-fixnum)) | |
| 388 | 388 | |
| 389 | 389 | (defmacro foreach-dentry ((var dtree-ent) &body body) |
| 390 | 390 | `(dolist (xent ,dtree-ent) |
| 394 | 394 | (defun is-fetch-concat (term is-table) |
| 395 | 395 | (let ((res nil)) |
| 396 | 396 | (foreach-dentry (e (is-fetch term is-table)) |
| 397 | (push e res)) | |
| 397 | (push e res)) | |
| 398 | 398 | #|| |
| 399 | 399 | (with-output-simple-msg () |
| 400 | 400 | (princ "fetch concat: ") |
| 401 | 401 | (term-print term) |
| 402 | 402 | (dolist (x res) |
| 403 | (print-next) | |
| 404 | (prin1 x))) | |
| 403 | (print-next) | |
| 404 | (prin1 x))) | |
| 405 | 405 | ||# |
| 406 | 406 | (nreverse res))) |
| 407 | 407 | |
| 412 | 412 | ;;; |
| 413 | 413 | (defun dtree-fetch (pat dtree var-list-in var-n-in best-list best-n) |
| 414 | 414 | (if (or (null dtree) |
| 415 | (null pat) | |
| 416 | (and (termp pat) (term-is-variable? pat))) | |
| 415 | (null pat) | |
| 416 | (and (termp pat) (term-is-variable? pat))) | |
| 417 | 417 | (values best-list best-n) |
| 418 | 418 | (let* ((var-nlist (dtree-var dtree)) |
| 419 | (var-n (+ var-n-in (nlist-n var-nlist))) | |
| 420 | (var-list (if (null (nlist-list var-nlist)) | |
| 421 | var-list-in | |
| 422 | (cons (nlist-list var-nlist) | |
| 423 | var-list-in)))) | |
| 419 | (var-n (+ var-n-in (nlist-n var-nlist))) | |
| 420 | (var-list (if (null (nlist-list var-nlist)) | |
| 421 | var-list-in | |
| 422 | (cons (nlist-list var-nlist) | |
| 423 | var-list-in)))) | |
| 424 | 424 | (cond ((>= var-n best-n) (values best-list best-n)) |
| 425 | ((atom pat) | |
| 426 | (dtree-atom-fetch pat | |
| 427 | dtree | |
| 428 | var-list | |
| 429 | var-n | |
| 430 | best-list | |
| 431 | best-n)) | |
| 432 | ((not (termp pat)) | |
| 433 | (multiple-value-bind (list1 n1) | |
| 434 | (dtree-fetch (first pat) | |
| 435 | (dtree-first dtree) | |
| 436 | var-list | |
| 437 | var-n | |
| 438 | best-list | |
| 439 | best-n) | |
| 440 | (dtree-fetch (rest pat) | |
| 441 | (dtree-rest dtree) | |
| 442 | var-list | |
| 443 | var-n | |
| 444 | list1 | |
| 445 | n1))) | |
| 446 | (t (multiple-value-bind (list1 n1) | |
| 447 | (if (term-is-builtin-constant? pat) | |
| 448 | (dtree-fetch (term-builtin-value pat) | |
| 449 | (dtree-first dtree) | |
| 450 | var-list | |
| 451 | var-n | |
| 452 | best-list | |
| 453 | best-n) | |
| 454 | (dtree-fetch (term-head pat) | |
| 455 | (dtree-first dtree) | |
| 456 | var-list | |
| 457 | var-n | |
| 458 | best-list | |
| 459 | best-n)) | |
| 460 | (dtree-fetch (term-subterms pat) | |
| 461 | (dtree-rest dtree) | |
| 462 | var-list | |
| 463 | var-n | |
| 464 | list1 | |
| 465 | n1)))) | |
| 425 | ((atom pat) | |
| 426 | (dtree-atom-fetch pat | |
| 427 | dtree | |
| 428 | var-list | |
| 429 | var-n | |
| 430 | best-list | |
| 431 | best-n)) | |
| 432 | ((not (termp pat)) | |
| 433 | (multiple-value-bind (list1 n1) | |
| 434 | (dtree-fetch (first pat) | |
| 435 | (dtree-first dtree) | |
| 436 | var-list | |
| 437 | var-n | |
| 438 | best-list | |
| 439 | best-n) | |
| 440 | (dtree-fetch (rest pat) | |
| 441 | (dtree-rest dtree) | |
| 442 | var-list | |
| 443 | var-n | |
| 444 | list1 | |
| 445 | n1))) | |
| 446 | (t (multiple-value-bind (list1 n1) | |
| 447 | (if (term-is-builtin-constant? pat) | |
| 448 | (dtree-fetch (term-builtin-value pat) | |
| 449 | (dtree-first dtree) | |
| 450 | var-list | |
| 451 | var-n | |
| 452 | best-list | |
| 453 | best-n) | |
| 454 | (dtree-fetch (term-head pat) | |
| 455 | (dtree-first dtree) | |
| 456 | var-list | |
| 457 | var-n | |
| 458 | best-list | |
| 459 | best-n)) | |
| 460 | (dtree-fetch (term-subterms pat) | |
| 461 | (dtree-rest dtree) | |
| 462 | var-list | |
| 463 | var-n | |
| 464 | list1 | |
| 465 | n1)))) | |
| 466 | 466 | ))) |
| 467 | 467 | |
| 468 | 468 | (defun dtree-atom-fetch (op dtree var-list var-n best-list best-n) |
| 474 | 474 | ;; |
| 475 | 475 | (let ((atom-nlist (cdr (assoc op (dtree-atoms dtree))))) |
| 476 | 476 | (cond ((or (null atom-nlist) (null (nlist-list atom-nlist))) |
| 477 | (values var-list var-n) | |
| 478 | ) | |
| 479 | ((and atom-nlist (< (incf var-n (nlist-n atom-nlist)) best-n)) | |
| 480 | (values (cons (nlist-list atom-nlist) var-list) var-n)) | |
| 481 | (t (values best-list best-n)) | |
| 482 | ))) | |
| 477 | (values var-list var-n) | |
| 478 | ) | |
| 479 | ((and atom-nlist (< (incf var-n (nlist-n atom-nlist)) best-n)) | |
| 480 | (values (cons (nlist-list atom-nlist) var-list) var-n)) | |
| 481 | (t (values best-list best-n)) | |
| 482 | ))) | |
| 483 | 483 | |
| 484 | 484 | |
| 485 | 485 | ;;; IS-DELETE |
| 486 | 486 | ;;; |
| 487 | 487 | (defun dtree-delete (key value dtree test) |
| 488 | 488 | (flet ((lookup (atom dtree) |
| 489 | (cdr (assoc atom (dtree-atoms dtree)))) | |
| 490 | (nlist-delete (nlist) | |
| 491 | (when nlist | |
| 492 | (decf (car nlist)) | |
| 493 | (setf (cdr nlist) | |
| 494 | (delete value (cdr nlist) :count 1 :test test)) | |
| 495 | nlist))) | |
| 489 | (cdr (assoc atom (dtree-atoms dtree)))) | |
| 490 | (nlist-delete (nlist) | |
| 491 | (when nlist | |
| 492 | (decf (car nlist)) | |
| 493 | (setf (cdr nlist) | |
| 494 | (delete value (cdr nlist) :count 1 :test test)) | |
| 495 | nlist))) | |
| 496 | 496 | (when dtree |
| 497 | 497 | (cond ((null key)) |
| 498 | ((atom key) | |
| 499 | (let ((nlist (lookup key dtree))) | |
| 500 | (when nlist | |
| 501 | (nlist-delete (lookup key dtree))))) | |
| 502 | ((not (termp key)) | |
| 503 | (dtree-delete (first key) | |
| 504 | value | |
| 505 | (dtree-first dtree) | |
| 506 | test) | |
| 507 | (dtree-delete (rest key) | |
| 508 | value | |
| 509 | (dtree-rest dtree) | |
| 510 | test)) | |
| 511 | ((term-is-applform? key) | |
| 512 | (dtree-delete (term-head key) | |
| 513 | value | |
| 514 | (dtree-first dtree) | |
| 515 | test) | |
| 516 | (dtree-delete (term-subterms key) value (dtree-rest dtree) | |
| 517 | test)) | |
| 518 | ((term-is-variable? key) | |
| 519 | (dolist (ns (dtree-atoms dtree)) | |
| 520 | (nlist-delete ns)) | |
| 521 | (nlist-delete (dtree-var dtree))) | |
| 522 | ((term-is-builtin-constant? key) | |
| 523 | (dtree-delete value (term-builtin-value key) | |
| 524 | (dtree-first dtree) | |
| 525 | test) | |
| 526 | ;; (nlist-delete value (lookup (term-builtin-value key) dtree)) | |
| 527 | ) | |
| 528 | (t (break "illegal key")) | |
| 529 | )) | |
| 498 | ((atom key) | |
| 499 | (let ((nlist (lookup key dtree))) | |
| 500 | (when nlist | |
| 501 | (nlist-delete (lookup key dtree))))) | |
| 502 | ((not (termp key)) | |
| 503 | (dtree-delete (first key) | |
| 504 | value | |
| 505 | (dtree-first dtree) | |
| 506 | test) | |
| 507 | (dtree-delete (rest key) | |
| 508 | value | |
| 509 | (dtree-rest dtree) | |
| 510 | test)) | |
| 511 | ((term-is-applform? key) | |
| 512 | (dtree-delete (term-head key) | |
| 513 | value | |
| 514 | (dtree-first dtree) | |
| 515 | test) | |
| 516 | (dtree-delete (term-subterms key) value (dtree-rest dtree) | |
| 517 | test)) | |
| 518 | ((term-is-variable? key) | |
| 519 | (dolist (ns (dtree-atoms dtree)) | |
| 520 | (nlist-delete ns)) | |
| 521 | (nlist-delete (dtree-var dtree))) | |
| 522 | ((term-is-builtin-constant? key) | |
| 523 | (dtree-delete value (term-builtin-value key) | |
| 524 | (dtree-first dtree) | |
| 525 | test) | |
| 526 | ;; (nlist-delete value (lookup (term-builtin-value key) dtree)) | |
| 527 | ) | |
| 528 | (t (break "illegal key")) | |
| 529 | )) | |
| 530 | 530 | )) |
| 531 | 531 | |
| 532 | 532 | (defun is-delete (literal itable &optional (test #'eql)) |
| 533 | 533 | (let ((atom (literal-atom literal))) |
| 534 | 534 | (dtree-delete atom literal (get-dtree (term-head atom) itable) |
| 535 | test) | |
| 535 | test) | |
| 536 | 536 | )) |
| 537 | 537 | |
| 538 | 538 | ;;; INDEX-ALL-LITERALS : Clause -> Void |
| 550 | 550 | ;; (register-clause cl *current-psys*) |
| 551 | 551 | (let ((c2 nil)) |
| 552 | 552 | (when (and (eq (clause-container cl) :passive) |
| 553 | (unit-clause? cl) | |
| 554 | ) | |
| 555 | (let ((lit (ith-literal cl 1))) | |
| 556 | (when (eq-literal? lit) | |
| 557 | (setq c2 (copy-clause cl)) | |
| 558 | ;; (register-clause c2 *current-psys*) | |
| 559 | (setf (clause-parents c2) | |
| 560 | (list (list :copy-rule (clause-id cl) | |
| 561 | :flip-eq-rule | |
| 562 | ))) | |
| 563 | (setq lit (ith-literal c2 1)) | |
| 564 | (let* ((atom (literal-atom lit)) | |
| 565 | (new-atom (make-term-with-sort-check *fopl-eq* | |
| 566 | (list (term-arg-2 atom) | |
| 567 | (term-arg-1 atom))))) | |
| 568 | (setf (literal-atom lit) new-atom)))) | |
| 569 | ) | |
| 553 | (unit-clause? cl) | |
| 554 | ) | |
| 555 | (let ((lit (ith-literal cl 1))) | |
| 556 | (when (eq-literal? lit) | |
| 557 | (setq c2 (copy-clause cl)) | |
| 558 | ;; (register-clause c2 *current-psys*) | |
| 559 | (setf (clause-parents c2) | |
| 560 | (list (list :copy-rule (clause-id cl) | |
| 561 | :flip-eq-rule | |
| 562 | ))) | |
| 563 | (setq lit (ith-literal c2 1)) | |
| 564 | (let* ((atom (literal-atom lit)) | |
| 565 | (new-atom (make-term-with-sort-check *fopl-eq* | |
| 566 | (list (term-arg-2 atom) | |
| 567 | (term-arg-1 atom))))) | |
| 568 | (setf (literal-atom lit) new-atom)))) | |
| 569 | ) | |
| 570 | 570 | (dolist (lit (if c2 |
| 571 | (append (clause-literals cl) | |
| 572 | (clause-literals c2)) | |
| 573 | (clause-literals cl))) | |
| 574 | (declare (type literal lit)) | |
| 575 | (unless (answer-literal? lit) | |
| 576 | (when (and (pn-flag back-demod) | |
| 577 | (not (eq (clause-container cl) :passive))) | |
| 578 | (add-literal-to-table *full-lit-table* lit t)) | |
| 579 | (cond ((positive-literal? lit) | |
| 580 | ;; (add-literal-to-table *pos-literals* lit) | |
| 581 | (is-insert lit *pos-literals*) | |
| 582 | ) | |
| 583 | (t | |
| 584 | ;; (add-literal-to-table *neg-literals* lit) | |
| 585 | (is-insert lit *neg-literals*) | |
| 586 | )))) | |
| 571 | (append (clause-literals cl) | |
| 572 | (clause-literals c2)) | |
| 573 | (clause-literals cl))) | |
| 574 | (declare (type literal lit)) | |
| 575 | (unless (answer-literal? lit) | |
| 576 | (when (and (pn-flag back-demod) | |
| 577 | (not (eq (clause-container cl) :passive))) | |
| 578 | (add-literal-to-table *full-lit-table* lit t)) | |
| 579 | (cond ((positive-literal? lit) | |
| 580 | ;; (add-literal-to-table *pos-literals* lit) | |
| 581 | (is-insert lit *pos-literals*) | |
| 582 | ) | |
| 583 | (t | |
| 584 | ;; (add-literal-to-table *neg-literals* lit) | |
| 585 | (is-insert lit *neg-literals*) | |
| 586 | )))) | |
| 587 | 587 | ))) |
| 588 | 588 | ||# |
| 589 | 589 | |
| 591 | 591 | (declare (type clause cl)) |
| 592 | 592 | (let ((c2 nil)) |
| 593 | 593 | (when (and (eq (clause-container cl) :passive) |
| 594 | (unit-clause? cl)) | |
| 594 | (unit-clause? cl)) | |
| 595 | 595 | (let ((lit (ith-literal cl 1))) |
| 596 | (when (and (eq-literal? lit) | |
| 597 | ;; | |
| 598 | ;; (pn-flag eq-units-both-ways) | |
| 599 | ;; | |
| 600 | t) | |
| 601 | (setq c2 (copy-clause cl)) | |
| 602 | (setf (clause-parents c2) | |
| 603 | (list (list :copy-rule (clause-id cl) | |
| 604 | :flip-eq-rule | |
| 605 | ))) | |
| 606 | (setq lit (ith-literal c2 1)) | |
| 607 | (let* ((atom (literal-atom lit)) | |
| 608 | (new-atom (make-term-with-sort-check *fopl-eq* | |
| 609 | (list (term-arg-2 atom) | |
| 610 | (term-arg-1 atom))))) | |
| 611 | (setf (literal-atom lit) new-atom)))) | |
| 596 | (when (and (eq-literal? lit) | |
| 597 | ;; | |
| 598 | ;; (pn-flag eq-units-both-ways) | |
| 599 | ;; | |
| 600 | t) | |
| 601 | (setq c2 (copy-clause cl)) | |
| 602 | (setf (clause-parents c2) | |
| 603 | (list (list :copy-rule (clause-id cl) | |
| 604 | :flip-eq-rule | |
| 605 | ))) | |
| 606 | (setq lit (ith-literal c2 1)) | |
| 607 | (let* ((atom (literal-atom lit)) | |
| 608 | (new-atom (make-term-with-sort-check *fopl-eq* | |
| 609 | (list (term-arg-2 atom) | |
| 610 | (term-arg-1 atom))))) | |
| 611 | (setf (literal-atom lit) new-atom)))) | |
| 612 | 612 | ) |
| 613 | 613 | (dolist (lit (if c2 |
| 614 | (append (clause-literals cl) | |
| 615 | (clause-literals c2)) | |
| 616 | (clause-literals cl))) | |
| 614 | (append (clause-literals cl) | |
| 615 | (clause-literals c2)) | |
| 616 | (clause-literals cl))) | |
| 617 | 617 | (declare (type literal lit)) |
| 618 | 618 | (unless (answer-literal? lit) |
| 619 | (when (and (pn-flag back-demod) | |
| 620 | (not (eq (clause-container cl) :passive))) | |
| 621 | (add-literal-to-table *full-lit-table* lit t)) | |
| 622 | (cond ((positive-literal? lit) | |
| 623 | ;; (add-literal-to-table *pos-literals* lit) | |
| 624 | (is-insert lit *pos-literals*) | |
| 625 | ) | |
| 626 | (t | |
| 627 | ;; (add-literal-to-table *neg-literals* lit) | |
| 628 | (is-insert lit *neg-literals*) | |
| 629 | )))) | |
| 619 | (when (and (pn-flag back-demod) | |
| 620 | (not (eq (clause-container cl) :passive))) | |
| 621 | (add-literal-to-table *full-lit-table* lit t)) | |
| 622 | (cond ((positive-literal? lit) | |
| 623 | ;; (add-literal-to-table *pos-literals* lit) | |
| 624 | (is-insert lit *pos-literals*) | |
| 625 | ) | |
| 626 | (t | |
| 627 | ;; (add-literal-to-table *neg-literals* lit) | |
| 628 | (is-insert lit *neg-literals*) | |
| 629 | )))) | |
| 630 | 630 | )) |
| 631 | 631 | |
| 632 | 632 | ;;; UN-IDEX-ALL-LITERALS : Clause -> Void |
| 639 | 639 | (delete-literal-from-table *full-lit-table* lit t)) |
| 640 | 640 | (unless (answer-literal? lit) |
| 641 | 641 | (cond ((positive-literal? lit) |
| 642 | ;; (delete-literal-from-table *pos-literals* lit) | |
| 643 | (is-delete lit *pos-literals*) | |
| 644 | ) | |
| 645 | (t | |
| 646 | ;; (delete-literal-from-table *neg-literals* lit) | |
| 647 | (is-delete lit *neg-literals*) | |
| 648 | ) | |
| 649 | )))) | |
| 642 | ;; (delete-literal-from-table *pos-literals* lit) | |
| 643 | (is-delete lit *pos-literals*) | |
| 644 | ) | |
| 645 | (t | |
| 646 | ;; (delete-literal-from-table *neg-literals* lit) | |
| 647 | (is-delete lit *neg-literals*) | |
| 648 | ) | |
| 649 | )))) | |
| 650 | 650 | |
| 651 | 651 | (defun un-index-all-literals-slow (clause) |
| 652 | 652 | (declare (type clause clause)) |
| 656 | 656 | (delete-literal-from-table-slow *full-lit-table* lit)) |
| 657 | 657 | (unless (answer-literal? lit) |
| 658 | 658 | (cond ((positive-literal? lit) |
| 659 | ;; (delete-literal-from-table-slow *pos-literals* lit) | |
| 660 | (is-delete lit *pos-literals*) | |
| 661 | ) | |
| 662 | (t | |
| 663 | ;; (delete-literal-from-table-slow *neg-literals* lit) | |
| 664 | (is-delete lit *neg-literals*) | |
| 665 | ) | |
| 666 | )) | |
| 659 | ;; (delete-literal-from-table-slow *pos-literals* lit) | |
| 660 | (is-delete lit *pos-literals*) | |
| 661 | ) | |
| 662 | (t | |
| 663 | ;; (delete-literal-from-table-slow *neg-literals* lit) | |
| 664 | (is-delete lit *neg-literals*) | |
| 665 | ) | |
| 666 | )) | |
| 667 | 667 | )) |
| 668 | 668 | |
| 669 | 669 | ;;; INDEX-CLASH-LITERALS |
| 677 | 677 | (unless (answer-literal? lit) |
| 678 | 678 | ;; register to clash tables |
| 679 | 679 | (if (positive-literal? lit) |
| 680 | ;; (add-literal-to-table *clash-pos-literals* lit) | |
| 681 | (is-insert lit *clash-pos-literals*) | |
| 682 | ;; (add-literal-to-table *clash-neg-literals* lit) | |
| 683 | (is-insert lit *clash-neg-literals*) | |
| 684 | ) | |
| 680 | ;; (add-literal-to-table *clash-pos-literals* lit) | |
| 681 | (is-insert lit *clash-pos-literals*) | |
| 682 | ;; (add-literal-to-table *clash-neg-literals* lit) | |
| 683 | (is-insert lit *clash-neg-literals*) | |
| 684 | ) | |
| 685 | 685 | (when (or (pn-flag para-from) (pn-flag para-into)) |
| 686 | ;; register to paramod table | |
| 687 | (index-paramodulation lit)))) | |
| 686 | ;; register to paramod table | |
| 687 | (index-paramodulation lit)))) | |
| 688 | 688 | ) |
| 689 | 689 | |
| 690 | 690 | ;;; UN-INDEX-CLASH-LITERALS |
| 695 | 695 | (declare (type literal lit)) |
| 696 | 696 | (unless (answer-literal? lit) |
| 697 | 697 | (if (positive-literal? lit) |
| 698 | ;; (delete-literal-from-table *clash-pos-literals* lit) | |
| 699 | (is-delete lit *clash-pos-literals*) | |
| 700 | ;; (delete-literal-from-table *clash-neg-literals* lit) | |
| 701 | (is-delete lit *clash-neg-literals*) | |
| 702 | ) | |
| 698 | ;; (delete-literal-from-table *clash-pos-literals* lit) | |
| 699 | (is-delete lit *clash-pos-literals*) | |
| 700 | ;; (delete-literal-from-table *clash-neg-literals* lit) | |
| 701 | (is-delete lit *clash-neg-literals*) | |
| 702 | ) | |
| 703 | 703 | (when (or (pn-flag para-from) (pn-flag para-into)) |
| 704 | (un-index-paramodulation lit)))) | |
| 704 | (un-index-paramodulation lit)))) | |
| 705 | 705 | ) |
| 706 | 706 | |
| 707 | 707 | (defun un-index-clash-literals-slow (c) |
| 710 | 710 | (declare (type literal lit)) |
| 711 | 711 | (unless (answer-literal? lit) |
| 712 | 712 | (if (positive-literal? lit) |
| 713 | ;; (delete-literal-from-table-slow *clash-pos-literals* lit) | |
| 714 | (is-delete lit *clash-pos-literals*) | |
| 715 | ;; (delete-literal-from-table-slow *clash-neg-literals* lit) | |
| 716 | (is-delete lit *clash-neg-literals*) | |
| 717 | ) | |
| 713 | ;; (delete-literal-from-table-slow *clash-pos-literals* lit) | |
| 714 | (is-delete lit *clash-pos-literals*) | |
| 715 | ;; (delete-literal-from-table-slow *clash-neg-literals* lit) | |
| 716 | (is-delete lit *clash-neg-literals*) | |
| 717 | ) | |
| 718 | 718 | (when (or (pn-flag para-from) (pn-flag para-into)) |
| 719 | (un-index-paramodulation-slow lit) | |
| 720 | ))) | |
| 719 | (un-index-paramodulation-slow lit) | |
| 720 | ))) | |
| 721 | 721 | ) |
| 722 | 722 | |
| 723 | 723 | ;;; ===================== |
| 726 | 726 | |
| 727 | 727 | (defun get-paramod-entry (key table) |
| 728 | 728 | (if (term-is-variable? key) |
| 729 | (get-dtree (variable-sort key) table) | |
| 729 | (get-dtree (variable-sort key) table) | |
| 730 | 730 | (get-dtree (term-head key) table))) |
| 731 | 731 | |
| 732 | 732 | (defun is-paramod-insert (lhs paramod itable) |
| 733 | 733 | (flet ((insert-from-var-pat (sort) |
| 734 | (push paramod (gethash sort *parafrom-var-rules*))) | |
| 735 | (insert-to-var-pat (sort) | |
| 736 | (push paramod (gethash sort *parainto-var-rules*))) | |
| 737 | ) | |
| 734 | (push paramod (gethash sort *parafrom-var-rules*))) | |
| 735 | (insert-to-var-pat (sort) | |
| 736 | (push paramod (gethash sort *parainto-var-rules*))) | |
| 737 | ) | |
| 738 | 738 | (if (term-is-variable? lhs) |
| 739 | (insert-from-var-pat (variable-sort lhs)) | |
| 739 | (insert-from-var-pat (variable-sort lhs)) | |
| 740 | 740 | (progn |
| 741 | (dtree-index lhs paramod (get-paramod-entry lhs itable)) | |
| 742 | (when (pn-flag para-into-vars) | |
| 743 | (insert-to-var-pat (term-sort lhs)))) | |
| 741 | (dtree-index lhs paramod (get-paramod-entry lhs itable)) | |
| 742 | (when (pn-flag para-into-vars) | |
| 743 | (insert-to-var-pat (term-sort lhs)))) | |
| 744 | 744 | ))) |
| 745 | 745 | |
| 746 | 746 | (defun is-paramod-delete (lhs literal itable) |
| 747 | 747 | (flet ((delete-into-var-pat (sort) |
| 748 | (let ((ent (gethash sort *parainto-var-rules*))) | |
| 749 | (setf (gethash sort *parainto-var-rules*) | |
| 750 | (delete literal ent | |
| 751 | :test #'(lambda (x y) | |
| 752 | (eq x (paramod-literal y))))))) | |
| 753 | (delete-from-var-pat (sort) | |
| 754 | (let ((ent (gethash sort *parafrom-var-rules*))) | |
| 755 | (setf (gethash sort *parafrom-var-rules*) | |
| 756 | (delete literal ent | |
| 757 | :test #'(lambda (x y) | |
| 758 | (eq x (paramod-literal y)))))))) | |
| 748 | (let ((ent (gethash sort *parainto-var-rules*))) | |
| 749 | (setf (gethash sort *parainto-var-rules*) | |
| 750 | (delete literal ent | |
| 751 | :test #'(lambda (x y) | |
| 752 | (eq x (paramod-literal y))))))) | |
| 753 | (delete-from-var-pat (sort) | |
| 754 | (let ((ent (gethash sort *parafrom-var-rules*))) | |
| 755 | (setf (gethash sort *parafrom-var-rules*) | |
| 756 | (delete literal ent | |
| 757 | :test #'(lambda (x y) | |
| 758 | (eq x (paramod-literal y)))))))) | |
| 759 | 759 | (if (term-is-variable? lhs) |
| 760 | (delete-from-var-pat (variable-sort lhs)) | |
| 760 | (delete-from-var-pat (variable-sort lhs)) | |
| 761 | 761 | (progn |
| 762 | (dtree-delete lhs literal (get-paramod-entry lhs itable) | |
| 763 | #'(lambda (x y) | |
| 764 | (eq x (paramod-literal y)))) | |
| 765 | (when (pn-flag para-into-vars) | |
| 766 | (delete-into-var-pat (term-sort lhs))) | |
| 767 | )))) | |
| 762 | (dtree-delete lhs literal (get-paramod-entry lhs itable) | |
| 763 | #'(lambda (x y) | |
| 764 | (eq x (paramod-literal y)))) | |
| 765 | (when (pn-flag para-into-vars) | |
| 766 | (delete-into-var-pat (term-sort lhs))) | |
| 767 | )))) | |
| 768 | 768 | |
| 769 | 769 | (defun is-paramod-fetch (term itable) |
| 770 | 770 | (if (term-is-variable? term) |
| 771 | 771 | (list (gethash (variable-sort term) *parainto-var-rules*)) |
| 772 | 772 | (dtree-fetch term (get-paramod-entry term itable) |
| 773 | nil 0 nil most-positive-fixnum))) | |
| 773 | nil 0 nil most-positive-fixnum))) | |
| 774 | 774 | |
| 775 | 775 | (defun is-paramod-fetch-concat (term itable) |
| 776 | 776 | (let ((res nil)) |
| 777 | 777 | (foreach-dentry (e (is-paramod-fetch term itable)) |
| 778 | (push e res)) | |
| 778 | (push e res)) | |
| 779 | 779 | (when (pn-flag para-from-vars) |
| 780 | 780 | (dolist (para (gethash (term-sort term) |
| 781 | *parafrom-var-rules*)) | |
| 782 | (push para res))) | |
| 781 | *parafrom-var-rules*)) | |
| 782 | (push para res))) | |
| 783 | 783 | (nreverse res))) |
| 784 | 784 | |
| 785 | 785 | (defun add-eq-literal (table lhs rhs lit) |
| 786 | 786 | (declare (type hash-table table) |
| 787 | (type term lhs rhs) | |
| 788 | (type literal lit)) | |
| 787 | (type term lhs rhs) | |
| 788 | (type literal lit)) | |
| 789 | 789 | (unless (or ;; (term-is-builtin-constant? lhs) |
| 790 | (term-is-lisp-form? lhs)) | |
| 790 | (term-is-lisp-form? lhs)) | |
| 791 | 791 | |
| 792 | 792 | (when (and (term-is-variable? lhs) |
| 793 | (not (pn-flag para-into-vars))) | |
| 793 | (not (pn-flag para-into-vars))) | |
| 794 | 794 | (return-from add-eq-literal nil)) |
| 795 | 795 | |
| 796 | 796 | (when (and (term-is-applform? lhs) |
| 797 | (pn-flag para-skip-skolem) | |
| 798 | (is-skolem (term-head lhs))) | |
| 797 | (pn-flag para-skip-skolem) | |
| 798 | (is-skolem (term-head lhs))) | |
| 799 | 799 | (return-from add-eq-literal nil)) |
| 800 | 800 | ;; |
| 801 | 801 | (let ((paramod (make-paramod :lhs lhs |
| 802 | :rhs rhs | |
| 803 | :literal lit))) | |
| 802 | :rhs rhs | |
| 803 | :literal lit))) | |
| 804 | 804 | ;; |
| 805 | 805 | #|| |
| 806 | 806 | (let ((keys (pn-const-possible-pat lhs *current-module*))) |
| 807 | (dolist (key keys) | |
| 808 | (add-to-index-table table | |
| 809 | key | |
| 810 | paramod)) | |
| 811 | ||
| 812 | t) | |
| 807 | (dolist (key keys) | |
| 808 | (add-to-index-table table | |
| 809 | key | |
| 810 | paramod)) | |
| 811 | ||
| 812 | t) | |
| 813 | 813 | ||# |
| 814 | 814 | (is-paramod-insert lhs paramod table) |
| 815 | 815 | ))) |
| 817 | 817 | #|| |
| 818 | 818 | (defun add-eq-literal-to-table (table lit) |
| 819 | 819 | (declare (type hash-table table) |
| 820 | (type literal lit)) | |
| 820 | (type literal lit)) | |
| 821 | 821 | (let* ((atom (literal-atom lit)) |
| 822 | (lhs (term-arg-1 atom)) | |
| 823 | (rhs (term-arg-2 atom))) | |
| 822 | (lhs (term-arg-1 atom)) | |
| 823 | (rhs (term-arg-2 atom))) | |
| 824 | 824 | (declare (type term atom lhs rhs)) |
| 825 | 825 | (when (or (not (pn-flag para-from-units-only)) |
| 826 | (unit-clause? (literal-clause lit))) | |
| 826 | (unit-clause? (literal-clause lit))) | |
| 827 | 827 | (when (pn-flag para-into-left) |
| 828 | (if (pn-flag para-from-left) | |
| 829 | (if (or (pn-flag para-from-vars) | |
| 830 | (not (term-is-variable? lhs))) | |
| 831 | (add-eq-literal table lhs rhs lit)) | |
| 832 | (if (pn-flag para-from-right) | |
| 833 | (if (or (pn-flag para-from-vars) | |
| 834 | (not (term-is-variable? rhs))) | |
| 835 | (add-eq-literal table rhs lhs lit)))) | |
| 836 | )))) | |
| 828 | (if (pn-flag para-from-left) | |
| 829 | (if (or (pn-flag para-from-vars) | |
| 830 | (not (term-is-variable? lhs))) | |
| 831 | (add-eq-literal table lhs rhs lit)) | |
| 832 | (if (pn-flag para-from-right) | |
| 833 | (if (or (pn-flag para-from-vars) | |
| 834 | (not (term-is-variable? rhs))) | |
| 835 | (add-eq-literal table rhs lhs lit)))) | |
| 836 | )))) | |
| 837 | 837 | ||# |
| 838 | 838 | |
| 839 | 839 | (defun add-eq-literal-to-table (table lit) |
| 840 | 840 | (declare (type hash-table table) |
| 841 | (type literal lit)) | |
| 841 | (type literal lit)) | |
| 842 | 842 | (let* ((atom (literal-atom lit)) |
| 843 | (lhs (term-arg-1 atom)) | |
| 844 | (rhs (term-arg-2 atom))) | |
| 843 | (lhs (term-arg-1 atom)) | |
| 844 | (rhs (term-arg-2 atom))) | |
| 845 | 845 | (declare (type term atom lhs rhs)) |
| 846 | 846 | (when (or (not (pn-flag para-from-units-only)) |
| 847 | (unit-clause? (literal-clause lit))) | |
| 847 | (unit-clause? (literal-clause lit))) | |
| 848 | 848 | (when (pn-flag para-from-left) |
| 849 | (if (or (pn-flag para-from-vars) | |
| 850 | (not (term-is-variable? lhs))) | |
| 851 | (add-eq-literal table lhs rhs lit))) | |
| 849 | (if (or (pn-flag para-from-vars) | |
| 850 | (not (term-is-variable? lhs))) | |
| 851 | (add-eq-literal table lhs rhs lit))) | |
| 852 | 852 | (when (pn-flag para-from-right) |
| 853 | (if (or (pn-flag para-from-vars) | |
| 854 | (not (term-is-variable? rhs))) | |
| 855 | (add-eq-literal table rhs lhs lit)))) | |
| 853 | (if (or (pn-flag para-from-vars) | |
| 854 | (not (term-is-variable? rhs))) | |
| 855 | (add-eq-literal table rhs lhs lit)))) | |
| 856 | 856 | )) |
| 857 | 857 | |
| 858 | 858 | (defun delete-eq-literal-from-table (table lit) |
| 859 | 859 | (declare (type hash-table table) |
| 860 | (type literal lit)) | |
| 860 | (type literal lit)) | |
| 861 | 861 | (let ((atom (literal-atom lit))) |
| 862 | 862 | (declare (type term atom)) |
| 863 | 863 | (let ((lhs (term-arg-1 atom)) |
| 864 | (rhs (term-arg-2 atom))) | |
| 864 | (rhs (term-arg-2 atom))) | |
| 865 | 865 | (declare (type term lhs rhs)) |
| 866 | 866 | (when (pn-flag para-into-left) |
| 867 | (delete-eq-literal-atom-from-table table lhs lit)) | |
| 867 | (delete-eq-literal-atom-from-table table lhs lit)) | |
| 868 | 868 | (when (pn-flag para-into-right) |
| 869 | (delete-eq-literal-atom-from-table table rhs lit))))) | |
| 869 | (delete-eq-literal-atom-from-table table rhs lit))))) | |
| 870 | 870 | |
| 871 | 871 | (defun delete-eq-literal-from-table-slow (table lit) |
| 872 | 872 | (declare (type hash-table table) |
| 873 | (type literal lit)) | |
| 873 | (type literal lit)) | |
| 874 | 874 | (maphash #'(lambda (key data) |
| 875 | (declare (type list data)) | |
| 876 | (setf (gethash key table) | |
| 877 | (delete-if #'(lambda (x) | |
| 878 | (eq lit (paramod-literal x))) | |
| 879 | data))) | |
| 880 | table)) | |
| 875 | (declare (type list data)) | |
| 876 | (setf (gethash key table) | |
| 877 | (delete-if #'(lambda (x) | |
| 878 | (eq lit (paramod-literal x))) | |
| 879 | data))) | |
| 880 | table)) | |
| 881 | 881 | |
| 882 | 882 | #|| |
| 883 | 883 | (defun delete-eq-literal-atom-from-table (table term lit) |
| 884 | 884 | (declare (type hash-table table) |
| 885 | (type term term) | |
| 886 | (type literal lit)) | |
| 885 | (type term term) | |
| 886 | (type literal lit)) | |
| 887 | 887 | (when (term-is-variable? term) |
| 888 | 888 | (unless (pn-flag para-into-vars) |
| 889 | 889 | (return-from delete-eq-literal-atom-from-table nil))) |
| 890 | 890 | (let ((keys (pn-const-possible-pat term *current-module*))) |
| 891 | 891 | (dolist (key keys) |
| 892 | 892 | (let ((new-data nil)) |
| 893 | (dolist (paramod (get-indexed-data table key)) | |
| 894 | (unless (eq lit (paramod-literal paramod)) | |
| 895 | (push paramod new-data))) | |
| 896 | (set-to-index-table table key new-data))) | |
| 893 | (dolist (paramod (get-indexed-data table key)) | |
| 894 | (unless (eq lit (paramod-literal paramod)) | |
| 895 | (push paramod new-data))) | |
| 896 | (set-to-index-table table key new-data))) | |
| 897 | 897 | t)) |
| 898 | 898 | ||# |
| 899 | 899 | |
| 900 | 900 | (defun delete-eq-literal-atom-from-table (table term lit) |
| 901 | 901 | (declare (type hash-table table) |
| 902 | (type term term) | |
| 903 | (type literal lit)) | |
| 902 | (type term term) | |
| 903 | (type literal lit)) | |
| 904 | 904 | (when (term-is-variable? term) |
| 905 | 905 | (unless (pn-flag para-into-vars) |
| 906 | 906 | (return-from delete-eq-literal-atom-from-table nil))) |
| 918 | 918 | (return-from index-paramodulation nil)) |
| 919 | 919 | ;; |
| 920 | 920 | (let* ((atom (literal-atom lit)) |
| 921 | (lhs (term-arg-1 atom)) | |
| 922 | (rhs (term-arg-2 atom))) | |
| 921 | (lhs (term-arg-1 atom)) | |
| 922 | (rhs (term-arg-2 atom))) | |
| 923 | 923 | (when (term-is-identical lhs rhs) |
| 924 | 924 | (return-from index-paramodulation nil)) |
| 925 | 925 | ;; |
| 926 | 926 | (add-eq-literal-to-table *paramod-rules* |
| 927 | lit))) | |
| 927 | lit))) | |
| 928 | 928 | |
| 929 | 929 | |
| 930 | 930 | ;;; UN-INDEX-PARAMODULATION : Literal |
| 937 | 937 | (unless (eq-literal? lit) |
| 938 | 938 | (return-from un-index-paramodulation nil)) |
| 939 | 939 | (let* ((atom (literal-atom lit)) |
| 940 | (lhs (term-arg-1 atom)) | |
| 941 | (rhs (term-arg-2 atom))) | |
| 940 | (lhs (term-arg-1 atom)) | |
| 941 | (rhs (term-arg-2 atom))) | |
| 942 | 942 | (declare (type term atom lhs rhs)) |
| 943 | 943 | (when (term-is-identical lhs rhs) |
| 944 | 944 | (return-from un-index-paramodulation nil)) |
| 952 | 952 | (return-from un-index-paramodulation-slow nil)) |
| 953 | 953 | ;; (delete-eq-literal-from-table-slow *paramod-rules* lit) |
| 954 | 954 | (let* ((atom (literal-atom lit)) |
| 955 | (lhs (term-arg-1 atom)) | |
| 956 | (rhs (term-arg-2 atom))) | |
| 955 | (lhs (term-arg-1 atom)) | |
| 956 | (rhs (term-arg-2 atom))) | |
| 957 | 957 | (declare (type term atom lhs rhs)) |
| 958 | 958 | (when (term-is-identical lhs rhs) |
| 959 | (return-from un-index-paramodulation-slow nil)) | |
| 959 | (return-from un-index-paramodulation-slow nil)) | |
| 960 | 960 | (delete-eq-literal-from-table *paramod-rules* lit)) |
| 961 | 961 | ) |
| 962 | 962 | |
| 967 | 967 | (defun get-all-demodulators (hash &optional sort) |
| 968 | 968 | (declare (type hash-table hash)) |
| 969 | 969 | (flet ((!clause-id (cl) |
| 970 | (if (clause-p cl) | |
| 971 | (clause-id cl) | |
| 972 | 0))) | |
| 970 | (if (clause-p cl) | |
| 971 | (clause-id cl) | |
| 972 | 0))) | |
| 973 | 973 | (let ((res nil)) |
| 974 | 974 | (declare (type list res)) |
| 975 | 975 | (maphash #'(lambda (key demod) |
| 976 | (declare (ignore key)) | |
| 977 | (dolist (d demod) | |
| 978 | (pushnew d res :test #'eq))) | |
| 979 | hash) | |
| 976 | (declare (ignore key)) | |
| 977 | (dolist (d demod) | |
| 978 | (pushnew d res :test #'eq))) | |
| 979 | hash) | |
| 980 | 980 | (if sort |
| 981 | (sort res #'(lambda (x y) (< (!clause-id (demod-clause x)) | |
| 982 | (!clause-id (demod-clause y))))) | |
| 983 | res)))) | |
| 981 | (sort res #'(lambda (x y) (< (!clause-id (demod-clause x)) | |
| 982 | (!clause-id (demod-clause y))))) | |
| 983 | res)))) | |
| 984 | 984 | |
| 985 | 985 | (defun un-index-demodulator (clause) |
| 986 | 986 | (declare (type clause clause)) |
| 987 | 987 | (let ((xdeleted nil)) |
| 988 | 988 | (maphash #'(lambda (key demods) |
| 989 | (let ((new-ent nil) | |
| 990 | (deleted nil)) | |
| 991 | (dolist (demod demods) | |
| 992 | (declare (type demod demod)) | |
| 993 | (if (eq (demod-clause demod) clause) | |
| 994 | (setq deleted t) | |
| 995 | (push demod new-ent))) | |
| 996 | (when deleted | |
| 997 | (setq xdeleted t) | |
| 998 | (setf (gethash key *demodulators*) new-ent)))) | |
| 999 | *demodulators*) | |
| 989 | (let ((new-ent nil) | |
| 990 | (deleted nil)) | |
| 991 | (dolist (demod demods) | |
| 992 | (declare (type demod demod)) | |
| 993 | (if (eq (demod-clause demod) clause) | |
| 994 | (setq deleted t) | |
| 995 | (push demod new-ent))) | |
| 996 | (when deleted | |
| 997 | (setq xdeleted t) | |
| 998 | (setf (gethash key *demodulators*) new-ent)))) | |
| 999 | *demodulators*) | |
| 1000 | 1000 | (when xdeleted |
| 1001 | 1001 | (decf (pn-stat demodulators-size))) |
| 1002 | 1002 | )) |
| 1009 | 1009 | ;;; |
| 1010 | 1010 | (defun table-to-clause-list (db) |
| 1011 | 1011 | (declare (type hash-table db) |
| 1012 | (values list)) | |
| 1012 | (values list)) | |
| 1013 | 1013 | (let ((clauses nil)) |
| 1014 | 1014 | (maphash #'(lambda (x y) |
| 1015 | (declare (ignore x)) | |
| 1016 | (dolist (data y) | |
| 1017 | (let ((lit (literal-entry-literal data))) | |
| 1018 | (declare (type literal lit)) | |
| 1019 | (pushnew (literal-clause lit) clauses :test #'eq)))) | |
| 1020 | db) | |
| 1015 | (declare (ignore x)) | |
| 1016 | (dolist (data y) | |
| 1017 | (let ((lit (literal-entry-literal data))) | |
| 1018 | (declare (type literal lit)) | |
| 1019 | (pushnew (literal-clause lit) clauses :test #'eq)))) | |
| 1020 | db) | |
| 1021 | 1021 | clauses)) |
| 1022 | 1022 | |
| 1023 | 1023 | ;;; TABLE-TO-LITERAL-LIST |
| 1024 | 1024 | ;;; |
| 1025 | 1025 | (defun table-to-literal-list (db) |
| 1026 | 1026 | (declare (type hash-table db) |
| 1027 | (values list)) | |
| 1027 | (values list)) | |
| 1028 | 1028 | (let ((lits nil)) |
| 1029 | 1029 | (declare (type list lits)) |
| 1030 | 1030 | (maphash #'(lambda (x y) |
| 1031 | (declare (ignore x)) | |
| 1032 | (dolist (data y) | |
| 1033 | (pushnew (literal-entry-literal data) lits | |
| 1034 | :test #'eq))) | |
| 1035 | db) | |
| 1031 | (declare (ignore x)) | |
| 1032 | (dolist (data y) | |
| 1033 | (pushnew (literal-entry-literal data) lits | |
| 1034 | :test #'eq))) | |
| 1035 | db) | |
| 1036 | 1036 | lits)) |
| 1037 | 1037 | |
| 1038 | 1038 | ;;; GET-CLAUSES-FROM-TABLE |
| 1040 | 1040 | |
| 1041 | 1041 | (defun get-clashable-clauses-from-literal (db literal &optional (opt nil)) |
| 1042 | 1042 | (declare (type hash-table db) |
| 1043 | (type literal literal) | |
| 1044 | (ignore opt) | |
| 1045 | (values list)) | |
| 1043 | (type literal literal) | |
| 1044 | (ignore opt) | |
| 1045 | (values list)) | |
| 1046 | 1046 | (let ((res nil) |
| 1047 | (atom (literal-atom literal)) | |
| 1048 | ) | |
| 1047 | (atom (literal-atom literal)) | |
| 1048 | ) | |
| 1049 | 1049 | (declare (type list res) |
| 1050 | (type term atom)) | |
| 1050 | (type term atom)) | |
| 1051 | 1051 | ;; |
| 1052 | 1052 | (dolist (litent (is-fetch atom db)) |
| 1053 | 1053 | (dolist (lit litent) |
| 1054 | (pushnew (literal-clause lit) | |
| 1055 | res | |
| 1056 | :test #'eq))) | |
| 1054 | (pushnew (literal-clause lit) | |
| 1055 | res | |
| 1056 | :test #'eq))) | |
| 1057 | 1057 | ;; (setq res (delete-duplicates (mapcar #'literal-clause |
| 1058 | ;; (is-fetch-all atom db)))) | |
| 1058 | ;; (is-fetch-all atom db)))) | |
| 1059 | 1059 | ;; |
| 1060 | 1060 | #|| |
| 1061 | 1061 | (with-output-simple-msg () |
| 1072 | 1072 | ;;; |
| 1073 | 1073 | (defun get-clashable-clauses-from-atom (db atom &optional (opt nil)) |
| 1074 | 1074 | (declare (type hash-table db) |
| 1075 | (type term atom) | |
| 1076 | (values list)) | |
| 1075 | (type term atom) | |
| 1076 | (values list)) | |
| 1077 | 1077 | (let ((res nil) |
| 1078 | (key (if (and opt (eq (term-head atom) *fopl-eq*)) | |
| 1079 | (or (and (not (term-is-variable? (term-arg-1 atom))) | |
| 1080 | (term-arg-1 atom)) | |
| 1081 | (and (not (term-is-variable? (term-arg-2 atom))) | |
| 1082 | (term-arg-2 atom)) | |
| 1083 | atom) | |
| 1084 | atom))) | |
| 1078 | (key (if (and opt (eq (term-head atom) *fopl-eq*)) | |
| 1079 | (or (and (not (term-is-variable? (term-arg-1 atom))) | |
| 1080 | (term-arg-1 atom)) | |
| 1081 | (and (not (term-is-variable? (term-arg-2 atom))) | |
| 1082 | (term-arg-2 atom)) | |
| 1083 | atom) | |
| 1084 | atom))) | |
| 1085 | 1085 | (declare (type list res) |
| 1086 | (type term key)) | |
| 1086 | (type term key)) | |
| 1087 | 1087 | (dolist (data (get-literal-entry-from-atom db key)) |
| 1088 | 1088 | (pushnew (literal-clause (the literal (literal-entry-literal data))) |
| 1089 | res | |
| 1090 | :test #'eq)) | |
| 1089 | res | |
| 1090 | :test #'eq)) | |
| 1091 | 1091 | res)) |
| 1092 | 1092 | |
| 1093 | 1093 | ;;; EOF |
| 0 | 0 | ;;;-*-Mode:LISP; Package: CHAOS; Base:10; Syntax:Common-lisp -*- |
| 1 | 1 | ;;; |
| 2 | ;;; Copyright (c) 2000-2014, Toshimi Sawada. All rights reserved. | |
| 2 | ;;; Copyright (c) 2000-2015, Toshimi Sawada. All rights reserved. | |
| 3 | 3 | ;;; |
| 4 | 4 | ;;; Redistribution and use in source and binary forms, with or without |
| 5 | 5 | ;;; modification, are permitted provided that the following conditions |
| 28 | 28 | ;;; |
| 29 | 29 | (in-package :chaos) |
| 30 | 30 | #|============================================================================= |
| 31 | System:Chaos | |
| 32 | Module:BigPink | |
| 33 | File:infer.lisp | |
| 31 | System:Chaos | |
| 32 | Module:BigPink | |
| 33 | File:infer.lisp | |
| 34 | 34 | =============================================================================|# |
| 35 | 35 | #-:chaos-debug |
| 36 | 36 | (declaim (optimize (speed 3) (safety 0) #-GCL (debug 0))) |
| 38 | 38 | (declaim (optimize (speed 1) (safety 3) #-GCL (debug 3))) |
| 39 | 39 | |
| 40 | 40 | ;;; ****************** |
| 41 | ;;; Inference Engine | |
| 41 | ;;; Inference Engine | |
| 42 | 42 | ;;; ****************** |
| 43 | 43 | |
| 44 | 44 | ;;; ========== |
| 53 | 53 | ;; perform db reset in automatic mode. |
| 54 | 54 | (unless *pn-no-db-reset* |
| 55 | 55 | (if (or (pn-flag auto) |
| 56 | (pn-flag auto1) | |
| 57 | (pn-flag auto2) | |
| 58 | (pn-flag auto3)) | |
| 59 | (progn | |
| 60 | (clear-all-index-tables) | |
| 61 | (reset-module-proof-system mod)) | |
| 62 | ;; | |
| 63 | (unless (module-proof-system mod) | |
| 64 | (auto-db-reset mod)) | |
| 65 | )) | |
| 56 | (pn-flag auto1) | |
| 57 | (pn-flag auto2) | |
| 58 | (pn-flag auto3)) | |
| 59 | (progn | |
| 60 | (clear-all-index-tables) | |
| 61 | (reset-module-proof-system mod)) | |
| 62 | ;; | |
| 63 | (unless (module-proof-system mod) | |
| 64 | (auto-db-reset mod)) | |
| 65 | )) | |
| 66 | 66 | ;; |
| 67 | 67 | (with-proof-context (mod) |
| 68 | 68 | (let ((ex-code nil)) |
| 69 | (declare (type symbol ex-code)) | |
| 70 | (setq ex-code | |
| 71 | (catch :exit-inference | |
| 72 | ;; ----------- | |
| 73 | ;; preparation | |
| 74 | ;; ----------- | |
| 75 | (prepare-inference mod) | |
| 76 | (setq status (check-pn-stop)) | |
| 77 | (if (eq status :keep-searching) | |
| 78 | (setq *given-clause* (extract-given-clause)) | |
| 79 | (setq *given-clause* nil)) | |
| 80 | ;; --------------- | |
| 81 | ;; start main loop | |
| 82 | ;; --------------- | |
| 83 | (when (pn-flag print-message) | |
| 84 | (format t "~% ~%** Starting PigNose _____________________~% ~%") | |
| 85 | ) | |
| 86 | (loop | |
| 87 | (unless (and *given-clause* | |
| 88 | (eq status :keep-searching)) | |
| 89 | (return)) | |
| 90 | ;; | |
| 91 | (incf (pn-stat cl-given)) | |
| 92 | (when (pn-flag print-given) | |
| 93 | (with-output-simple-msg () | |
| 94 | (format t "#~d(weight=~d):" | |
| 95 | (pn-stat cl-given) | |
| 96 | (clause-pick-weight *given-clause*)) | |
| 97 | (print-next) | |
| 98 | (print-clause *given-clause* *standard-output*)) | |
| 99 | ) | |
| 100 | ;; | |
| 101 | (index-clash-literals *given-clause*) | |
| 102 | (append-clause :usable *given-clause*) | |
| 103 | ||
| 104 | ;; ************ | |
| 105 | ;; DO INFERENCE | |
| 106 | ;; ************ | |
| 107 | (setq *new-demodulator* nil) | |
| 108 | (infer *given-clause*) | |
| 109 | ;; | |
| 110 | #|| | |
| 111 | (when (and (< 0 (pn-parameter interrupt-given)) | |
| 112 | (= 0 (mod (pn-stat cl-given) | |
| 113 | (pn-parameter interrupt-given)))) | |
| 114 | (when (pn-flag print-message) | |
| 115 | (with-output-msg () | |
| 116 | (format t "~d clauses have been given." | |
| 117 | (pn-stat cl-given)))) | |
| 118 | ;; todo | |
| 119 | (pn-interact)) | |
| 120 | ||# | |
| 121 | ;; | |
| 122 | (setq status (check-pn-stop)) | |
| 123 | ;; | |
| 124 | (when (eq status :keep-searching) | |
| 125 | (when (= (pn-parameter change-limit-after) | |
| 126 | (pn-stat cl-given)) | |
| 127 | (let ((new-limit (pn-parameter new-max-weight))) | |
| 128 | (setf (pn-parameter max-weight) new-limit) | |
| 129 | (when (pn-flag print-message) | |
| 130 | (with-output-msg () | |
| 131 | (format t "reducing weight limit to ~d" new-limit))))) | |
| 132 | ;; get next clause | |
| 133 | (setq *given-clause* (extract-given-clause)) | |
| 134 | ) | |
| 135 | ;; | |
| 136 | #|| report : not yet | |
| 137 | (when (and (eq status :keep-searching) | |
| 138 | *given-clause* | |
| 139 | (< 0 (pn-parameter report))) | |
| 140 | ;; TODO | |
| 141 | ;; (pn-report) | |
| 142 | ) | |
| 143 | (when (pn-flag print-message) | |
| 144 | (print-in-progress ".")) | |
| 145 | ||# | |
| 146 | ) | |
| 147 | ||
| 148 | ;; ------------------ | |
| 149 | ;; loop ends | |
| 150 | ;; report the result | |
| 151 | ;; ------------------ | |
| 152 | (cond ((eq status :keep-searching) | |
| 153 | (setq status :sos-empty-exit) | |
| 154 | (when (pn-flag print-stats) | |
| 155 | (format t "~%** Search stopped because SOS is empty.~% ~%"))) | |
| 156 | (t (let ((reason nil)) | |
| 157 | (case status | |
| 158 | (:max-given-exit (setq reason "max-given")) | |
| 159 | (:max-gen-exit (setq reason "max-gen")) | |
| 160 | (:max-kept-exit (setq reason "max-kept")) | |
| 161 | (:max-seconds-exit (setq reason "max-seconds")) | |
| 162 | (otherwise (setq reason "???"))) | |
| 163 | (when (pn-flag print-stats) | |
| 164 | (format t "~%** Search stopped due to ~a option.~% ~%" | |
| 165 | reason)) | |
| 166 | )) | |
| 167 | ) | |
| 168 | ;; | |
| 169 | (infer-clean-up) | |
| 170 | status)) | |
| 171 | ;; | |
| 172 | (when .debug-pn-memory. | |
| 173 | (report-pn-memory)) | |
| 174 | ;; | |
| 175 | (if ex-code | |
| 176 | ex-code | |
| 177 | status))) | |
| 69 | (declare (type symbol ex-code)) | |
| 70 | (setq ex-code | |
| 71 | (catch :exit-inference | |
| 72 | ;; ----------- | |
| 73 | ;; preparation | |
| 74 | ;; ----------- | |
| 75 | (prepare-inference mod) | |
| 76 | (setq status (check-pn-stop)) | |
| 77 | (if (eq status :keep-searching) | |
| 78 | (setq *given-clause* (extract-given-clause)) | |
| 79 | (setq *given-clause* nil)) | |
| 80 | ;; --------------- | |
| 81 | ;; start main loop | |
| 82 | ;; --------------- | |
| 83 | (when (pn-flag print-message) | |
| 84 | (format t "~% ~%** Starting PigNose _____________________~% ~%") | |
| 85 | ) | |
| 86 | (loop | |
| 87 | (unless (and *given-clause* | |
| 88 | (eq status :keep-searching)) | |
| 89 | (return)) | |
| 90 | ;; | |
| 91 | (incf (pn-stat cl-given)) | |
| 92 | (when (pn-flag print-given) | |
| 93 | (with-output-simple-msg () | |
| 94 | (format t "#~d(weight=~d):" | |
| 95 | (pn-stat cl-given) | |
| 96 | (clause-pick-weight *given-clause*)) | |
| 97 | (print-next) | |
| 98 | (print-clause *given-clause* *standard-output*)) | |
| 99 | ) | |
| 100 | ;; | |
| 101 | (index-clash-literals *given-clause*) | |
| 102 | (append-clause :usable *given-clause*) | |
| 103 | ||
| 104 | ;; ************ | |
| 105 | ;; DO INFERENCE | |
| 106 | ;; ************ | |
| 107 | (setq *new-demodulator* nil) | |
| 108 | (infer *given-clause*) | |
| 109 | ;; | |
| 110 | #|| | |
| 111 | (when (and (< 0 (pn-parameter interrupt-given)) | |
| 112 | (= 0 (mod (pn-stat cl-given) | |
| 113 | (pn-parameter interrupt-given)))) | |
| 114 | (when (pn-flag print-message) | |
| 115 | (with-output-msg () | |
| 116 | (format t "~d clauses have been given." | |
| 117 | (pn-stat cl-given)))) | |
| 118 | ;; todo | |
| 119 | (pn-interact)) | |
| 120 | ||# | |
| 121 | ;; | |
| 122 | (setq status (check-pn-stop)) | |
| 123 | ;; | |
| 124 | (when (eq status :keep-searching) | |
| 125 | (when (= (pn-parameter change-limit-after) | |
| 126 | (pn-stat cl-given)) | |
| 127 | (let ((new-limit (pn-parameter new-max-weight))) | |
| 128 | (setf (pn-parameter max-weight) new-limit) | |
| 129 | (when (pn-flag print-message) | |
| 130 | (with-output-msg () | |
| 131 | (format t "reducing weight limit to ~d" new-limit))))) | |
| 132 | ;; get next clause | |
| 133 | (setq *given-clause* (extract-given-clause)) | |
| 134 | ) | |
| 135 | ;; | |
| 136 | #|| report : not yet | |
| 137 | (when (and (eq status :keep-searching) | |
| 138 | *given-clause* | |
| 139 | (< 0 (pn-parameter report))) | |
| 140 | ;; TODO | |
| 141 | ;; (pn-report) | |
| 142 | ) | |
| 143 | (when (pn-flag print-message) | |
| 144 | (print-in-progress ".")) | |
| 145 | ||# | |
| 146 | ) | |
| 147 | ||
| 148 | ;; ------------------ | |
| 149 | ;; loop ends | |
| 150 | ;; report the result | |
| 151 | ;; ------------------ | |
| 152 | (cond ((eq status :keep-searching) | |
| 153 | (setq status :sos-empty-exit) | |
| 154 | (when (pn-flag print-stats) | |
| 155 | (format t "~%** Search stopped because SOS is empty.~% ~%"))) | |
| 156 | (t (let ((reason nil)) | |
| 157 | (case status | |
| 158 | (:max-given-exit (setq reason "max-given")) | |
| 159 | (:max-gen-exit (setq reason "max-gen")) | |
| 160 | (:max-kept-exit (setq reason "max-kept")) | |
| 161 | (:max-seconds-exit (setq reason "max-seconds")) | |
| 162 | (otherwise (setq reason "???"))) | |
| 163 | (when (pn-flag print-stats) | |
| 164 | (format t "~%** Search stopped due to ~a option.~% ~%" | |
| 165 | reason)) | |
| 166 | )) | |
| 167 | ) | |
| 168 | ;; | |
| 169 | (infer-clean-up) | |
| 170 | status)) | |
| 171 | ;; | |
| 172 | (when .debug-pn-memory. | |
| 173 | (report-pn-memory)) | |
| 174 | ;; | |
| 175 | (if ex-code | |
| 176 | ex-code | |
| 177 | status))) | |
| 178 | 178 | )) |
| 179 | 179 | |
| 180 | 180 | (defun pn-interact () |
| 196 | 196 | (declare (type fixnum clause-id)) |
| 197 | 197 | (let ((clause (get-clause clause-id (psystem-clause-hash *current-psys*)))) |
| 198 | 198 | (and clause |
| 199 | (clause-container clause)))) | |
| 199 | (clause-container clause)))) | |
| 200 | 200 | |
| 201 | 201 | (defun infer (clause) |
| 202 | 202 | (declare (type clause clause)) |
| 203 | (let ((gen-cls nil) ; clauses generated | |
| 204 | (cl-id (clause-id clause)) ; identifier of given clause | |
| 205 | ) | |
| 203 | (let ((gen-cls nil) ; clauses generated | |
| 204 | (cl-id (clause-id clause)) ; identifier of given clause | |
| 205 | ) | |
| 206 | 206 | (declare (type list gen-cls) |
| 207 | (type fixnum cl-id)) | |
| 207 | (type fixnum cl-id)) | |
| 208 | 208 | ;; |
| 209 | 209 | ;; adjust max-weight |
| 210 | 210 | ;; |
| 215 | 215 | ;; binary resolution |
| 216 | 216 | ;; |
| 217 | 217 | (when (and (pn-flag binary-res) |
| 218 | (given-clause-ok cl-id)) | |
| 218 | (given-clause-ok cl-id)) | |
| 219 | 219 | (setq gen-cls |
| 220 | (binary-resolution clause)) ; inference rule appends newly | |
| 221 | ; kept clauses to *SOS* also. | |
| 220 | (binary-resolution clause)) ; inference rule appends newly | |
| 221 | ; kept clauses to *SOS* also. | |
| 222 | 222 | ;; post-process new clases in *SOS* |
| 223 | 223 | ;; - may append even more clauses to *SOS*. |
| 224 | 224 | (when gen-cls |
| 225 | (post-proc-all gen-cls nil :sos)) | |
| 225 | (post-proc-all gen-cls nil :sos)) | |
| 226 | 226 | ) |
| 227 | 227 | |
| 228 | 228 | ;; special treatment for propoitional literals |
| 229 | 229 | (when (and (not (pn-flag binary-res)) |
| 230 | (pn-flag prop-res)) | |
| 230 | (pn-flag prop-res)) | |
| 231 | 231 | (let ((do-prop-resolve nil)) |
| 232 | (setq do-prop-resolve | |
| 233 | (or (pn-flag hyper-res) | |
| 234 | (pn-flag neg-hyper-res))) | |
| 235 | #|| | |
| 236 | (setq do-prop-resolve | |
| 237 | (or (and (pn-flag hyper-res) | |
| 238 | (not (positive-clause? clause))) | |
| 239 | (and (pn-flag neg-hyper-res) | |
| 240 | (not (negative-clause? clause))))) | |
| 241 | ||# | |
| 242 | (when do-prop-resolve | |
| 243 | (setq gen-cls (binary-resolution clause :propositional-only))) | |
| 244 | (when gen-cls | |
| 245 | (post-proc-all gen-cls nil :sos))) | |
| 232 | (setq do-prop-resolve | |
| 233 | (or (pn-flag hyper-res) | |
| 234 | (pn-flag neg-hyper-res))) | |
| 235 | #|| | |
| 236 | (setq do-prop-resolve | |
| 237 | (or (and (pn-flag hyper-res) | |
| 238 | (not (positive-clause? clause))) | |
| 239 | (and (pn-flag neg-hyper-res) | |
| 240 | (not (negative-clause? clause))))) | |
| 241 | ||# | |
| 242 | (when do-prop-resolve | |
| 243 | (setq gen-cls (binary-resolution clause :propositional-only))) | |
| 244 | (when gen-cls | |
| 245 | (post-proc-all gen-cls nil :sos))) | |
| 246 | 246 | ) |
| 247 | ||
| 247 | ||
| 248 | 248 | ;; for subsequent inference rules, check the given clause has |
| 249 | 249 | ;; not back demodulated or back subsumed..................... |
| 250 | 250 | |
| 252 | 252 | ;; hyper resolution |
| 253 | 253 | ;; |
| 254 | 254 | (when (and (pn-flag hyper-res) |
| 255 | (given-clause-ok cl-id)) | |
| 255 | (given-clause-ok cl-id)) | |
| 256 | 256 | (setq gen-cls (hyper-resolution clause)) |
| 257 | 257 | (when gen-cls |
| 258 | (post-proc-all gen-cls nil :sos))) | |
| 258 | (post-proc-all gen-cls nil :sos))) | |
| 259 | 259 | |
| 260 | 260 | ;; |
| 261 | 261 | ;; negative hyper resolution |
| 262 | 262 | ;; |
| 263 | 263 | (when (and (pn-flag neg-hyper-res) |
| 264 | (given-clause-ok cl-id)) | |
| 264 | (given-clause-ok cl-id)) | |
| 265 | 265 | (setq gen-cls |
| 266 | (neg-hyper-resolution clause)) | |
| 266 | (neg-hyper-resolution clause)) | |
| 267 | 267 | (when gen-cls |
| 268 | (post-proc-all gen-cls nil :sos))) | |
| 268 | (post-proc-all gen-cls nil :sos))) | |
| 269 | 269 | |
| 270 | 270 | ;; |
| 271 | 271 | ;; ur(unit resulting) resolution |
| 272 | 272 | ;; |
| 273 | 273 | (when (and (pn-flag ur-res) |
| 274 | (given-clause-ok cl-id)) | |
| 274 | (given-clause-ok cl-id)) | |
| 275 | 275 | (setq gen-cls |
| 276 | (ur-resolution clause)) | |
| 276 | (ur-resolution clause)) | |
| 277 | 277 | (when gen-cls |
| 278 | (post-proc-all gen-cls nil :sos))) | |
| 278 | (post-proc-all gen-cls nil :sos))) | |
| 279 | 279 | |
| 280 | 280 | ;; paramudulations: |
| 281 | 281 | ;; paramodulation-into |
| 282 | 282 | |
| 283 | 283 | (when (and (pn-flag para-into) |
| 284 | (given-clause-ok cl-id)) | |
| 284 | (given-clause-ok cl-id)) | |
| 285 | 285 | (setq gen-cls |
| 286 | (paramodulation-into clause)) | |
| 286 | (paramodulation-into clause)) | |
| 287 | 287 | (when gen-cls |
| 288 | (post-proc-all gen-cls nil :sos))) | |
| 288 | (post-proc-all gen-cls nil :sos))) | |
| 289 | 289 | |
| 290 | 290 | ;; paramodulation-from |
| 291 | 291 | |
| 292 | 292 | (when (and (pn-flag para-from) |
| 293 | (given-clause-ok cl-id)) | |
| 293 | (given-clause-ok cl-id)) | |
| 294 | 294 | (setq gen-cls |
| 295 | (paramodulation-from clause)) | |
| 295 | (paramodulation-from clause)) | |
| 296 | 296 | (when gen-cls |
| 297 | (post-proc-all gen-cls nil :sos))) | |
| 297 | (post-proc-all gen-cls nil :sos))) | |
| 298 | 298 | |
| 299 | 299 | ;; finally, the demodulation process |
| 300 | 300 | |
| 301 | 301 | (when (and (pn-flag demod-inf) |
| 302 | (given-clause-ok cl-id)) | |
| 302 | (given-clause-ok cl-id)) | |
| 303 | 303 | (let ((c nil)) |
| 304 | (declare (type (or null clause) c)) | |
| 305 | (setq c (copy-clause clause)) | |
| 306 | ;; (register-clause c *current-psys*) | |
| 307 | (incf (pn-stat cl-generated)) | |
| 308 | (incf (pn-stat demod-inf-gen)) | |
| 309 | (setf (clause-parents (the clause c)) | |
| 310 | (list (list (clause-id clause)))) | |
| 311 | (when (pre-process c nil :sos) | |
| 312 | (post-proc-all (list c) nil :sos)))) | |
| 304 | (declare (type (or null clause) c)) | |
| 305 | (setq c (copy-clause clause)) | |
| 306 | ;; (register-clause c *current-psys*) | |
| 307 | (incf (pn-stat cl-generated)) | |
| 308 | (incf (pn-stat demod-inf-gen)) | |
| 309 | (setf (clause-parents (the clause c)) | |
| 310 | (list (list (clause-id clause)))) | |
| 311 | (when (pre-process c nil :sos) | |
| 312 | (post-proc-all (list c) nil :sos)))) | |
| 313 | 313 | )) |
| 314 | 314 | |
| 315 | 315 | ;;; POST-PROCESS sos-pointer input lst |
| 324 | 324 | ;;; |
| 325 | 325 | (defun post-process (clause input list) |
| 326 | 326 | (declare (type clause clause) |
| 327 | (type symbol list)) | |
| 327 | (type symbol list)) | |
| 328 | 328 | (when (and (pn-flag eq-units-both-ways) |
| 329 | (unit-clause? clause)) | |
| 329 | (unit-clause? clause)) | |
| 330 | 330 | ;; generate a flipped copy if |
| 331 | 331 | ;; 1. it's a (pos or neg) eq unit, and |
| 332 | 332 | ;; 2. either |
| 336 | 336 | (let ((lit (ith-literal clause 1))) |
| 337 | 337 | (declare (type literal lit)) |
| 338 | 338 | (when (and (eq-literal? lit) |
| 339 | (or (not (pn-flag order-eq)) | |
| 340 | (not (test-bit (literal-stat-bits lit) | |
| 341 | oriented-eq-bit)))) | |
| 342 | (let ((c2 (copy-clause clause))) | |
| 343 | (declare (type clause c2)) | |
| 344 | ;; (register-clause c2 *current-psys*) | |
| 345 | ;; (break "a!") | |
| 346 | (setf (clause-parents c2) | |
| 347 | (list (list :copy-rule (clause-id clause) | |
| 348 | :flip-eq-rule | |
| 349 | ))) | |
| 350 | (setq lit (ith-literal c2 1)) | |
| 351 | (let* ((atom (literal-atom lit)) | |
| 352 | (new-atom (make-term-with-sort-check *fopl-eq* | |
| 353 | (list (term-arg-2 atom) | |
| 354 | (term-arg-1 atom))))) | |
| 355 | (setf (literal-atom lit) new-atom)) | |
| 356 | ;; | |
| 357 | (pre-process c2 input list) | |
| 358 | )) | |
| 339 | (or (not (pn-flag order-eq)) | |
| 340 | (not (test-bit (literal-stat-bits lit) | |
| 341 | oriented-eq-bit)))) | |
| 342 | (let ((c2 (copy-clause clause))) | |
| 343 | (declare (type clause c2)) | |
| 344 | ;; (register-clause c2 *current-psys*) | |
| 345 | ;; (break "a!") | |
| 346 | (setf (clause-parents c2) | |
| 347 | (list (list :copy-rule (clause-id clause) | |
| 348 | :flip-eq-rule | |
| 349 | ))) | |
| 350 | (setq lit (ith-literal c2 1)) | |
| 351 | (let* ((atom (literal-atom lit)) | |
| 352 | (new-atom (make-term-with-sort-check *fopl-eq* | |
| 353 | (list (term-arg-2 atom) | |
| 354 | (term-arg-1 atom))))) | |
| 355 | (setf (literal-atom lit) new-atom)) | |
| 356 | ;; | |
| 357 | (pre-process c2 input list) | |
| 358 | )) | |
| 359 | 359 | )) |
| 360 | 360 | |
| 361 | 361 | ;; Back DEMODULATION |
| 362 | 362 | (when (or (not (pn-flag no-new-demod)) |
| 363 | input) | |
| 363 | input) | |
| 364 | 364 | (when (and (pn-flag back-demod) |
| 365 | (unit-clause? clause)) | |
| 365 | (unit-clause? clause)) | |
| 366 | 366 | (when (assq clause *new-demodulator*) |
| 367 | (unless (pn-flag quiet) | |
| 368 | (when (or input (pn-flag print-back-demod)) | |
| 369 | (with-output-simple-msg () | |
| 370 | (format t "* starting back demodulation with ~d." | |
| 371 | (clause-id clause)))))) | |
| 367 | (unless (pn-flag quiet) | |
| 368 | (when (or input (pn-flag print-back-demod)) | |
| 369 | (with-output-simple-msg () | |
| 370 | (format t "* starting back demodulation with ~d." | |
| 371 | (clause-id clause)))))) | |
| 372 | 372 | (back-demodulate *new-demodulator* clause input list) |
| 373 | 373 | ) |
| 374 | 374 | ) |
| 378 | 378 | (when (pn-flag back-sub) |
| 379 | 379 | (let ((cp (back-subsume clause))) |
| 380 | 380 | (dolist (e cp) |
| 381 | (declare (type clause e)) | |
| 382 | (incf (pn-stat cl-back-sub)) | |
| 383 | (unless (pn-flag quiet) | |
| 384 | (when (or input (pn-flag print-back-sub)) | |
| 385 | (with-output-msg () | |
| 386 | (format t "~d backsubsumes ~d." | |
| 387 | (clause-id clause) | |
| 388 | (clause-id e)) | |
| 389 | ;; | |
| 390 | ;; (print-next) | |
| 391 | ;; (print-clause e) | |
| 392 | ;; | |
| 393 | ) | |
| 394 | )) | |
| 395 | ;; | |
| 396 | (clause-full-un-index e) | |
| 397 | ))) | |
| 381 | (declare (type clause e)) | |
| 382 | (incf (pn-stat cl-back-sub)) | |
| 383 | (unless (pn-flag quiet) | |
| 384 | (when (or input (pn-flag print-back-sub)) | |
| 385 | (with-output-msg () | |
| 386 | (format t "~d backsubsumes ~d." | |
| 387 | (clause-id clause) | |
| 388 | (clause-id e)) | |
| 389 | ;; | |
| 390 | ;; (print-next) | |
| 391 | ;; (print-clause e) | |
| 392 | ;; | |
| 393 | ) | |
| 394 | )) | |
| 395 | ;; | |
| 396 | (clause-full-un-index e) | |
| 397 | ))) | |
| 398 | 398 | |
| 399 | 399 | ;; FACTORING |
| 400 | 400 | |
| 405 | 405 | ;; BACK UNIT DELETION |
| 406 | 406 | |
| 407 | 407 | (when (and (pn-flag back-unit-deletion) |
| 408 | (unit-clause? clause)) | |
| 408 | (unit-clause? clause)) | |
| 409 | 409 | (unless (pn-flag quiet) |
| 410 | 410 | (when (or (pn-flag print-back-demod) |
| 411 | input) | |
| 412 | (with-output-simple-msg () | |
| 413 | (format t "* starting back unit deletion with ~d." | |
| 414 | (clause-id clause))))) | |
| 411 | input) | |
| 412 | (with-output-simple-msg () | |
| 413 | (format t "* starting back unit deletion with ~d." | |
| 414 | (clause-id clause))))) | |
| 415 | 415 | (back-unit-deletion clause input) |
| 416 | 416 | ) |
| 417 | 417 | ;; |
| 422 | 422 | ;;; |
| 423 | 423 | (defun post-proc-all (clauses input clause-list-marker) |
| 424 | 424 | (declare (type list clauses) |
| 425 | (type symbol clause-list-marker)) | |
| 425 | (type symbol clause-list-marker)) | |
| 426 | 426 | (when (pn-flag debug-infer) |
| 427 | 427 | (with-output-msg () |
| 428 | 428 | (princ "start[post-proc-all]:") |
| 429 | 429 | (pr-clause-list clauses t))) |
| 430 | 430 | (unless clauses |
| 431 | 431 | (if (eq clause-list-marker :sos) |
| 432 | (setq clauses *sos*) | |
| 432 | (setq clauses *sos*) | |
| 433 | 433 | (if (eq clause-list-marker :usable) |
| 434 | (setq clauses *usable*)))) | |
| 434 | (setq clauses *usable*)))) | |
| 435 | 435 | (dolist (c clauses) |
| 436 | 436 | (post-process c input clause-list-marker)) |
| 437 | 437 | ;; |
| 450 | 450 | ;;; |
| 451 | 451 | (defun pre-process (clause input list &optional dont-delete) |
| 452 | 452 | (declare (type clause clause) |
| 453 | (type symbol list)) | |
| 453 | (type symbol list)) | |
| 454 | 454 | (when (pn-flag debug-infer) |
| 455 | 455 | (with-output-msg () |
| 456 | 456 | (format t "start[pre-process]") |
| 461 | 461 | ||# |
| 462 | 462 | ;; |
| 463 | 463 | (let ((original-input (if (clause-parents clause) |
| 464 | nil | |
| 465 | (copy-clause clause))) | |
| 466 | (gen-result nil)) | |
| 464 | nil | |
| 465 | (copy-clause clause))) | |
| 466 | (gen-result nil)) | |
| 467 | 467 | (setq gen-result (proc-gen clause input)) |
| 468 | 468 | (unless gen-result |
| 469 | 469 | (unless dont-delete |
| 470 | (cl-delete clause)) | |
| 470 | (cl-delete clause)) | |
| 471 | 471 | (when original-input |
| 472 | (cl-delete original-input)) | |
| 472 | (cl-delete original-input)) | |
| 473 | 473 | (return-from pre-process nil)) |
| 474 | 474 | |
| 475 | 475 | (when (pn-flag debug-infer) |
| 476 | 476 | (with-output-msg () |
| 477 | (format t "after proc-gen:") | |
| 478 | (print-clause clause))) | |
| 477 | (format t "after proc-gen:") | |
| 478 | (print-clause clause))) | |
| 479 | 479 | |
| 480 | 480 | (when original-input |
| 481 | 481 | ;; when input clauses are changed (unit-del, factor-simp, |
| 482 | 482 | ;; demod) during pre-process, we keep the original so that |
| 483 | 483 | ;; proofs make sense. |
| 484 | 484 | (setf (clause-parents original-input) |
| 485 | (list (list :copy-rule (clause-id clause)))) | |
| 485 | (list (list :copy-rule (clause-id clause)))) | |
| 486 | 486 | ;; (register-clause original-input *current-psys*) |
| 487 | 487 | ) |
| 488 | 488 | |
| 489 | 489 | ;; registering & indexing |
| 490 | 490 | (index-all-literals clause) |
| 491 | 491 | (when (and (eq list :usable) |
| 492 | (not (eq clause *given-clause*))) | |
| 492 | (not (eq clause *given-clause*))) | |
| 493 | 493 | (index-clash-literals clause)) |
| 494 | 494 | |
| 495 | 495 | ;; append to list |
| 503 | 503 | #|| |
| 504 | 504 | (unless (= 0 (pn-parameter age-factor)) |
| 505 | 505 | (incf (clause-pick-weight clause) |
| 506 | (/ (pn-stat cl-given) (pn-parameter age-factor)))) | |
| 506 | (/ (pn-stat cl-given) (pn-parameter age-factor)))) | |
| 507 | 507 | ||# |
| 508 | 508 | |
| 509 | 509 | #|| no yet |
| 510 | 510 | (unless (= 0 (pn-parameter distinct-vars-factor)) |
| 511 | 511 | (incf (clause-pick-weight clause) |
| 512 | (* (clause-distinct-variables clause) | |
| 513 | (pn-parameter distinct-vars-factor)))) | |
| 512 | (* (clause-distinct-variables clause) | |
| 513 | (pn-parameter distinct-vars-factor)))) | |
| 514 | 514 | ||# |
| 515 | 515 | ;; |
| 516 | 516 | (incf (pn-stat cl-kept)) |
| 520 | 520 | ||# |
| 521 | 521 | ;; |
| 522 | 522 | (when (or (and input (not (pn-flag quiet))) |
| 523 | (pn-flag print-kept)) | |
| 524 | (with-output-simple-msg () | |
| 525 | (format t "* kept in ~a : weight=~d" list (clause-pick-weight clause)) | |
| 526 | (print-next) | |
| 527 | (print-clause clause)) | |
| 528 | ) | |
| 523 | (pn-flag print-kept)) | |
| 524 | (with-output-simple-msg () | |
| 525 | (format t "* kept in ~a : weight=~d" list (clause-pick-weight clause)) | |
| 526 | (print-next) | |
| 527 | (print-clause clause)) | |
| 528 | ) | |
| 529 | 529 | |
| 530 | 530 | ;; dynamic demodulation |
| 531 | 531 | |
| 532 | 532 | (when (or (not (pn-flag no-new-demod)) |
| 533 | input) | |
| 533 | input) | |
| 534 | 534 | (when (and (or (pn-flag dynamic-demod) |
| 535 | (pn-flag demod-inf)) | |
| 536 | (unit-clause? clause) | |
| 537 | (= 1 (the fixnum (num-literals-all clause))) | |
| 538 | (or (positive-eq-literal? (the literal (ith-literal clause 1))) | |
| 539 | (and input | |
| 540 | (not (eq-literal? | |
| 541 | (the literal (ith-literal clause 1))))))) | |
| 542 | ;; | |
| 543 | (let ((demod-flag (dynamic-demodulator clause))) | |
| 544 | (declare (type symbol demod-flag)) | |
| 545 | (when demod-flag | |
| 546 | (let ((new-demod (new-demodulator clause demod-flag))) | |
| 547 | (declare (type demod new-demod)) | |
| 548 | (unless (pn-flag quiet) | |
| 549 | (when (pn-flag print-new-demod) | |
| 550 | (with-output-simple-msg () | |
| 551 | (princ "* new demodulator: ") | |
| 552 | (print-next) | |
| 553 | (print-demodulator new-demod)) | |
| 554 | )) | |
| 555 | (push (cons clause new-demod) *new-demodulator*) | |
| 556 | ))) | |
| 557 | )) | |
| 535 | (pn-flag demod-inf)) | |
| 536 | (unit-clause? clause) | |
| 537 | (= 1 (the fixnum (num-literals-all clause))) | |
| 538 | (or (positive-eq-literal? (the literal (ith-literal clause 1))) | |
| 539 | (and input | |
| 540 | (not (eq-literal? | |
| 541 | (the literal (ith-literal clause 1))))))) | |
| 542 | ;; | |
| 543 | (let ((demod-flag (dynamic-demodulator clause))) | |
| 544 | (declare (type symbol demod-flag)) | |
| 545 | (when demod-flag | |
| 546 | (let ((new-demod (new-demodulator clause demod-flag))) | |
| 547 | (declare (type demod new-demod)) | |
| 548 | (unless (pn-flag quiet) | |
| 549 | (when (pn-flag print-new-demod) | |
| 550 | (with-output-simple-msg () | |
| 551 | (princ "* new demodulator: ") | |
| 552 | (print-next) | |
| 553 | (print-demodulator new-demod)) | |
| 554 | )) | |
| 555 | (push (cons clause new-demod) *new-demodulator*) | |
| 556 | ))) | |
| 557 | )) | |
| 558 | 558 | |
| 559 | 559 | ;; check for proof |
| 560 | 560 | (let ((e nil)) |
| 561 | 561 | (setq e (check-for-proof clause list)) |
| 562 | 562 | (when (and (not (= -1 (pn-parameter max-proofs))) |
| 563 | (>= (pn-stat empty-clauses) | |
| 564 | (pn-parameter max-proofs))) | |
| 565 | ;; the end | |
| 566 | (when (pn-flag print-stats) | |
| 567 | (format t "~%** Search stopped due to max-proofs option.~% ~%") | |
| 568 | ) | |
| 569 | (infer-clean-up) | |
| 570 | ;; | |
| 571 | (exit-pn-proof :max-proofs-exit)) | |
| 563 | (>= (pn-stat empty-clauses) | |
| 564 | (pn-parameter max-proofs))) | |
| 565 | ;; the end | |
| 566 | (when (pn-flag print-stats) | |
| 567 | (format t "~%** Search stopped due to max-proofs option.~% ~%") | |
| 568 | ) | |
| 569 | (infer-clean-up) | |
| 570 | ;; | |
| 571 | (exit-pn-proof :max-proofs-exit)) | |
| 572 | 572 | (when e |
| 573 | (when (pn-flag debug-infer) | |
| 574 | (with-output-msg () | |
| 575 | (princ "End[pre-process]: empty clause."))) | |
| 576 | (return-from pre-process nil)) | |
| 573 | (when (pn-flag debug-infer) | |
| 574 | (with-output-msg () | |
| 575 | (princ "End[pre-process]: empty clause."))) | |
| 576 | (return-from pre-process nil)) | |
| 577 | 577 | ) |
| 578 | 578 | ;; |
| 579 | 579 | #|| NOT YET |
| 580 | 580 | (when (and (not input) |
| 581 | (<= (clause-pick-weight clause) | |
| 582 | (pn-parameter dynamic-heat-weight))) | |
| 581 | (<= (clause-pick-weight clause) | |
| 582 | (pn-parameter dynamic-heat-weight))) | |
| 583 | 583 | (hot-dynamic clause)) |
| 584 | 584 | ||# |
| 585 | 585 | ;; |
| 618 | 618 | ;;; |
| 619 | 619 | (defun proc-gen (clause &optional (input nil)) |
| 620 | 620 | (declare (type clause clause) |
| 621 | (values (or null clause))) | |
| 621 | (values (or null clause))) | |
| 622 | 622 | ;; RENAME VARIABLES |
| 623 | 623 | |
| 624 | 624 | (cl-unique-variables clause) |
| 635 | 635 | (declare (type fixnum rwc)) |
| 636 | 636 | (demodulate-clause clause) |
| 637 | 637 | (when (and (pn-flag very-verbose) |
| 638 | (not (= rwc (pn-stat rewrites)))) | |
| 638 | (not (= rwc (pn-stat rewrites)))) | |
| 639 | 639 | (with-output-simple-msg () |
| 640 | (princ " * after dmodulation: ") | |
| 641 | (print-next) | |
| 642 | (print-clause clause))) | |
| 640 | (princ " * after dmodulation: ") | |
| 641 | (print-next) | |
| 642 | (print-clause clause))) | |
| 643 | 643 | ) |
| 644 | 644 | |
| 645 | 645 | ;; |
| 673 | 673 | |
| 674 | 674 | (when (pn-flag order-eq) |
| 675 | 675 | (if (pn-flag lrpo) |
| 676 | (order-equalities-lrpo clause input) | |
| 676 | (order-equalities-lrpo clause input) | |
| 677 | 677 | (order-equalities clause input)) |
| 678 | 678 | (when (and (not input) |
| 679 | (pn-flag discard-non-orientable-eq) | |
| 680 | (unit-clause? clause) | |
| 681 | (= (the fixnum (num-literals-all clause)) 1) | |
| 682 | (positive-eq-literal? (the literal (ith-literal clause 1))) | |
| 683 | (not (test-bit (literal-stat-bits | |
| 684 | (the literal (ith-literal clause 1))) | |
| 685 | oriented-eq-bit)) | |
| 686 | ) | |
| 679 | (pn-flag discard-non-orientable-eq) | |
| 680 | (unit-clause? clause) | |
| 681 | (= (the fixnum (num-literals-all clause)) 1) | |
| 682 | (positive-eq-literal? (the literal (ith-literal clause 1))) | |
| 683 | (not (test-bit (literal-stat-bits | |
| 684 | (the literal (ith-literal clause 1))) | |
| 685 | oriented-eq-bit)) | |
| 686 | ) | |
| 687 | 687 | (return-from proc-gen nil))) |
| 688 | 688 | |
| 689 | 689 | ;; UNIT DELETION |
| 690 | 690 | |
| 691 | 691 | (when (and (pn-flag unit-deletion) |
| 692 | (> (the fixnum (num-literals clause)) 1)) | |
| 692 | (> (the fixnum (num-literals clause)) 1)) | |
| 693 | 693 | (unit-deletion clause) |
| 694 | 694 | ) |
| 695 | 695 | |
| 708 | 708 | ;; |
| 709 | 709 | ;; max-literals |
| 710 | 710 | (when (and (not input) |
| 711 | (not (= -1 (pn-parameter max-literals)))) | |
| 711 | (not (= -1 (pn-parameter max-literals)))) | |
| 712 | 712 | (when (< (pn-parameter max-literals) (num-literals clause)) |
| 713 | 713 | (incf (pn-stat cl-wt-delete)) |
| 714 | 714 | (return-from proc-gen nil))) |
| 715 | 715 | #|| |
| 716 | 716 | ;; max-answers |
| 717 | 717 | (when (and (not input) |
| 718 | (not (= -1 (pn-parameter max-answers)))) | |
| 718 | (not (= -1 (pn-parameter max-answers)))) | |
| 719 | 719 | (when (< (pn-parameter max-answers) (num-answers clause)) |
| 720 | 720 | (incf (pn-stat cl-wt-delete)) |
| 721 | 721 | (return-from proc-gen nil))) |
| 723 | 723 | ||# |
| 724 | 724 | |
| 725 | 725 | (when (and (not input) |
| 726 | (pn-flag discard-xx-resolvable) | |
| 727 | (xx-resolvable clause)) | |
| 726 | (pn-flag discard-xx-resolvable) | |
| 727 | (xx-resolvable clause)) | |
| 728 | 728 | (incf (pn-stat cl-wt-delete)) |
| 729 | 729 | (return-from proc-gen nil)) |
| 730 | 730 | |
| 737 | 737 | ;; MAX WEIGHT TEST |
| 738 | 738 | |
| 739 | 739 | (when (and (not input) |
| 740 | (not (= (pn-parameter max-weight) | |
| 741 | most-positive-fixnum))) | |
| 740 | (not (= (pn-parameter max-weight) | |
| 741 | most-positive-fixnum))) | |
| 742 | 742 | (let ((wt 0)) |
| 743 | 743 | (declare (type fixnum wt)) |
| 744 | 744 | (setq wt (weight-clause clause)) |
| 745 | 745 | (when (> wt (pn-parameter max-weight)) |
| 746 | (when (pn-flag very-verbose) | |
| 747 | (with-output-simple-msg () | |
| 748 | (format t " deleted because weight=~d." wt))) | |
| 749 | (incf (pn-stat cl-wt-delete)) | |
| 750 | (return-from proc-gen nil)))) | |
| 746 | (when (pn-flag very-verbose) | |
| 747 | (with-output-simple-msg () | |
| 748 | (format t " deleted because weight=~d." wt))) | |
| 749 | (incf (pn-stat cl-wt-delete)) | |
| 750 | (return-from proc-gen nil)))) | |
| 751 | 751 | |
| 752 | 752 | ;; DELETE IDENTICAL NESTED SKOLEM FUNCTIONS. |
| 753 | 753 | |
| 754 | 754 | (when (and (not input) |
| 755 | (pn-flag delete-identical-nested-skolem)) | |
| 755 | (pn-flag delete-identical-nested-skolem)) | |
| 756 | 756 | (when (ident-nested-skolems clause) |
| 757 | 757 | (incf (pn-stat cl-wt-delete)) |
| 758 | 758 | (return-from proc-gen nil)) |
| 772 | 772 | (let ((n 0)) |
| 773 | 773 | (declare (type fixnum n)) |
| 774 | 774 | (dolist (lit (clause-literals clause)) |
| 775 | (declare (type literal lit)) | |
| 776 | (incf n) | |
| 777 | (when (test-bit (literal-stat-bits lit) scratch-bit) | |
| 778 | ;; scratch-bit meaning flipped. | |
| 779 | (clear-bit (literal-stat-bits lit) scratch-bit) | |
| 780 | (setf (clause-parents clause) | |
| 781 | (nconc (clause-parents clause) | |
| 782 | (list (list :flip-eq-rule))))))) | |
| 775 | (declare (type literal lit)) | |
| 776 | (incf n) | |
| 777 | (when (test-bit (literal-stat-bits lit) scratch-bit) | |
| 778 | ;; scratch-bit meaning flipped. | |
| 779 | (clear-bit (literal-stat-bits lit) scratch-bit) | |
| 780 | (setf (clause-parents clause) | |
| 781 | (nconc (clause-parents clause) | |
| 782 | (list (list :flip-eq-rule))))))) | |
| 783 | 783 | |
| 784 | 784 | ) |
| 785 | 785 | |
| 788 | 788 | (when (pn-flag for-sub) |
| 789 | 789 | (when (pn-flag debug-infer) |
| 790 | 790 | (with-output-msg () |
| 791 | (princ "*proc-gen: start forward subsumption:") | |
| 792 | )) | |
| 791 | (princ "*proc-gen: start forward subsumption:") | |
| 792 | )) | |
| 793 | 793 | (let ((e nil)) |
| 794 | 794 | (declare (type (or null clause) e)) |
| 795 | 795 | (setq e (forward-subsume clause)) |
| 796 | 796 | (when e |
| 797 | (if (pn-flag very-verbose) | |
| 798 | (with-output-simple-msg () | |
| 799 | (format t " * subsumed by ~d." (clause-id e))) | |
| 800 | (when (and input (not (pn-flag quiet))) | |
| 801 | (with-output-simple-msg () | |
| 802 | (format t "-- following clause subsumed by ~d during input processing:" | |
| 803 | (clause-id e)) | |
| 804 | (print-next) | |
| 805 | (print-clause clause)) | |
| 806 | )) | |
| 807 | (incf (pn-stat cl-for-sub)) | |
| 808 | (when (eq (clause-container e) :sos) | |
| 809 | (incf (pn-stat for-sub-sos))) | |
| 810 | ;; | |
| 811 | (return-from proc-gen nil) | |
| 812 | )) | |
| 797 | (if (pn-flag very-verbose) | |
| 798 | (with-output-simple-msg () | |
| 799 | (format t " * subsumed by ~d." (clause-id e))) | |
| 800 | (when (and input (not (pn-flag quiet))) | |
| 801 | (with-output-simple-msg () | |
| 802 | (format t "-- following clause subsumed by ~d during input processing:" | |
| 803 | (clause-id e)) | |
| 804 | (print-next) | |
| 805 | (print-clause clause)) | |
| 806 | )) | |
| 807 | (incf (pn-stat cl-for-sub)) | |
| 808 | (when (eq (clause-container e) :sos) | |
| 809 | (incf (pn-stat for-sub-sos))) | |
| 810 | ;; | |
| 811 | (return-from proc-gen nil) | |
| 812 | )) | |
| 813 | 813 | (when (pn-flag debug-infer) |
| 814 | 814 | (with-output-msg () |
| 815 | (princ "*proc-gen: end forward subsumption.") | |
| 816 | )) | |
| 815 | (princ "*proc-gen: end forward subsumption.") | |
| 816 | )) | |
| 817 | 817 | ) |
| 818 | 818 | ;; all over |
| 819 | 819 | clause) |
| 830 | 830 | ;; |
| 831 | 831 | (if (pn-flag universal-symmetry) |
| 832 | 832 | (let ((eqvar (make-variable-term *cosmos* (gensym "Univ")))) |
| 833 | (declare (type term eqvar)) | |
| 834 | (let ((symm (car (cnf-to-list | |
| 835 | (make-term-with-sort-check *fopl-eq* | |
| 836 | (list eqvar eqvar)) | |
| 837 | *current-psys*)))) | |
| 838 | (declare (type clause symm) | |
| 839 | (type psystem *current-psys*)) | |
| 840 | (if (or (pn-flag auto) | |
| 841 | (pn-flag auto1) | |
| 842 | (pn-flag auto2) | |
| 843 | (pn-flag auto3)) | |
| 844 | (push symm (psystem-axioms *current-psys*)) | |
| 845 | (progn (push symm (psystem-usable *current-psys*)) | |
| 846 | (push symm *usable*)) | |
| 847 | ) | |
| 848 | ;; | |
| 849 | #|| | |
| 850 | (if (pn-flag simple-index) | |
| 851 | (setq *universal-symmetry* nil) | |
| 852 | (setq *universal-symmetry* (car symm))) | |
| 853 | ||# | |
| 854 | )) | |
| 833 | (declare (type term eqvar)) | |
| 834 | (let ((symm (car (cnf-to-list | |
| 835 | (make-term-with-sort-check *fopl-eq* | |
| 836 | (list eqvar eqvar)) | |
| 837 | *current-psys*)))) | |
| 838 | (declare (type clause symm) | |
| 839 | (type psystem *current-psys*)) | |
| 840 | (if (or (pn-flag auto) | |
| 841 | (pn-flag auto1) | |
| 842 | (pn-flag auto2) | |
| 843 | (pn-flag auto3)) | |
| 844 | (push symm (psystem-axioms *current-psys*)) | |
| 845 | (progn (push symm (psystem-usable *current-psys*)) | |
| 846 | (push symm *usable*)) | |
| 847 | ) | |
| 848 | ;; | |
| 849 | #|| | |
| 850 | (if (pn-flag simple-index) | |
| 851 | (setq *universal-symmetry* nil) | |
| 852 | (setq *universal-symmetry* (car symm))) | |
| 853 | ||# | |
| 854 | )) | |
| 855 | 855 | ;; (setq *universal-symmetry* nil) |
| 856 | 856 | () |
| 857 | 857 | ) |
| 858 | 858 | ;; a dirty kludge |
| 859 | 859 | (unless (or (pn-flag auto) |
| 860 | (pn-flag auto1) | |
| 861 | (pn-flag auto2) | |
| 862 | (pn-flag auto3)) | |
| 860 | (pn-flag auto1) | |
| 861 | (pn-flag auto2) | |
| 862 | (pn-flag auto3)) | |
| 863 | 863 | (setf (psystem-sos *current-psys*) |
| 864 | 864 | (remove :system-goal (psystem-sos *current-psys*) :test #'eq)) |
| 865 | 865 | (setf *sos* |
| 877 | 877 | (if (or (pn-flag auto) (pn-flag auto1)) |
| 878 | 878 | (pn-automatic-settings-1) |
| 879 | 879 | (if (pn-flag auto2) |
| 880 | (pn-automatic-settings-2) | |
| 880 | (pn-automatic-settings-2) | |
| 881 | 881 | (if (pn-flag auto3) |
| 882 | (pn-automatic-settings-3) | |
| 883 | ;; else, full manual mode: | |
| 884 | ;; support setting sos implicitly by axiom label. | |
| 885 | ;; (pn-automatic-sos-setting) | |
| 886 | ;; NOT for now. | |
| 887 | () | |
| 888 | ))) | |
| 882 | (pn-automatic-settings-3) | |
| 883 | ;; else, full manual mode: | |
| 884 | ;; support setting sos implicitly by axiom label. | |
| 885 | ;; (pn-automatic-sos-setting) | |
| 886 | ;; NOT for now. | |
| 887 | () | |
| 888 | ))) | |
| 889 | 889 | ;; |
| 890 | 890 | (check-pn-options) |
| 891 | 891 | |
| 894 | 894 | |
| 895 | 895 | ;; |
| 896 | 896 | (cond ((pn-flag process-input) |
| 897 | ;; PROCESS INPUT if RQUIRED | |
| 898 | (when (pn-flag print-message) | |
| 899 | (format t "~% ~%** start input processing.~%") | |
| 900 | ) | |
| 901 | (when (and (pn-flag print-message) | |
| 902 | (not (pn-flag print-lists-at-end))) | |
| 903 | (print-usable-list)) | |
| 904 | (when (pn-flag print-message) | |
| 905 | (with-output-simple-msg () | |
| 906 | (format t " process usable:"))) | |
| 907 | (setf (pn-stats usable-size) 0) | |
| 908 | (let ((list *usable*)) | |
| 909 | (setq *usable* nil) | |
| 910 | (dolist (c list) | |
| 911 | (pre-process c t :usable)) | |
| 912 | (post-proc-all nil t :usable)) | |
| 913 | (when *current-psys* | |
| 914 | (setf (psystem-usable *current-psys*) *usable*)) | |
| 915 | ;; | |
| 916 | (when (and (pn-flag print-message) | |
| 917 | (not (pn-flag print-lists-at-end))) | |
| 918 | (print-sos-list) | |
| 919 | ) | |
| 920 | (when (pn-flag print-message) | |
| 921 | (with-output-simple-msg () | |
| 922 | (format t " process sos:"))) | |
| 923 | (setf (pn-stats sos-size) 0) | |
| 924 | (let ((list *sos*)) | |
| 925 | (setq *sos* nil) | |
| 926 | (dolist (c list) | |
| 927 | (pre-process c t :sos))) | |
| 928 | (post-proc-all nil t :sos) | |
| 929 | ;; | |
| 930 | (let ((list *passive*)) | |
| 931 | (dolist (c list) | |
| 932 | ;; index passive | |
| 933 | (index-all-literals c))) | |
| 934 | ;; | |
| 935 | (when (and (pn-flag print-message) | |
| 936 | (not (pn-flag print-lists-at-end))) | |
| 937 | (print-passive-list) | |
| 938 | (print-demodulators-list)) | |
| 939 | ;; | |
| 940 | (when (pn-flag print-message) | |
| 941 | (format t "~%** end process input.~%")) | |
| 942 | ) | |
| 943 | ;; | |
| 944 | (t | |
| 945 | (setf (pn-stats usable-size) (length *usable*)) | |
| 946 | (setf (pn-stats sos-size) (length *sos*)) | |
| 947 | (pignose-index-all mod) | |
| 948 | )) | |
| 897 | ;; PROCESS INPUT if RQUIRED | |
| 898 | (when (pn-flag print-message) | |
| 899 | (format t "~% ~%** start input processing.~%") | |
| 900 | ) | |
| 901 | (when (and (pn-flag print-message) | |
| 902 | (not (pn-flag print-lists-at-end))) | |
| 903 | (print-usable-list)) | |
| 904 | (when (pn-flag print-message) | |
| 905 | (with-output-simple-msg () | |
| 906 | (format t " process usable:"))) | |
| 907 | (setf (pn-stats usable-size) 0) | |
| 908 | (let ((list *usable*)) | |
| 909 | (setq *usable* nil) | |
| 910 | (dolist (c list) | |
| 911 | (pre-process c t :usable)) | |
| 912 | (post-proc-all nil t :usable)) | |
| 913 | (when *current-psys* | |
| 914 | (setf (psystem-usable *current-psys*) *usable*)) | |
| 915 | ;; | |
| 916 | (when (and (pn-flag print-message) | |
| 917 | (not (pn-flag print-lists-at-end))) | |
| 918 | (print-sos-list) | |
| 919 | ) | |
| 920 | (when (pn-flag print-message) | |
| 921 | (with-output-simple-msg () | |
| 922 | (format t " process sos:"))) | |
| 923 | (setf (pn-stats sos-size) 0) | |
| 924 | (let ((list *sos*)) | |
| 925 | (setq *sos* nil) | |
| 926 | (dolist (c list) | |
| 927 | (pre-process c t :sos))) | |
| 928 | (post-proc-all nil t :sos) | |
| 929 | ;; | |
| 930 | (let ((list *passive*)) | |
| 931 | (dolist (c list) | |
| 932 | ;; index passive | |
| 933 | (index-all-literals c))) | |
| 934 | ;; | |
| 935 | (when (and (pn-flag print-message) | |
| 936 | (not (pn-flag print-lists-at-end))) | |
| 937 | (print-passive-list) | |
| 938 | (print-demodulators-list)) | |
| 939 | ;; | |
| 940 | (when (pn-flag print-message) | |
| 941 | (format t "~%** end process input.~%")) | |
| 942 | ) | |
| 943 | ;; | |
| 944 | (t | |
| 945 | (setf (pn-stats usable-size) (length *usable*)) | |
| 946 | (setf (pn-stats sos-size) (length *sos*)) | |
| 947 | (pignose-index-all mod) | |
| 948 | )) | |
| 949 | 949 | ;; weight clauses |
| 950 | 950 | (let ((input-sos-first? (pn-flag input-sos-first))) |
| 951 | 951 | (dolist (cl *sos*) |
| 952 | 952 | (setf (clause-pick-weight cl) |
| 953 | (if input-sos-first? | |
| 954 | most-negative-fixnum | |
| 955 | (weight-clause cl))))) | |
| 953 | (if input-sos-first? | |
| 954 | most-negative-fixnum | |
| 955 | (weight-clause cl))))) | |
| 956 | 956 | |
| 957 | 957 | ;; |
| 958 | 958 | (reset-memory-control) |
| 976 | 976 | ;;; |
| 977 | 977 | (defun check-pn-options () |
| 978 | 978 | (unless (or (pn-flag binary-res) |
| 979 | (pn-flag hyper-res) | |
| 980 | (pn-flag neg-hyper-res) | |
| 981 | (pn-flag ur-res) | |
| 982 | (pn-flag para-from) | |
| 983 | (pn-flag para-into) | |
| 984 | (pn-flag demod-inf) | |
| 985 | ) | |
| 979 | (pn-flag hyper-res) | |
| 980 | (pn-flag neg-hyper-res) | |
| 981 | (pn-flag ur-res) | |
| 982 | (pn-flag para-from) | |
| 983 | (pn-flag para-into) | |
| 984 | (pn-flag demod-inf) | |
| 985 | ) | |
| 986 | 986 | (with-output-chaos-warning () |
| 987 | 987 | (princ "no inference rules are specified."))) |
| 988 | 988 | ;; |
| 989 | 989 | (when (and (pn-flag para-from) |
| 990 | (not (pn-flag para-from-right)) | |
| 991 | (not (pn-flag para-from-left))) | |
| 990 | (not (pn-flag para-from-right)) | |
| 991 | (not (pn-flag para-from-left))) | |
| 992 | 992 | (with-output-chaos-warning () |
| 993 | (princ "`para-from' is set, but `para-from-left' and `para-from-right' are both off."))) | |
| 993 | (princ "`para-from' is set, but `para-from-left' and `para-from-right' are both off."))) | |
| 994 | 994 | ;; |
| 995 | 995 | (when (and (pn-flag para-into) |
| 996 | (not (pn-flag para-into-right)) | |
| 997 | (not (pn-flag para-into-left))) | |
| 996 | (not (pn-flag para-into-right)) | |
| 997 | (not (pn-flag para-into-left))) | |
| 998 | 998 | (with-output-chaos-warning () |
| 999 | (princ "`para-into' is set, but `para-into-left' and `para-from-right' are both off."))) | |
| 999 | (princ "`para-into' is set, but `para-into-left' and `para-from-right' are both off."))) | |
| 1000 | 1000 | ;; |
| 1001 | 1001 | (when (and (not (pn-flag para-from)) |
| 1002 | (not (pn-flag para-into)) | |
| 1003 | (pn-flag para-ones-rule)) | |
| 1002 | (not (pn-flag para-into)) | |
| 1003 | (pn-flag para-ones-rule)) | |
| 1004 | 1004 | (with-output-chaos-warning () |
| 1005 | (princ "`para-from', `para-into' rules are off, but `para-ones-rule' is set."))) | |
| 1005 | (princ "`para-from', `para-into' rules are off, but `para-ones-rule' is set."))) | |
| 1006 | 1006 | ;; |
| 1007 | 1007 | (when (and (or (pn-flag kb) |
| 1008 | (pn-flag kb2) | |
| 1009 | (pn-flag kb3)) | |
| 1010 | (not (pn-flag lrpo))) | |
| 1008 | (pn-flag kb2) | |
| 1009 | (pn-flag kb3)) | |
| 1010 | (not (pn-flag lrpo))) | |
| 1011 | 1011 | (with-output-chaos-warning () |
| 1012 | (princ "`knuth-bendix' is set and `lrpo' is off."))) | |
| 1012 | (princ "`knuth-bendix' is set and `lrpo' is off."))) | |
| 1013 | 1013 | ;; |
| 1014 | 1014 | (when (= (pn-parameter demod-limit) 0) |
| 1015 | 1015 | (with-output-chaos-warning () |
| 1016 | (princ "demod-limit=0; set it to -1 for no limit."))) | |
| 1016 | (princ "demod-limit=0; set it to -1 for no limit."))) | |
| 1017 | 1017 | |
| 1018 | 1018 | (when (= (pn-parameter max-literals) 0) |
| 1019 | 1019 | (with-output-chaos-warning () |
| 1020 | (princ "max-literals=0; set it to -1 for no limit."))) | |
| 1020 | (princ "max-literals=0; set it to -1 for no limit."))) | |
| 1021 | 1021 | |
| 1022 | 1022 | (when (= (pn-parameter max-proofs) 0) |
| 1023 | 1023 | (with-output-chaos-warning () |
| 1024 | (princ "max-proofs=0; set it to -1 for no limit."))) | |
| 1024 | (princ "max-proofs=0; set it to -1 for no limit."))) | |
| 1025 | 1025 | |
| 1026 | 1026 | (when (not (= -1 (pn-parameter pick-given-ratio))) |
| 1027 | 1027 | (if (pn-flag sos-stack) |
| 1028 | (with-output-chaos-warning () | |
| 1029 | (princ "`sos-stack' has priority over `pick-given-ratio'.")) | |
| 1030 | (if (pn-flag sos-queue) | |
| 1031 | (with-output-chaos-warning () | |
| 1032 | (princ "`sos-queue' has priority over `pick-given-ratio'."))))) | |
| 1028 | (with-output-chaos-warning () | |
| 1029 | (princ "`sos-stack' has priority over `pick-given-ratio'.")) | |
| 1030 | (if (pn-flag sos-queue) | |
| 1031 | (with-output-chaos-warning () | |
| 1032 | (princ "`sos-queue' has priority over `pick-given-ratio'."))))) | |
| 1033 | 1033 | (when (and (pn-flag sos-stack) |
| 1034 | (pn-flag sos-queue)) | |
| 1034 | (pn-flag sos-queue)) | |
| 1035 | 1035 | (with-output-chaos-warning () |
| 1036 | (princ "`sos-queue' has priority over `sos-stack'."))) | |
| 1036 | (princ "`sos-queue' has priority over `sos-stack'."))) | |
| 1037 | 1037 | ;; |
| 1038 | 1038 | #|| |
| 1039 | 1039 | (when (and (pn-flag para-all) |
| 1040 | (pn-flag detailed-history)) | |
| 1040 | (pn-flag detailed-history)) | |
| 1041 | 1041 | (with-output-chaos-warning () |
| 1042 | (princ "detailed paramod history is ignored when `para-all' is set."))) | |
| 1042 | (princ "detailed paramod history is ignored when `para-all' is set."))) | |
| 1043 | 1043 | ||# |
| 1044 | 1044 | ) |
| 1045 | 1045 | |
| 0 | 0 | ;;;-*-Mode:LISP; Package: CHAOS; Base:10; Syntax:Common-lisp -*- |
| 1 | 1 | ;;; |
| 2 | ;;; Copyright (c) 2000-2014, Toshimi Sawada. All rights reserved. | |
| 2 | ;;; Copyright (c) 2000-2015, Toshimi Sawada. All rights reserved. | |
| 3 | 3 | ;;; |
| 4 | 4 | ;;; Redistribution and use in source and binary forms, with or without |
| 5 | 5 | ;;; modification, are permitted provided that the following conditions |
| 28 | 28 | ;;; |
| 29 | 29 | (in-package :chaos) |
| 30 | 30 | #|============================================================================= |
| 31 | System:Chaos | |
| 32 | Module:BigPink | |
| 33 | File:inv.lisp | |
| 31 | System:Chaos | |
| 32 | Module:BigPink | |
| 33 | File:inv.lisp | |
| 34 | 34 | =============================================================================|# |
| 35 | 35 | #-:chaos-debug |
| 36 | 36 | (declaim (optimize (speed 3) (safety 0) #-GCL (debug 0))) |
| 48 | 48 | ;;; INV-CHECK-SYSTEM |
| 49 | 49 | ;;; |
| 50 | 50 | (defstruct (inv-check-system) |
| 51 | (module nil :type (or null module)) ; context module | |
| 52 | (sort nil :type (or null sort*)) ; sort of object | |
| 51 | (module nil :type (or null module)) ; context module | |
| 52 | (sort nil :type (or null sort*)) ; sort of object | |
| 53 | 53 | (predicate nil :type (or null method)) ; predicate representing invariance |
| 54 | 54 | (initial-state nil :type (or null term)) ; initial state constant term |
| 55 | (object nil :type term) ; term representing target object | |
| 56 | (methods nil :type list) ; methods w.r.t. hidden sort | |
| 57 | (goals nil :type list) ; goals to be proved | |
| 58 | (conditions nil :type list) ; filed goals | |
| 59 | (after-loop 0 :type fixnum) ; loop start point | |
| 55 | (object nil :type term) ; term representing target object | |
| 56 | (methods nil :type list) ; methods w.r.t. hidden sort | |
| 57 | (goals nil :type list) ; goals to be proved | |
| 58 | (conditions nil :type list) ; filed goals | |
| 59 | (after-loop 0 :type fixnum) ; loop start point | |
| 60 | 60 | (after-num 0 :type fixnum)) |
| 61 | 61 | |
| 62 | 62 | (defun pn-get-meth-unique (module opname) |
| 63 | 63 | (declare (type module module) |
| 64 | (type list opname) | |
| 65 | (values method)) | |
| 64 | (type list opname) | |
| 65 | (values method)) | |
| 66 | 66 | (with-in-module (module) |
| 67 | 67 | (let* ((parsedop (parse-op-name opname)) |
| 68 | (ops (find-qual-operators parsedop module)) | |
| 69 | (op nil)) | |
| 68 | (ops (find-qual-operators parsedop module)) | |
| 69 | (op nil)) | |
| 70 | 70 | (unless ops |
| 71 | (with-output-chaos-error ('no-op) | |
| 72 | (format t "no such operator with name ~s" opname))) | |
| 71 | (with-output-chaos-error ('no-op) | |
| 72 | (format t "no such operator with name ~s" opname))) | |
| 73 | 73 | (when (cdr ops) |
| 74 | (with-output-chaos-error ('amb-op) | |
| 75 | (format t "more than one operators with name ~s" opname))) | |
| 74 | (with-output-chaos-error ('amb-op) | |
| 75 | (format t "more than one operators with name ~s" opname))) | |
| 76 | 76 | ;; |
| 77 | 77 | (dolist (meth (opinfo-methods (car ops))) |
| 78 | (unless (method-is-error-method meth) | |
| 79 | (setq op meth) | |
| 80 | (return))) | |
| 78 | (unless (method-is-error-method meth) | |
| 79 | (setq op meth) | |
| 80 | (return))) | |
| 81 | 81 | op))) |
| 82 | 82 | |
| 83 | 83 | (defun make-term-pat (method) |
| 84 | 84 | (declare (type method method)) |
| 85 | 85 | (make-term-with-sort-check method |
| 86 | (mapcar #'(lambda (x) | |
| 87 | (make-variable-term x | |
| 88 | (gensym "_V"))) | |
| 89 | (method-arity method)))) | |
| 86 | (mapcar #'(lambda (x) | |
| 87 | (make-variable-term x | |
| 88 | (gensym "_V"))) | |
| 89 | (method-arity method)))) | |
| 90 | 90 | |
| 91 | 91 | (defun make-inv-check-context (methods hole target-pattern) |
| 92 | 92 | (let ((res nil)) |
| 93 | 93 | (dolist (method methods) |
| 94 | 94 | (let ((kernel-pat nil)) |
| 95 | (setq kernel-pat | |
| 96 | (make-term-with-sort-check | |
| 97 | method | |
| 98 | (mapcar #'(lambda (x) | |
| 99 | (if (not (sort-is-hidden x)) | |
| 100 | (make-variable-term x | |
| 101 | (gensym "_V")) | |
| 102 | (progn | |
| 103 | (unless (sort= x (term-sort target-pattern)) | |
| 104 | (with-output-chaos-error ('no-sort-match) | |
| 105 | (princ "unmatched hidden sorts") | |
| 106 | )) | |
| 107 | hole))) | |
| 108 | (method-arity method)))) | |
| 109 | (push | |
| 110 | (if (term-is-variable? target-pattern) | |
| 111 | kernel-pat | |
| 112 | (apply-subst (list (cons hole kernel-pat)) target-pattern)) | |
| 113 | res))) | |
| 95 | (setq kernel-pat | |
| 96 | (make-term-with-sort-check | |
| 97 | method | |
| 98 | (mapcar #'(lambda (x) | |
| 99 | (if (not (sort-is-hidden x)) | |
| 100 | (make-variable-term x | |
| 101 | (gensym "_V")) | |
| 102 | (progn | |
| 103 | (unless (sort= x (term-sort target-pattern)) | |
| 104 | (with-output-chaos-error ('no-sort-match) | |
| 105 | (princ "unmatched hidden sorts") | |
| 106 | )) | |
| 107 | hole))) | |
| 108 | (method-arity method)))) | |
| 109 | (push | |
| 110 | (if (term-is-variable? target-pattern) | |
| 111 | kernel-pat | |
| 112 | (apply-subst (list (cons hole kernel-pat)) target-pattern)) | |
| 113 | res))) | |
| 114 | 114 | ;; |
| 115 | 115 | (when (pn-flag debug-inv-check) |
| 116 | 116 | (with-output-simple-msg () |
| 117 | (format t "** check contexts:") | |
| 118 | (dolist (tp res) | |
| 119 | (print-next) | |
| 120 | (term-print tp)))) | |
| 117 | (format t "** check contexts:") | |
| 118 | (dolist (tp res) | |
| 119 | (print-next) | |
| 120 | (term-print tp)))) | |
| 121 | 121 | ;; |
| 122 | 122 | res)) |
| 123 | 123 | |
| 125 | 125 | (let ((res nil)) |
| 126 | 126 | (dolist (tpat target-patterns) |
| 127 | 127 | (setq res |
| 128 | (nconc res | |
| 129 | (make-inv-check-context methods hole tpat)))) | |
| 128 | (nconc res | |
| 129 | (make-inv-check-context methods hole tpat)))) | |
| 130 | 130 | res)) |
| 131 | 131 | |
| 132 | 132 | (defun pn-expand-macro (term module) |
| 133 | 133 | (if (module-macros module) |
| 134 | 134 | (let ((pat-string |
| 135 | (with-output-to-string (stream) | |
| 136 | (let ((*print-with-sort* t)) | |
| 137 | (term-print term stream))))) | |
| 138 | (simple-parse-from-string pat-string)) | |
| 135 | (with-output-to-string (stream) | |
| 136 | (let ((*print-with-sort* t)) | |
| 137 | (term-print term stream))))) | |
| 138 | (simple-parse-from-string pat-string)) | |
| 139 | 139 | term)) |
| 140 | 140 | |
| 141 | 141 | (defun make-pn-inv-check-pat (predicate |
| 142 | target-pat | |
| 143 | &key (make-condition nil) | |
| 144 | (print-msg *error-output*) | |
| 145 | (make-imply nil)) | |
| 142 | target-pat | |
| 143 | &key (make-condition nil) | |
| 144 | (print-msg *error-output*) | |
| 145 | (make-imply nil)) | |
| 146 | 146 | (let ((hole nil) |
| 147 | (hypo-pat nil) | |
| 148 | (hole-subst nil) | |
| 149 | ;; (method-pat nil) | |
| 150 | (conc-pat nil) | |
| 151 | (check-pat nil) | |
| 152 | ) | |
| 147 | (hypo-pat nil) | |
| 148 | (hole-subst nil) | |
| 149 | ;; (method-pat nil) | |
| 150 | (conc-pat nil) | |
| 151 | (check-pat nil) | |
| 152 | ) | |
| 153 | 153 | ;; |
| 154 | 154 | (setq hypo-pat |
| 155 | 155 | (make-term-with-sort-check predicate |
| 156 | (mapcar #'(lambda (x) | |
| 157 | (let ((var (make-variable-term | |
| 158 | x | |
| 159 | (gensym "_V")))) | |
| 160 | (when (sort-is-hidden x) | |
| 161 | (push var hole)) | |
| 162 | (if make-imply | |
| 163 | make-imply | |
| 164 | var))) | |
| 165 | (method-arity predicate)))) | |
| 156 | (mapcar #'(lambda (x) | |
| 157 | (let ((var (make-variable-term | |
| 158 | x | |
| 159 | (gensym "_V")))) | |
| 160 | (when (sort-is-hidden x) | |
| 161 | (push var hole)) | |
| 162 | (if make-imply | |
| 163 | make-imply | |
| 164 | var))) | |
| 165 | (method-arity predicate)))) | |
| 166 | 166 | (when (cdr hole) |
| 167 | 167 | (with-output-chaos-error ('too-many-holes) |
| 168 | (princ "predicate pattern has too many hidden context"))) | |
| 168 | (princ "predicate pattern has too many hidden context"))) | |
| 169 | 169 | (setq hole |
| 170 | 170 | (if make-imply |
| 171 | make-imply | |
| 172 | (car hole))) | |
| 171 | make-imply | |
| 172 | (car hole))) | |
| 173 | 173 | (setq hole-subst (list (cons hole target-pat))) |
| 174 | 174 | (setq conc-pat (apply-subst hole-subst hypo-pat)) |
| 175 | 175 | |
| 176 | 176 | ;; make check pattern |
| 177 | 177 | (if make-imply |
| 178 | (setq check-pat | |
| 179 | (make-term-with-sort-check | |
| 180 | *fopl-imply* | |
| 181 | (list hypo-pat conc-pat))) | |
| 178 | (setq check-pat | |
| 179 | (make-term-with-sort-check | |
| 180 | *fopl-imply* | |
| 181 | (list hypo-pat conc-pat))) | |
| 182 | 182 | (setq check-pat conc-pat) |
| 183 | 183 | ) |
| 184 | 184 | ;; bound free variables |
| 186 | 186 | ;; |
| 187 | 187 | (when print-msg |
| 188 | 188 | (let ((*print-indent* 7)) |
| 189 | (if (stringp print-msg) | |
| 190 | (setq print-msg | |
| 191 | (with-output-to-string (stream) | |
| 192 | (if make-condition | |
| 193 | (format stream "~%~a: " make-condition) | |
| 194 | (format stream "~%goal: ")) | |
| 195 | (term-print check-pat stream))) | |
| 196 | (progn | |
| 197 | (if make-condition | |
| 198 | (format print-msg "~%~a: " make-condition) | |
| 199 | (format print-msg "~%goal: ")) | |
| 200 | (term-print check-pat print-msg))))) | |
| 189 | (if (stringp print-msg) | |
| 190 | (setq print-msg | |
| 191 | (with-output-to-string (stream) | |
| 192 | (if make-condition | |
| 193 | (format stream "~%~a: " make-condition) | |
| 194 | (format stream "~%goal: ")) | |
| 195 | (term-print check-pat stream))) | |
| 196 | (progn | |
| 197 | (if make-condition | |
| 198 | (format print-msg "~%~a: " make-condition) | |
| 199 | (format print-msg "~%goal: ")) | |
| 200 | (term-print check-pat print-msg))))) | |
| 201 | 201 | |
| 202 | 202 | ;; negate |
| 203 | 203 | (unless make-condition |
| 204 | 204 | (setq check-pat |
| 205 | (make-term-with-sort-check *fopl-neg* | |
| 206 | (list check-pat)))) | |
| 205 | (make-term-with-sort-check *fopl-neg* | |
| 206 | (list check-pat)))) | |
| 207 | 207 | ;; expand macro |
| 208 | 208 | (setq check-pat (pn-expand-macro check-pat *current-module*)) |
| 209 | 209 | |
| 218 | 218 | |
| 219 | 219 | (defun setup-inv-check-db (module goal preset-sos preset-passive) |
| 220 | 220 | (when (or (pn-flag auto) |
| 221 | (pn-flag auto1) | |
| 222 | (pn-flag auto2) | |
| 223 | (pn-flag auto3)) | |
| 221 | (pn-flag auto1) | |
| 222 | (pn-flag auto2) | |
| 223 | (pn-flag auto3)) | |
| 224 | 224 | ;; in auto mode, |
| 225 | 225 | ;; essentially we need not do anything, |
| 226 | 226 | ;; but make sure to force `db-reset', because new axioms |
| 243 | 243 | ;; (setf (psystem-passive psys) preset-passive) |
| 244 | 244 | ;; reset SOS |
| 245 | 245 | (let ((sos nil) |
| 246 | (usable nil) | |
| 247 | (passive nil) | |
| 248 | (sos-pre? preset-sos) | |
| 249 | ;; (passive-pre? preset-passive) | |
| 250 | (put-goal-in-sos? nil)) | |
| 246 | (usable nil) | |
| 247 | (passive nil) | |
| 248 | (sos-pre? preset-sos) | |
| 249 | ;; (passive-pre? preset-passive) | |
| 250 | (put-goal-in-sos? nil)) | |
| 251 | 251 | (when (memq :system-goal preset-sos) |
| 252 | (setq preset-sos (delete :system-goal preset-sos :test #'eq)) | |
| 253 | (setq put-goal-in-sos? t)) | |
| 252 | (setq preset-sos (delete :system-goal preset-sos :test #'eq)) | |
| 253 | (setq put-goal-in-sos? t)) | |
| 254 | 254 | (dolist (cl (psystem-axioms psys)) |
| 255 | (cond ((eq (clause-axiom cl) goal) | |
| 256 | ;; generated goal | |
| 257 | (if put-goal-in-sos? | |
| 258 | (progn | |
| 259 | (setf (clause-container cl) :sos) | |
| 260 | (push cl sos)) | |
| 261 | ;; put the goal into usable | |
| 262 | (progn | |
| 263 | (setf (clause-container cl) :usable) | |
| 264 | (push cl usable))) | |
| 265 | ) | |
| 266 | ;; the following cases treat non-goal | |
| 267 | (sos-pre? | |
| 268 | (if (member cl preset-sos :test #'cl-member-test) | |
| 269 | (progn | |
| 270 | (setf (clause-container cl) :sos) | |
| 271 | (push cl sos)) | |
| 272 | (if (member cl preset-passive :test #'cl-member-test) | |
| 273 | (progn | |
| 274 | (setf (clause-container cl) :passive) | |
| 275 | (push cl passive)) | |
| 276 | (progn | |
| 277 | (setf (clause-container cl) :usable) | |
| 278 | (push cl usable))))) | |
| 279 | (t | |
| 280 | (if (member cl preset-passive :test #'cl-member-test) | |
| 281 | (progn | |
| 282 | (setf (clause-container cl) :passive) | |
| 283 | (push cl passive)) | |
| 284 | (if (positive-clause? cl) | |
| 285 | (progn | |
| 286 | (setf (clause-container cl) :sos) | |
| 287 | (push cl sos)) | |
| 288 | (progn | |
| 289 | (setf (clause-container cl) :usable) | |
| 290 | (push cl usable))))))) | |
| 255 | (cond ((eq (clause-axiom cl) goal) | |
| 256 | ;; generated goal | |
| 257 | (if put-goal-in-sos? | |
| 258 | (progn | |
| 259 | (setf (clause-container cl) :sos) | |
| 260 | (push cl sos)) | |
| 261 | ;; put the goal into usable | |
| 262 | (progn | |
| 263 | (setf (clause-container cl) :usable) | |
| 264 | (push cl usable))) | |
| 265 | ) | |
| 266 | ;; the following cases treat non-goal | |
| 267 | (sos-pre? | |
| 268 | (if (member cl preset-sos :test #'cl-member-test) | |
| 269 | (progn | |
| 270 | (setf (clause-container cl) :sos) | |
| 271 | (push cl sos)) | |
| 272 | (if (member cl preset-passive :test #'cl-member-test) | |
| 273 | (progn | |
| 274 | (setf (clause-container cl) :passive) | |
| 275 | (push cl passive)) | |
| 276 | (progn | |
| 277 | (setf (clause-container cl) :usable) | |
| 278 | (push cl usable))))) | |
| 279 | (t | |
| 280 | (if (member cl preset-passive :test #'cl-member-test) | |
| 281 | (progn | |
| 282 | (setf (clause-container cl) :passive) | |
| 283 | (push cl passive)) | |
| 284 | (if (positive-clause? cl) | |
| 285 | (progn | |
| 286 | (setf (clause-container cl) :sos) | |
| 287 | (push cl sos)) | |
| 288 | (progn | |
| 289 | (setf (clause-container cl) :usable) | |
| 290 | (push cl usable))))))) | |
| 291 | 291 | ;; |
| 292 | 292 | (setf (psystem-sos psys) (reverse sos)) |
| 293 | 293 | (setf (psystem-passive psys) (reverse passive)) |
| 299 | 299 | ;;; prepare run-time env of PigNose and invoke it. |
| 300 | 300 | ;;; |
| 301 | 301 | (defun perform-inv-check (module |
| 302 | predicate | |
| 303 | target-pat | |
| 304 | conditions | |
| 305 | additional-conds | |
| 306 | &key dont-negate | |
| 307 | type | |
| 308 | hole) | |
| 302 | predicate | |
| 303 | target-pat | |
| 304 | conditions | |
| 305 | additional-conds | |
| 306 | &key dont-negate | |
| 307 | type | |
| 308 | hole) | |
| 309 | 309 | (declare (type module module) |
| 310 | (type method predicate) | |
| 311 | (type term target-pat) | |
| 312 | (type list conditions) | |
| 313 | (values symbol)) | |
| 310 | (type method predicate) | |
| 311 | (type term target-pat) | |
| 312 | (type list conditions) | |
| 313 | (values symbol)) | |
| 314 | 314 | (let ((ret-code nil) |
| 315 | (preset-sos nil) | |
| 316 | (preset-passive nil) | |
| 317 | (*pn-no-db-reset* t) | |
| 318 | ) | |
| 315 | (preset-sos nil) | |
| 316 | (preset-passive nil) | |
| 317 | (*pn-no-db-reset* t) | |
| 318 | ) | |
| 319 | 319 | (declare (special *pn-no-db-reset*)) |
| 320 | 320 | (when (module-proof-system module) |
| 321 | 321 | (setq preset-sos (psystem-sos (module-proof-system module))) |
| 327 | 327 | (setf (module-op-lex *pn-proof-module*) (module-op-lex module)) |
| 328 | 328 | (with-in-module (*pn-proof-module*) |
| 329 | 329 | (let ((inv-check-pat nil) |
| 330 | (goal nil) | |
| 331 | (ax nil) | |
| 332 | (flags (save-pn-flags)) | |
| 333 | (parameters (save-pn-parameters))) | |
| 334 | ;; make goal | |
| 335 | (setq inv-check-pat | |
| 336 | (make-pn-inv-check-pat predicate | |
| 337 | target-pat | |
| 338 | :make-condition dont-negate | |
| 339 | :make-imply (if (and (eq type :from) | |
| 340 | hole) | |
| 341 | hole | |
| 342 | nil))) | |
| 343 | (setq goal | |
| 344 | (make-rule :lhs inv-check-pat | |
| 345 | :rhs *bool-true* | |
| 346 | :condition *bool-true* | |
| 347 | :labels nil | |
| 348 | :behavioural nil | |
| 349 | :type :pignose-axiom)) | |
| 350 | ||
| 351 | ;; NOTE: we may need ...................... | |
| 352 | ;; the goal is added as an axiom. | |
| 353 | (check-axiom-error-method *current-module* | |
| 354 | goal | |
| 355 | t) | |
| 356 | (add-axiom-to-module *current-module* goal) | |
| 357 | ||
| 358 | ;; pre conditions | |
| 359 | (dolist (a (append conditions additional-conds)) | |
| 360 | (setq ax | |
| 361 | (make-rule :lhs a | |
| 362 | :rhs *bool-true* | |
| 363 | :condition *bool-true* | |
| 364 | :labels nil | |
| 365 | :behavioural nil | |
| 366 | :type :pignose-axiom)) | |
| 367 | (check-axiom-error-method *current-module* | |
| 368 | ax | |
| 369 | t) | |
| 370 | (add-axiom-to-module *current-module* ax)) | |
| 371 | ||
| 372 | ;; | |
| 373 | (set-needs-rule) | |
| 374 | (compile-module *current-module*) | |
| 375 | ;; | |
| 376 | ;; invoke PigNose ////// | |
| 377 | ;; ...... | |
| 378 | (unless (or (pn-flag auto) | |
| 379 | (pn-flag auto2) | |
| 380 | (pn-flag auto3) | |
| 381 | (pn-flag binary-res) | |
| 382 | (pn-flag hyper-res) | |
| 383 | (pn-flag neg-hyper-res) | |
| 384 | (pn-flag para-from) | |
| 385 | (pn-flag para-into) | |
| 386 | (pn-flag demod-inf)) | |
| 387 | (with-output-simple-msg () | |
| 388 | (princ "** NO inference rules are specified.") | |
| 389 | (print-next) | |
| 390 | (princ "system will use `auto' mode.")) | |
| 391 | (setq preset-sos nil) | |
| 392 | ;; (setq preset-passive nil) | |
| 393 | (auto-change-flag auto t) | |
| 394 | (auto-change-flag universal-symmetry t)) | |
| 395 | ;; only interest the first proof | |
| 396 | (setf (pn-parameter max-proofs) 1) | |
| 397 | ;; | |
| 398 | (setup-inv-check-db *current-module* goal preset-sos preset-passive) | |
| 399 | ;; do resolve | |
| 400 | (setq ret-code (do-resolve *current-module*)) | |
| 401 | ;; restore flags¶meters | |
| 402 | (restore-pn-flags flags) | |
| 403 | (restore-pn-parameters parameters) | |
| 404 | )) | |
| 330 | (goal nil) | |
| 331 | (ax nil) | |
| 332 | (flags (save-pn-flags)) | |
| 333 | (parameters (save-pn-parameters))) | |
| 334 | ;; make goal | |
| 335 | (setq inv-check-pat | |
| 336 | (make-pn-inv-check-pat predicate | |
| 337 | target-pat | |
| 338 | :make-condition dont-negate | |
| 339 | :make-imply (if (and (eq type :from) | |
| 340 | hole) | |
| 341 | hole | |
| 342 | nil))) | |
| 343 | (setq goal | |
| 344 | (make-rule :lhs inv-check-pat | |
| 345 | :rhs *bool-true* | |
| 346 | :condition *bool-true* | |
| 347 | :labels nil | |
| 348 | :behavioural nil | |
| 349 | :type :pignose-axiom)) | |
| 350 | ||
| 351 | ;; NOTE: we may need ...................... | |
| 352 | ;; the goal is added as an axiom. | |
| 353 | (check-axiom-error-method *current-module* | |
| 354 | goal | |
| 355 | t) | |
| 356 | (add-axiom-to-module *current-module* goal) | |
| 357 | ||
| 358 | ;; pre conditions | |
| 359 | (dolist (a (append conditions additional-conds)) | |
| 360 | (setq ax | |
| 361 | (make-rule :lhs a | |
| 362 | :rhs *bool-true* | |
| 363 | :condition *bool-true* | |
| 364 | :labels nil | |
| 365 | :behavioural nil | |
| 366 | :type :pignose-axiom)) | |
| 367 | (check-axiom-error-method *current-module* | |
| 368 | ax | |
| 369 | t) | |
| 370 | (add-axiom-to-module *current-module* ax)) | |
| 371 | ||
| 372 | ;; | |
| 373 | (set-needs-rule) | |
| 374 | (compile-module *current-module*) | |
| 375 | ;; | |
| 376 | ;; invoke PigNose ////// | |
| 377 | ;; ...... | |
| 378 | (unless (or (pn-flag auto) | |
| 379 | (pn-flag auto2) | |
| 380 | (pn-flag auto3) | |
| 381 | (pn-flag binary-res) | |
| 382 | (pn-flag hyper-res) | |
| 383 | (pn-flag neg-hyper-res) | |
| 384 | (pn-flag para-from) | |
| 385 | (pn-flag para-into) | |
| 386 | (pn-flag demod-inf)) | |
| 387 | (with-output-simple-msg () | |
| 388 | (princ "** NO inference rules are specified.") | |
| 389 | (print-next) | |
| 390 | (princ "system will use `auto' mode.")) | |
| 391 | (setq preset-sos nil) | |
| 392 | ;; (setq preset-passive nil) | |
| 393 | (auto-change-flag auto t) | |
| 394 | (auto-change-flag universal-symmetry t)) | |
| 395 | ;; only interest the first proof | |
| 396 | (setf (pn-parameter max-proofs) 1) | |
| 397 | ;; | |
| 398 | (setup-inv-check-db *current-module* goal preset-sos preset-passive) | |
| 399 | ;; do resolve | |
| 400 | (setq ret-code (do-resolve *current-module*)) | |
| 401 | ;; restore flags¶meters | |
| 402 | (restore-pn-flags flags) | |
| 403 | (restore-pn-parameters parameters) | |
| 404 | )) | |
| 405 | 405 | ;; |
| 406 | 406 | ret-code )) |
| 407 | 407 | |
| 411 | 411 | ;;; |
| 412 | 412 | (defun do-invariance-check (check-sys type) |
| 413 | 413 | (let ((module (inv-check-system-module check-sys)) |
| 414 | (pred (inv-check-system-predicate check-sys)) | |
| 415 | (init-state (inv-check-system-initial-state check-sys)) | |
| 416 | (object (inv-check-system-object check-sys)) | |
| 417 | (sort (inv-check-system-sort check-sys)) | |
| 418 | (success nil) | |
| 419 | (skip-l (inv-check-system-after-loop check-sys)) | |
| 420 | (skip-num (inv-check-system-after-num check-sys))) | |
| 414 | (pred (inv-check-system-predicate check-sys)) | |
| 415 | (init-state (inv-check-system-initial-state check-sys)) | |
| 416 | (object (inv-check-system-object check-sys)) | |
| 417 | (sort (inv-check-system-sort check-sys)) | |
| 418 | (success nil) | |
| 419 | (skip-l (inv-check-system-after-loop check-sys)) | |
| 420 | (skip-num (inv-check-system-after-num check-sys))) | |
| 421 | 421 | (with-in-module (module) |
| 422 | 422 | (case type |
| 423 | ((:from :of) | |
| 424 | (let* ((ret-code nil) | |
| 425 | (loops -1) | |
| 426 | (max-loops (pn-parameter inv-check-max-depth)) | |
| 427 | (target-patterns nil) | |
| 428 | (fail nil) | |
| 429 | (next-goals nil) | |
| 430 | (failed-goals nil) | |
| 431 | (hole (make-variable-term sort | |
| 432 | (gensym "_hole"))) | |
| 433 | (subst-pat (list | |
| 434 | (cons hole | |
| 435 | (or object init-state)))) | |
| 436 | ||
| 437 | (do-skip nil) | |
| 438 | ) | |
| 439 | ;; set initial target pattern: | |
| 440 | ;; hole will be substituted by real target. | |
| 441 | (setf (inv-check-system-goals check-sys) | |
| 442 | (list hole)) | |
| 443 | ;; | |
| 444 | (catch 'inv-check-fail | |
| 445 | (loop | |
| 446 | (setq target-patterns (inv-check-system-goals check-sys)) | |
| 447 | (unless target-patterns | |
| 448 | ;; we've done without failure. | |
| 449 | (setq success t) | |
| 450 | (return)) | |
| 451 | ;; check depth limit | |
| 452 | (incf loops) | |
| 453 | (when (and (not (= -1 max-loops)) | |
| 454 | (> loops max-loops)) | |
| 455 | (with-output-msg () | |
| 456 | (format t "stopping invariance check due to `inv-check-max-depth'") | |
| 457 | (return nil))) | |
| 458 | ;; | |
| 459 | (let ((num 0) ; case # of current depth (loops). | |
| 460 | (cur-conditions nil) | |
| 461 | (cur-cond nil)) | |
| 462 | ;; initialy, cur-conditions contains all of the goals | |
| 463 | ;; to be checked for the current depth. | |
| 464 | (setq cur-conditions | |
| 465 | (mapcar #'(lambda (x) | |
| 466 | (apply-subst subst-pat x)) | |
| 467 | target-patterns)) | |
| 468 | (do* ((targets target-patterns (cdr targets)) | |
| 469 | (target-pat (car targets) (car targets)) | |
| 470 | (reals cur-conditions (cdr reals)) | |
| 471 | (real-target (car reals) (car reals)) | |
| 472 | (hypo-str nil nil)) | |
| 473 | ((endp targets)) | |
| 474 | ;; all not-yet tested goals are used for additional | |
| 475 | ;; hypothesis of the current goal,i.e. real-target. | |
| 476 | (setq cur-conditions (remove real-target cur-conditions)) | |
| 477 | (setq cur-cond | |
| 478 | (mapcar #'(lambda (x) | |
| 479 | (multiple-value-bind (pat pat-str) | |
| 480 | (make-pn-inv-check-pat pred | |
| 481 | x | |
| 482 | :make-condition "hypo" | |
| 483 | :print-msg "" | |
| 484 | :make-imply nil) | |
| 485 | (push pat-str hypo-str) | |
| 486 | pat)) | |
| 487 | cur-conditions)) | |
| 488 | ;; print start message | |
| 489 | (let ((*standard-output* *error-output*)) | |
| 490 | (format t "~%==========") | |
| 491 | (format t "~%case #~d-~d: " loops (incf num)) | |
| 492 | (term-print real-target) | |
| 493 | (format t "~%----------") | |
| 494 | ;; | |
| 495 | #|| | |
| 496 | (with-output-simple-msg () | |
| 497 | (format t "loops=~a, num=~a, skip-l=~a, skip-num=~a" | |
| 498 | loops num skip-l skip-num)) | |
| 499 | ||# | |
| 500 | ;; | |
| 501 | (if (or (< loops skip-l) | |
| 502 | (and (= loops skip-l) | |
| 503 | (< num skip-num))) | |
| 504 | (with-output-simple-msg () | |
| 505 | (format t "** will skip real proof") | |
| 506 | (setq do-skip t)) | |
| 507 | (setq do-skip nil)) | |
| 508 | ||
| 509 | #|| | |
| 510 | (dolist (c cur-conditions) | |
| 511 | (terpri) | |
| 512 | (princ "hypo: ") | |
| 513 | (let ((*print-indent* 7)) | |
| 514 | (term-print c))) | |
| 515 | ||# | |
| 516 | (dolist (pst (reverse hypo-str)) | |
| 517 | (princ pst)) | |
| 518 | ) | |
| 519 | ;; do the check | |
| 520 | (setq ret-code | |
| 521 | (if do-skip | |
| 522 | :skip-exit | |
| 523 | (perform-inv-check module | |
| 524 | pred | |
| 525 | real-target | |
| 526 | ;; previous | |
| 527 | (inv-check-system-conditions check-sys) | |
| 528 | ;; current | |
| 529 | cur-cond | |
| 530 | :hole hole | |
| 531 | :type (if (zerop loops) | |
| 532 | :of | |
| 533 | type))) | |
| 534 | ) | |
| 535 | ||
| 536 | ;; | |
| 537 | (when (eq type :from) | |
| 538 | (setq subst-pat nil)) | |
| 539 | ;; | |
| 540 | (let ((*standard-output* *error-output*)) | |
| 541 | (if (eq ret-code :max-proofs-exit) | |
| 542 | ;; success | |
| 543 | (progn | |
| 544 | (when (zerop loops) | |
| 545 | (push (if (eq type :from) | |
| 546 | (make-variable-term sort (gensym "_KV")) | |
| 547 | target-pat) | |
| 548 | next-goals)) | |
| 549 | (format t "~%** success")) | |
| 550 | ;; fail | |
| 551 | (progn | |
| 552 | (if do-skip | |
| 553 | (format t "~%** SKIPPING...") | |
| 554 | (format t "~%** fail")) | |
| 555 | (setq fail t) | |
| 556 | ;; reachability check from intial state | |
| 557 | (when (and init-state | |
| 558 | (eq type :of) | |
| 559 | (or (not do-skip) | |
| 560 | (pn-flag check-init-always))) | |
| 561 | (let ((target (apply-subst (list (cons hole init-state)) | |
| 562 | target-pat))) | |
| 563 | (terpri) | |
| 564 | (princ "** check with the initial state : ") | |
| 565 | (term-print target) | |
| 566 | (setq ret-code | |
| 567 | (perform-inv-check module | |
| 568 | pred | |
| 569 | target | |
| 570 | (inv-check-system-conditions | |
| 571 | check-sys) | |
| 572 | cur-cond | |
| 573 | :type type)) | |
| 574 | (unless (eq :max-proofs-exit ret-code) | |
| 575 | (with-output-simple-msg () | |
| 576 | (princ "** fail!") | |
| 577 | (print-next) | |
| 578 | (princ "trying to find a counter example: ")) | |
| 579 | ;; | |
| 580 | (setq ret-code | |
| 581 | (perform-inv-check module | |
| 582 | pred | |
| 583 | target | |
| 584 | (inv-check-system-conditions | |
| 585 | check-sys) | |
| 586 | cur-cond | |
| 587 | :type type | |
| 588 | :dont-negate "ax") | |
| 589 | ) | |
| 590 | (when (eq :max-proofs-exit ret-code) | |
| 591 | (with-output-simple-msg () | |
| 592 | (princ "** found a counter example!") | |
| 593 | (print-next) | |
| 594 | (princ "initial state can reach to a hazardous state.") | |
| 595 | )) | |
| 596 | (setq success nil) | |
| 597 | (throw 'inv-check-fail nil) | |
| 598 | ) | |
| 599 | (with-output-simple-msg () | |
| 600 | (princ "** ok, it's safe.")) | |
| 601 | )) | |
| 602 | ||
| 603 | ;; next-goals accumurates base context patterns | |
| 604 | ;; for generating goals of the next loop (depth). | |
| 605 | (push target-pat next-goals) | |
| 606 | ;; put the failed goal back to condition | |
| 607 | ;; this will be used as hyphthesis of the | |
| 608 | ;; next goal (sibling). | |
| 609 | (push real-target cur-conditions) | |
| 610 | ) | |
| 611 | )) | |
| 612 | ) | |
| 613 | ;; end for all current target,i.e., the current depth. | |
| 614 | (if (or fail (zerop loops)) | |
| 615 | ;; found at least one failure case, or we've just done | |
| 616 | ;; for initial base case. | |
| 617 | (progn | |
| 618 | (setq next-goals (nreverse next-goals)) | |
| 619 | (setq failed-goals (nconc failed-goals next-goals)) | |
| 620 | (setf (inv-check-system-goals check-sys) | |
| 621 | (make-inv-check-contexts (inv-check-system-methods | |
| 622 | check-sys) | |
| 623 | hole | |
| 624 | next-goals)) | |
| 625 | (setf (inv-check-system-conditions check-sys) | |
| 626 | (nconc (inv-check-system-conditions check-sys) | |
| 627 | (mapcar | |
| 628 | #'(lambda (x) | |
| 629 | (make-pn-inv-check-pat pred | |
| 630 | x | |
| 631 | :make-condition | |
| 632 | "adding axiom" | |
| 633 | :print-msg *error-output* | |
| 634 | :make-imply nil)) | |
| 635 | cur-conditions))) | |
| 636 | ) | |
| 637 | ;; success | |
| 638 | (setf (inv-check-system-goals check-sys) nil)) | |
| 639 | ;; | |
| 640 | (setq next-goals nil) | |
| 641 | ) ; done for this level | |
| 642 | ;; | |
| 643 | ) ; done for all | |
| 644 | ) | |
| 645 | ;; | |
| 646 | #|| | |
| 647 | (when (and success (eq type :of) init-state) | |
| 648 | ;; we must check reachability | |
| 649 | (setq success nil) | |
| 650 | (let ((*standard-output* *error-output*)) | |
| 651 | (format t "~%==============================") | |
| 652 | (format t "~%** start reachability check **") | |
| 653 | (format t "~%------------------------------")) | |
| 654 | (dolist (pat failed-goals (setq success t)) | |
| 655 | (let ((target (apply-subst (list (cons hole init-state)) | |
| 656 | pat))) | |
| 657 | (setq ret-code | |
| 658 | (perform-inv-check module | |
| 659 | pred | |
| 660 | target | |
| 661 | (inv-check-system-conditions check-sys) | |
| 662 | nil)) | |
| 663 | (let ((*standard-output* *error-output*)) | |
| 664 | (if (eq ret-code :max-proofs-exit) | |
| 665 | (format t "~%*** success") | |
| 666 | (progn | |
| 667 | (format t "~%** fail") | |
| 668 | (return nil)))))) | |
| 669 | ) | |
| 670 | ||# | |
| 671 | ;; | |
| 672 | (unless success | |
| 673 | (if .pn-check-safety. | |
| 674 | (format *error-output* | |
| 675 | "~%** Failed to prove safety of ~{~a~}.~% ~%" | |
| 676 | (method-symbol pred)) | |
| 677 | (format *error-output* | |
| 678 | "~%** Failed to prove ~{~a~} is invariant.~% ~%" | |
| 679 | (method-symbol pred))) | |
| 680 | (return-from do-invariance-check nil)) | |
| 681 | ;; success!! | |
| 682 | (if .pn-check-safety. | |
| 683 | (format *error-output* | |
| 684 | "~%** Predicate ~{~a~} is safe!!~% ~%" | |
| 685 | (method-symbol pred)) | |
| 686 | (format *error-output* | |
| 687 | "~%** Predicate ~{~a~} is invriant!!~% ~%" | |
| 688 | (method-symbol pred))) | |
| 689 | t | |
| 690 | )) | |
| 691 | ;; | |
| 692 | (otherwise | |
| 693 | ;; TODO | |
| 694 | ) | |
| 695 | ) | |
| 423 | ((:from :of) | |
| 424 | (let* ((ret-code nil) | |
| 425 | (loops -1) | |
| 426 | (max-loops (pn-parameter inv-check-max-depth)) | |
| 427 | (target-patterns nil) | |
| 428 | (fail nil) | |
| 429 | (next-goals nil) | |
| 430 | (failed-goals nil) | |
| 431 | (hole (make-variable-term sort | |
| 432 | (gensym "_hole"))) | |
| 433 | (subst-pat (list | |
| 434 | (cons hole | |
| 435 | (or object init-state)))) | |
| 436 | ||
| 437 | (do-skip nil) | |
| 438 | ) | |
| 439 | ;; set initial target pattern: | |
| 440 | ;; hole will be substituted by real target. | |
| 441 | (setf (inv-check-system-goals check-sys) | |
| 442 | (list hole)) | |
| 443 | ;; | |
| 444 | (catch 'inv-check-fail | |
| 445 | (loop | |
| 446 | (setq target-patterns (inv-check-system-goals check-sys)) | |
| 447 | (unless target-patterns | |
| 448 | ;; we've done without failure. | |
| 449 | (setq success t) | |
| 450 | (return)) | |
| 451 | ;; check depth limit | |
| 452 | (incf loops) | |
| 453 | (when (and (not (= -1 max-loops)) | |
| 454 | (> loops max-loops)) | |
| 455 | (with-output-msg () | |
| 456 | (format t "stopping invariance check due to `inv-check-max-depth'") | |
| 457 | (return nil))) | |
| 458 | ;; | |
| 459 | (let ((num 0) ; case # of current depth (loops). | |
| 460 | (cur-conditions nil) | |
| 461 | (cur-cond nil)) | |
| 462 | ;; initialy, cur-conditions contains all of the goals | |
| 463 | ;; to be checked for the current depth. | |
| 464 | (setq cur-conditions | |
| 465 | (mapcar #'(lambda (x) | |
| 466 | (apply-subst subst-pat x)) | |
| 467 | target-patterns)) | |
| 468 | (do* ((targets target-patterns (cdr targets)) | |
| 469 | (target-pat (car targets) (car targets)) | |
| 470 | (reals cur-conditions (cdr reals)) | |
| 471 | (real-target (car reals) (car reals)) | |
| 472 | (hypo-str nil nil)) | |
| 473 | ((endp targets)) | |
| 474 | ;; all not-yet tested goals are used for additional | |
| 475 | ;; hypothesis of the current goal,i.e. real-target. | |
| 476 | (setq cur-conditions (remove real-target cur-conditions)) | |
| 477 | (setq cur-cond | |
| 478 | (mapcar #'(lambda (x) | |
| 479 | (multiple-value-bind (pat pat-str) | |
| 480 | (make-pn-inv-check-pat pred | |
| 481 | x | |
| 482 | :make-condition "hypo" | |
| 483 | :print-msg "" | |
| 484 | :make-imply nil) | |
| 485 | (push pat-str hypo-str) | |
| 486 | pat)) | |
| 487 | cur-conditions)) | |
| 488 | ;; print start message | |
| 489 | (let ((*standard-output* *error-output*)) | |
| 490 | (format t "~%==========") | |
| 491 | (format t "~%case #~d-~d: " loops (incf num)) | |
| 492 | (term-print real-target) | |
| 493 | (format t "~%----------") | |
| 494 | ;; | |
| 495 | #|| | |
| 496 | (with-output-simple-msg () | |
| 497 | (format t "loops=~a, num=~a, skip-l=~a, skip-num=~a" | |
| 498 | loops num skip-l skip-num)) | |
| 499 | ||# | |
| 500 | ;; | |
| 501 | (if (or (< loops skip-l) | |
| 502 | (and (= loops skip-l) | |
| 503 | (< num skip-num))) | |
| 504 | (with-output-simple-msg () | |
| 505 | (format t "** will skip real proof") | |
| 506 | (setq do-skip t)) | |
| 507 | (setq do-skip nil)) | |
| 508 | ||
| 509 | #|| | |
| 510 | (dolist (c cur-conditions) | |
| 511 | (terpri) | |
| 512 | (princ "hypo: ") | |
| 513 | (let ((*print-indent* 7)) | |
| 514 | (term-print c))) | |
| 515 | ||# | |
| 516 | (dolist (pst (reverse hypo-str)) | |
| 517 | (princ pst)) | |
| 518 | ) | |
| 519 | ;; do the check | |
| 520 | (setq ret-code | |
| 521 | (if do-skip | |
| 522 | :skip-exit | |
| 523 | (perform-inv-check module | |
| 524 | pred | |
| 525 | real-target | |
| 526 | ;; previous | |
| 527 | (inv-check-system-conditions check-sys) | |
| 528 | ;; current | |
| 529 | cur-cond | |
| 530 | :hole hole | |
| 531 | :type (if (zerop loops) | |
| 532 | :of | |
| 533 | type))) | |
| 534 | ) | |
| 535 | ||
| 536 | ;; | |
| 537 | (when (eq type :from) | |
| 538 | (setq subst-pat nil)) | |
| 539 | ;; | |
| 540 | (let ((*standard-output* *error-output*)) | |
| 541 | (if (eq ret-code :max-proofs-exit) | |
| 542 | ;; success | |
| 543 | (progn | |
| 544 | (when (zerop loops) | |
| 545 | (push (if (eq type :from) | |
| 546 | (make-variable-term sort (gensym "_KV")) | |
| 547 | target-pat) | |
| 548 | next-goals)) | |
| 549 | (format t "~%** success")) | |
| 550 | ;; fail | |
| 551 | (progn | |
| 552 | (if do-skip | |
| 553 | (format t "~%** SKIPPING...") | |
| 554 | (format t "~%** fail")) | |
| 555 | (setq fail t) | |
| 556 | ;; reachability check from intial state | |
| 557 | (when (and init-state | |
| 558 | (eq type :of) | |
| 559 | (or (not do-skip) | |
| 560 | (pn-flag check-init-always))) | |
| 561 | (let ((target (apply-subst (list (cons hole init-state)) | |
| 562 | target-pat))) | |
| 563 | (terpri) | |
| 564 | (princ "** check with the initial state : ") | |
| 565 | (term-print target) | |
| 566 | (setq ret-code | |
| 567 | (perform-inv-check module | |
| 568 | pred | |
| 569 | target | |
| 570 | (inv-check-system-conditions | |
| 571 | check-sys) | |
| 572 | cur-cond | |
| 573 | :type type)) | |
| 574 | (unless (eq :max-proofs-exit ret-code) | |
| 575 | (with-output-simple-msg () | |
| 576 | (princ "** fail!") | |
| 577 | (print-next) | |
| 578 | (princ "trying to find a counter example: ")) | |
| 579 | ;; | |
| 580 | (setq ret-code | |
| 581 | (perform-inv-check module | |
| 582 | pred | |
| 583 | target | |
| 584 | (inv-check-system-conditions | |
| 585 | check-sys) | |
| 586 | cur-cond | |
| 587 | :type type | |
| 588 | :dont-negate "ax") | |
| 589 | ) | |
| 590 | (when (eq :max-proofs-exit ret-code) | |
| 591 | (with-output-simple-msg () | |
| 592 | (princ "** found a counter example!") | |
| 593 | (print-next) | |
| 594 | (princ "initial state can reach to a hazardous state.") | |
| 595 | )) | |
| 596 | (setq success nil) | |
| 597 | (throw 'inv-check-fail nil) | |
| 598 | ) | |
| 599 | (with-output-simple-msg () | |
| 600 | (princ "** ok, it's safe.")) | |
| 601 | )) | |
| 602 | ||
| 603 | ;; next-goals accumurates base context patterns | |
| 604 | ;; for generating goals of the next loop (depth). | |
| 605 | (push target-pat next-goals) | |
| 606 | ;; put the failed goal back to condition | |
| 607 | ;; this will be used as hyphthesis of the | |
| 608 | ;; next goal (sibling). | |
| 609 | (push real-target cur-conditions) | |
| 610 | ) | |
| 611 | )) | |
| 612 | ) | |
| 613 | ;; end for all current target,i.e., the current depth. | |
| 614 | (if (or fail (zerop loops)) | |
| 615 | ;; found at least one failure case, or we've just done | |
| 616 | ;; for initial base case. | |
| 617 | (progn | |
| 618 | (setq next-goals (nreverse next-goals)) | |
| 619 | (setq failed-goals (nconc failed-goals next-goals)) | |
| 620 | (setf (inv-check-system-goals check-sys) | |
| 621 | (make-inv-check-contexts (inv-check-system-methods | |
| 622 | check-sys) | |
| 623 | hole | |
| 624 | next-goals)) | |
| 625 | (setf (inv-check-system-conditions check-sys) | |
| 626 | (nconc (inv-check-system-conditions check-sys) | |
| 627 | (mapcar | |
| 628 | #'(lambda (x) | |
| 629 | (make-pn-inv-check-pat pred | |
| 630 | x | |
| 631 | :make-condition | |
| 632 | "adding axiom" | |
| 633 | :print-msg *error-output* | |
| 634 | :make-imply nil)) | |
| 635 | cur-conditions))) | |
| 636 | ) | |
| 637 | ;; success | |
| 638 | (setf (inv-check-system-goals check-sys) nil)) | |
| 639 | ;; | |
| 640 | (setq next-goals nil) | |
| 641 | ) ; done for this level | |
| 642 | ;; | |
| 643 | ) ; done for all | |
| 644 | ) | |
| 645 | ;; | |
| 646 | #|| | |
| 647 | (when (and success (eq type :of) init-state) | |
| 648 | ;; we must check reachability | |
| 649 | (setq success nil) | |
| 650 | (let ((*standard-output* *error-output*)) | |
| 651 | (format t "~%==============================") | |
| 652 | (format t "~%** start reachability check **") | |
| 653 | (format t "~%------------------------------")) | |
| 654 | (dolist (pat failed-goals (setq success t)) | |
| 655 | (let ((target (apply-subst (list (cons hole init-state)) | |
| 656 | pat))) | |
| 657 | (setq ret-code | |
| 658 | (perform-inv-check module | |
| 659 | pred | |
| 660 | target | |
| 661 | (inv-check-system-conditions check-sys) | |
| 662 | nil)) | |
| 663 | (let ((*standard-output* *error-output*)) | |
| 664 | (if (eq ret-code :max-proofs-exit) | |
| 665 | (format t "~%*** success") | |
| 666 | (progn | |
| 667 | (format t "~%** fail") | |
| 668 | (return nil)))))) | |
| 669 | ) | |
| 670 | ||# | |
| 671 | ;; | |
| 672 | (unless success | |
| 673 | (if .pn-check-safety. | |
| 674 | (format *error-output* | |
| 675 | "~%** Failed to prove safety of ~{~a~}.~% ~%" | |
| 676 | (method-symbol pred)) | |
| 677 | (format *error-output* | |
| 678 | "~%** Failed to prove ~{~a~} is invariant.~% ~%" | |
| 679 | (method-symbol pred))) | |
| 680 | (return-from do-invariance-check nil)) | |
| 681 | ;; success!! | |
| 682 | (if .pn-check-safety. | |
| 683 | (format *error-output* | |
| 684 | "~%** Predicate ~{~a~} is safe!!~% ~%" | |
| 685 | (method-symbol pred)) | |
| 686 | (format *error-output* | |
| 687 | "~%** Predicate ~{~a~} is invriant!!~% ~%" | |
| 688 | (method-symbol pred))) | |
| 689 | t | |
| 690 | )) | |
| 691 | ;; | |
| 692 | (otherwise | |
| 693 | ;; TODO | |
| 694 | ) | |
| 695 | ) | |
| 696 | 696 | ) |
| 697 | 697 | )) |
| 698 | 698 | |
| 702 | 702 | (defun parse-pn-check-command (args) |
| 703 | 703 | (declare (type list args)) |
| 704 | 704 | (let ((pred-name nil) |
| 705 | (type nil) | |
| 706 | (init-name nil) | |
| 707 | (object-pat nil) | |
| 708 | (loop-after 0) | |
| 709 | (loop-after-sub 0) | |
| 710 | (args-list args) | |
| 711 | (e nil)) | |
| 705 | (type nil) | |
| 706 | (init-name nil) | |
| 707 | (object-pat nil) | |
| 708 | (loop-after 0) | |
| 709 | (loop-after-sub 0) | |
| 710 | (args-list args) | |
| 711 | (e nil)) | |
| 712 | 712 | ;; get predicate-name |
| 713 | 713 | (loop |
| 714 | 714 | (unless args-list (return nil)) |
| 715 | 715 | (setq e (pop args-list)) |
| 716 | 716 | (when (member e '("of" "from" "with" "after" |
| 717 | ":of" ":from" ":with" ":after") | |
| 718 | :test #'equal) | |
| 719 | (return nil)) | |
| 717 | ":of" ":from" ":with" ":after") | |
| 718 | :test #'equal) | |
| 719 | (return nil)) | |
| 720 | 720 | (push e pred-name)) |
| 721 | 721 | ;; get object pattern if any |
| 722 | 722 | (when (member e '("of" ":of") :test #'equal) |
| 723 | 723 | (setq type :of) |
| 724 | 724 | (loop |
| 725 | (unless args-list (return nil)) | |
| 726 | (setq e (pop args-list)) | |
| 727 | (when (member e '("from" "with" "after" | |
| 728 | ":from" ":with" ":after") | |
| 729 | :test #'equal) | |
| 730 | (return nil)) | |
| 731 | (push e object-pat))) | |
| 725 | (unless args-list (return nil)) | |
| 726 | (setq e (pop args-list)) | |
| 727 | (when (member e '("from" "with" "after" | |
| 728 | ":from" ":with" ":after") | |
| 729 | :test #'equal) | |
| 730 | (return nil)) | |
| 731 | (push e object-pat))) | |
| 732 | 732 | ;; get initial pattern or target pattern if any. |
| 733 | 733 | (unless type |
| 734 | 734 | (when (member e '("from" ":from") :test #'equal) |
| 735 | (setq type :from)) | |
| 735 | (setq type :from)) | |
| 736 | 736 | (when (member e '("with" ":with") :test #'equal) |
| 737 | (setq type :with))) | |
| 737 | (setq type :with))) | |
| 738 | 738 | (when (member e '(":from" ":with" "from" "with") |
| 739 | :test #'equal) | |
| 739 | :test #'equal) | |
| 740 | 740 | (loop |
| 741 | (unless args-list (return nil)) | |
| 742 | (setq e (pop args-list)) | |
| 743 | (when (member e '("after" ":after") :test #'equal) | |
| 744 | (return nil)) | |
| 745 | (push e init-name))) | |
| 741 | (unless args-list (return nil)) | |
| 742 | (setq e (pop args-list)) | |
| 743 | (when (member e '("after" ":after") :test #'equal) | |
| 744 | (return nil)) | |
| 745 | (push e init-name))) | |
| 746 | 746 | (when (member e '("after" ":after") :test #'equal) |
| 747 | 747 | (let ((pos 0)) |
| 748 | (setq e (pop args-list)) | |
| 749 | (multiple-value-setq (loop-after pos) | |
| 750 | (parse-integer e :junk-allowed t)) | |
| 751 | (unless (integerp loop-after) | |
| 752 | (with-output-chaos-error ('invalid-arg) | |
| 753 | (format t "invalid `after' agument : ~s" e))) | |
| 754 | (if (and (< pos (length e))) | |
| 755 | (progn | |
| 756 | (setq e (subseq e (1+ pos))) | |
| 757 | (setq loop-after-sub (read-from-string e)) | |
| 758 | (unless (integerp loop-after-sub) | |
| 759 | (format t "invalid `after' argument : ~s" e))) | |
| 760 | (setq loop-after-sub 1)) | |
| 761 | )) | |
| 748 | (setq e (pop args-list)) | |
| 749 | (multiple-value-setq (loop-after pos) | |
| 750 | (parse-integer e :junk-allowed t)) | |
| 751 | (unless (integerp loop-after) | |
| 752 | (with-output-chaos-error ('invalid-arg) | |
| 753 | (format t "invalid `after' agument : ~s" e))) | |
| 754 | (if (and (< pos (length e))) | |
| 755 | (progn | |
| 756 | (setq e (subseq e (1+ pos))) | |
| 757 | (setq loop-after-sub (read-from-string e)) | |
| 758 | (unless (integerp loop-after-sub) | |
| 759 | (format t "invalid `after' argument : ~s" e))) | |
| 760 | (setq loop-after-sub 1)) | |
| 761 | )) | |
| 762 | 762 | (values (nreverse pred-name) |
| 763 | (nreverse object-pat) | |
| 764 | (nreverse init-name) | |
| 765 | loop-after | |
| 766 | loop-after-sub | |
| 767 | type) | |
| 763 | (nreverse object-pat) | |
| 764 | (nreverse init-name) | |
| 765 | loop-after | |
| 766 | loop-after-sub | |
| 767 | type) | |
| 768 | 768 | )) |
| 769 | 769 | |
| 770 | 770 | |
| 771 | 771 | (defun pn-check-invariance (args) |
| 772 | 772 | (declare (type list args)) |
| 773 | (let ((target-module (or *current-module* | |
| 774 | *last-module*))) | |
| 775 | (declare (type (or null module) target-module)) | |
| 776 | (unless target-module | |
| 777 | (with-output-chaos-error ('no-context) | |
| 778 | (princ "check invariance: no context module is specified!"))) | |
| 779 | ;; | |
| 773 | (let ((target-module (get-context-module))) | |
| 774 | (declare (type module target-module)) | |
| 780 | 775 | (compile-module target-module) |
| 781 | 776 | (multiple-value-bind (pred-name object-pat init-name loop-after |
| 782 | loop-after-sub | |
| 783 | type) | |
| 784 | (parse-pn-check-command args) | |
| 777 | loop-after-sub | |
| 778 | type) | |
| 779 | (parse-pn-check-command args) | |
| 785 | 780 | (unless (and pred-name type (or init-name object-pat)) |
| 786 | (with-output-chaos-error ('invalid-args) | |
| 787 | (format t "insufficient args for check : ~{~s~}" args))) | |
| 781 | (with-output-chaos-error ('invalid-args) | |
| 782 | (format t "insufficient args for check : ~{~s~}" args))) | |
| 788 | 783 | (let ((predicate (pn-get-meth-unique target-module |
| 789 | pred-name)) | |
| 790 | (init-method (if init-name | |
| 791 | (pn-get-meth-unique target-module | |
| 792 | init-name) | |
| 793 | nil)) | |
| 794 | (object (if object-pat | |
| 795 | (simple-parse target-module object-pat) | |
| 796 | nil)) | |
| 797 | (hsort nil) | |
| 798 | (check-sys nil)) | |
| 799 | (declare (type fixnum loop-after loop-after-sub)) | |
| 800 | ;; | |
| 801 | (unless (sort= (method-coarity predicate) | |
| 802 | *bool-sort*) | |
| 803 | (with-output-chaos-error ('invalid-op) | |
| 804 | (princ "operator is not a predicate:") | |
| 805 | (print-chaos-object predicate))) | |
| 806 | (when init-method | |
| 807 | (unless (sort-is-hidden (method-coarity init-method)) | |
| 808 | (with-output-chaos-error ('ivalid-op) | |
| 809 | (princ "the value of operator ") | |
| 810 | (print-chaos-object init-method) | |
| 811 | (print-next) | |
| 812 | (princ "is not hidden sort, only hidden valued oprators are meaningful.") | |
| 813 | ))) | |
| 814 | ;; | |
| 815 | (when (and object (term-ill-defined object)) | |
| 816 | (return-from pn-check-invariance nil)) | |
| 817 | ;; | |
| 818 | (when init-method | |
| 819 | (unless (member (method-coarity init-method) | |
| 820 | (method-arity predicate)) | |
| 821 | (with-output-chaos-error ('invalid-op) | |
| 822 | (princ "given predicate and operator don't match.")))) | |
| 823 | ;; | |
| 824 | (when (and init-method object) | |
| 825 | (unless (eq (method-coarity init-method) | |
| 826 | (method-coarity (term-head object))) | |
| 827 | (with-output-chaos-error ('invalid-pat) | |
| 828 | (princ "given pattern does not match with init value.") | |
| 829 | (print-next) | |
| 830 | (princ "init value : ")(print-chaos-object init-method) | |
| 831 | (print-next) | |
| 832 | (princ "pattern : ")(term-print object)))) | |
| 833 | ;; | |
| 834 | (setq hsort | |
| 835 | (if init-method | |
| 836 | (method-coarity init-method) | |
| 837 | (method-coarity (term-head object)))) | |
| 838 | ;; | |
| 839 | ;; prepare initial inv-check-system | |
| 840 | ;; | |
| 841 | (setq check-sys | |
| 842 | (make-inv-check-system | |
| 843 | :module target-module | |
| 844 | :sort hsort | |
| 845 | :predicate predicate | |
| 846 | :initial-state (if init-method | |
| 847 | (make-term-pat init-method) | |
| 848 | nil) | |
| 849 | :object object | |
| 850 | :after-loop loop-after | |
| 851 | :after-num loop-after-sub)) | |
| 852 | ;; | |
| 853 | (setf (inv-check-system-methods check-sys) | |
| 854 | (nreverse | |
| 855 | (remove-if-not #'(lambda (x) | |
| 856 | (sort= hsort (method-coarity x))) | |
| 857 | (module-beh-methods target-module)))) | |
| 858 | ;; | |
| 859 | ;; do check | |
| 860 | ;; | |
| 861 | (let ((start-time (get-internal-real-time)) | |
| 862 | (grand-total "")) | |
| 863 | (declare (type integer start-time) | |
| 864 | (type simple-string grand-total)) | |
| 865 | ;; | |
| 866 | (do-invariance-check check-sys type) | |
| 867 | ;; | |
| 868 | (setq grand-total | |
| 869 | (format nil "~,3f sec" | |
| 870 | (elapsed-time-in-seconds start-time | |
| 871 | (get-internal-real-time)))) | |
| 872 | (unless *chaos-quiet* | |
| 873 | (when (pn-flag print-stats) | |
| 874 | (with-output-simple-msg () | |
| 875 | (format t "(grand total time ~a)" grand-total))))))))) | |
| 784 | pred-name)) | |
| 785 | (init-method (if init-name | |
| 786 | (pn-get-meth-unique target-module | |
| 787 | init-name) | |
| 788 | nil)) | |
| 789 | (object (if object-pat | |
| 790 | (simple-parse target-module object-pat) | |
| 791 | nil)) | |
| 792 | (hsort nil) | |
| 793 | (check-sys nil)) | |
| 794 | (declare (type fixnum loop-after loop-after-sub)) | |
| 795 | ;; | |
| 796 | (unless (sort= (method-coarity predicate) | |
| 797 | *bool-sort*) | |
| 798 | (with-output-chaos-error ('invalid-op) | |
| 799 | (princ "operator is not a predicate:") | |
| 800 | (print-chaos-object predicate))) | |
| 801 | (when init-method | |
| 802 | (unless (sort-is-hidden (method-coarity init-method)) | |
| 803 | (with-output-chaos-error ('ivalid-op) | |
| 804 | (princ "the value of operator ") | |
| 805 | (print-chaos-object init-method) | |
| 806 | (print-next) | |
| 807 | (princ "is not hidden sort, only hidden valued oprators are meaningful.") | |
| 808 | ))) | |
| 809 | ;; | |
| 810 | (when (and object (term-ill-defined object)) | |
| 811 | (return-from pn-check-invariance nil)) | |
| 812 | ;; | |
| 813 | (when init-method | |
| 814 | (unless (member (method-coarity init-method) | |
| 815 | (method-arity predicate)) | |
| 816 | (with-output-chaos-error ('invalid-op) | |
| 817 | (princ "given predicate and operator don't match.")))) | |
| 818 | ;; | |
| 819 | (when (and init-method object) | |
| 820 | (unless (eq (method-coarity init-method) | |
| 821 | (method-coarity (term-head object))) | |
| 822 | (with-output-chaos-error ('invalid-pat) | |
| 823 | (princ "given pattern does not match with init value.") | |
| 824 | (print-next) | |
| 825 | (princ "init value : ")(print-chaos-object init-method) | |
| 826 | (print-next) | |
| 827 | (princ "pattern : ")(term-print object)))) | |
| 828 | ;; | |
| 829 | (setq hsort | |
| 830 | (if init-method | |
| 831 | (method-coarity init-method) | |
| 832 | (method-coarity (term-head object)))) | |
| 833 | ;; | |
| 834 | ;; prepare initial inv-check-system | |
| 835 | ;; | |
| 836 | (setq check-sys | |
| 837 | (make-inv-check-system | |
| 838 | :module target-module | |
| 839 | :sort hsort | |
| 840 | :predicate predicate | |
| 841 | :initial-state (if init-method | |
| 842 | (make-term-pat init-method) | |
| 843 | nil) | |
| 844 | :object object | |
| 845 | :after-loop loop-after | |
| 846 | :after-num loop-after-sub)) | |
| 847 | ;; | |
| 848 | (setf (inv-check-system-methods check-sys) | |
| 849 | (nreverse | |
| 850 | (remove-if-not #'(lambda (x) | |
| 851 | (sort= hsort (method-coarity x))) | |
| 852 | (module-beh-methods target-module)))) | |
| 853 | ;; | |
| 854 | ;; do check | |
| 855 | ;; | |
| 856 | (let ((start-time (get-internal-real-time)) | |
| 857 | (grand-total "")) | |
| 858 | (declare (type integer start-time) | |
| 859 | (type simple-string grand-total)) | |
| 860 | ;; | |
| 861 | (do-invariance-check check-sys type) | |
| 862 | ;; | |
| 863 | (setq grand-total | |
| 864 | (format nil "~,3f sec" | |
| 865 | (elapsed-time-in-seconds start-time | |
| 866 | (get-internal-real-time)))) | |
| 867 | (unless *chaos-quiet* | |
| 868 | (when (pn-flag print-stats) | |
| 869 | (with-output-simple-msg () | |
| 870 | (format t "(grand total time ~a)" grand-total))))))))) | |
| 876 | 871 | |
| 877 | 872 | ;;; PN-CHECK-SAFETY |
| 878 | 873 | ;;; |
| 0 | 0 | ;;;-*-Mode:LISP; Package: CHAOS; Base:10; Syntax:Common-lisp -*- |
| 1 | 1 | ;;; |
| 2 | ;;; Copyright (c) 2000-2014, Toshimi Sawada. All rights reserved. | |
| 2 | ;;; Copyright (c) 2000-2015, Toshimi Sawada. All rights reserved. | |
| 3 | 3 | ;;; |
| 4 | 4 | ;;; Redistribution and use in source and binary forms, with or without |
| 5 | 5 | ;;; modification, are permitted provided that the following conditions |
| 28 | 28 | ;;; |
| 29 | 29 | (in-package :chaos) |
| 30 | 30 | #|============================================================================= |
| 31 | System:Chaos | |
| 32 | Module:BigPink | |
| 33 | File:lrpo.lisp | |
| 31 | System:Chaos | |
| 32 | Module:BigPink | |
| 33 | File:lrpo.lisp | |
| 34 | 34 | =============================================================================|# |
| 35 | 35 | #-:chaos-debug |
| 36 | 36 | (declaim (optimize (speed 3) (safety 0) #-GCL (debug 0))) |
| 44 | 44 | (defun lrpo-lex (t1 t2) |
| 45 | 45 | (declare (type term t1 t2)) |
| 46 | 46 | (let ((subs1 (term-subterms t1)) |
| 47 | (subs2 (term-subterms t2))) | |
| 47 | (subs2 (term-subterms t2))) | |
| 48 | 48 | (loop (unless subs1 (return)) |
| 49 | 49 | (unless (term-is-identical (car subs1) |
| 50 | (car subs2)) | |
| 51 | (return)) | |
| 50 | (car subs2)) | |
| 51 | (return)) | |
| 52 | 52 | (setq subs1 (cdr subs1) |
| 53 | subs2 (cdr subs2))) | |
| 53 | subs2 (cdr subs2))) | |
| 54 | 54 | (if (null subs1) |
| 55 | nil ; identical | |
| 55 | nil ; identical | |
| 56 | 56 | (if (lrpo (car subs1) (car subs2)) |
| 57 | ;; is t1 > each remaining arg of t2 | |
| 58 | (every #'(lambda (x)(lrpo t1 x)) | |
| 59 | (cdr subs2)) | |
| 60 | ;; is there a remaining arg of t1 s.t. arg == t2 or arg > t2 ? | |
| 61 | (dolist (ra (cdr subs1) nil) | |
| 62 | (when (or (term-is-identical ra t2) | |
| 63 | (lrpo ra t2)) | |
| 64 | (return-from lrpo-lex t))))))) | |
| 57 | ;; is t1 > each remaining arg of t2 | |
| 58 | (every #'(lambda (x)(lrpo t1 x)) | |
| 59 | (cdr subs2)) | |
| 60 | ;; is there a remaining arg of t1 s.t. arg == t2 or arg > t2 ? | |
| 61 | (dolist (ra (cdr subs1) nil) | |
| 62 | (when (or (term-is-identical ra t2) | |
| 63 | (lrpo ra t2)) | |
| 64 | (return-from lrpo-lex t))))))) | |
| 65 | 65 | |
| 66 | 66 | ;;; num-occurrences |
| 67 | 67 | ;;; |
| 69 | 69 | |
| 70 | 70 | (defun num-occurrences (arg term) |
| 71 | 71 | (declare (type term arg term) |
| 72 | (values fixnum)) | |
| 72 | (values fixnum)) | |
| 73 | 73 | (let ((i 0)) |
| 74 | 74 | (declare (type fixnum i)) |
| 75 | 75 | (dolist (sub (term-subterms term)) |
| 76 | 76 | (when (term-is-identical sub arg) |
| 77 | (incf i))) | |
| 77 | (incf i))) | |
| 78 | 78 | i)) |
| 79 | 79 | |
| 80 | 80 | ;;; term-multiset-diff t1 t2 |
| 81 | 81 | (defun term-multiset-diff (t1 t2) |
| 82 | 82 | (declare (type term t1 t2)) |
| 83 | 83 | (let ((done nil) |
| 84 | (diff nil)) | |
| 84 | (diff nil)) | |
| 85 | 85 | (declare (type list diff)) |
| 86 | 86 | (dolist (sub (term-subterms t1)) |
| 87 | 87 | (unless (member sub done :test #'term-is-identical) |
| 88 | (push sub done) | |
| 89 | (when (> (num-occurrences sub t1) | |
| 90 | (num-occurrences sub t2)) | |
| 91 | (push sub diff)))) | |
| 88 | (push sub done) | |
| 89 | (when (> (num-occurrences sub t1) | |
| 90 | (num-occurrences sub t2)) | |
| 91 | (push sub diff)))) | |
| 92 | 92 | diff)) |
| 93 | 93 | |
| 94 | 94 | ;;; lrpo-multiset |
| 96 | 96 | (defun lrpo-multiset (t1 t2) |
| 97 | 97 | (declare (type term t1 t2)) |
| 98 | 98 | (let ((t1-sub (term-subterms t1)) |
| 99 | (t2-sub (term-subterms t2))) | |
| 99 | (t2-sub (term-subterms t2))) | |
| 100 | 100 | (declare (type list t1-sub t2-sub)) |
| 101 | 101 | (unless t1-sub (return-from lrpo-multiset nil)) |
| 102 | 102 | (unless t2-sub (return-from lrpo-multiset t)) |
| 103 | 103 | (let ((diff1 (term-multiset-diff t1 t2)) |
| 104 | (diff2 (term-multiset-diff t2 t1)) | |
| 105 | (ok t)) | |
| 104 | (diff2 (term-multiset-diff t2 t1)) | |
| 105 | (ok t)) | |
| 106 | 106 | (declare (type list diff1 diff2)) |
| 107 | 107 | (if diff2 |
| 108 | (progn | |
| 109 | (dolist (r2 diff2 ) | |
| 110 | (unless ok (return)) | |
| 111 | (setq ok nil) | |
| 112 | (dolist (r1 diff1) | |
| 113 | (when (setq ok (lrpo r1 r2)) | |
| 114 | (return)))) | |
| 115 | ok) | |
| 116 | nil) | |
| 108 | (progn | |
| 109 | (dolist (r2 diff2 ) | |
| 110 | (unless ok (return)) | |
| 111 | (setq ok nil) | |
| 112 | (dolist (r1 diff1) | |
| 113 | (when (setq ok (lrpo r1 r2)) | |
| 114 | (return)))) | |
| 115 | ok) | |
| 116 | nil) | |
| 117 | 117 | ))) |
| 118 | 118 | |
| 119 | 119 | ;;; LRPO |
| 121 | 121 | (defun lrpo (t1 t2) |
| 122 | 122 | (declare (type term t1 t2)) |
| 123 | 123 | (let ((s1 (term-sort t1)) |
| 124 | (s2 (term-sort t2))) | |
| 124 | (s2 (term-sort t2))) | |
| 125 | 125 | (declare (type sort* s1 s2)) |
| 126 | 126 | (when (sort< s1 s2 *current-sort-order*) |
| 127 | 127 | (return-from lrpo nil)) |
| 141 | 141 | (return-from lrpo (occurs-in t2 t1))) |
| 142 | 142 | ;; |
| 143 | 143 | (if (method-is-of-same-operator (term-head t1) (term-head t2)) |
| 144 | (lrpo-lex t1 t2) | |
| 145 | ;; (lrpo-multiset t1 t2) | |
| 144 | (lrpo-lex t1 t2) | |
| 145 | ;; (lrpo-multiset t1 t2) | |
| 146 | 146 | (let ((prec (op-lex-precedence (term-head t1) (term-head t2)))) |
| 147 | (declare (type symbol prec)) | |
| 148 | (if (eq prec :same) | |
| 149 | (lrpo-multiset t1 t2) | |
| 150 | (if (eq prec :greater) | |
| 151 | ;; t1 > each arg of t2 | |
| 152 | (every #'(lambda (x) (lrpo t1 x)) | |
| 153 | (term-subterms t2)) | |
| 154 | ;; there is an arg of t1 s.t. arg = t2 or arg > t2. | |
| 155 | (some #'(lambda (x) | |
| 156 | (or (term-is-identical x t2) | |
| 157 | (lrpo x t2))) | |
| 158 | (term-subterms t1)))))) | |
| 147 | (declare (type symbol prec)) | |
| 148 | (if (eq prec :same) | |
| 149 | (lrpo-multiset t1 t2) | |
| 150 | (if (eq prec :greater) | |
| 151 | ;; t1 > each arg of t2 | |
| 152 | (every #'(lambda (x) (lrpo t1 x)) | |
| 153 | (term-subterms t2)) | |
| 154 | ;; there is an arg of t1 s.t. arg = t2 or arg > t2. | |
| 155 | (some #'(lambda (x) | |
| 156 | (or (term-is-identical x t2) | |
| 157 | (lrpo x t2))) | |
| 158 | (term-subterms t1)))))) | |
| 159 | 159 | )) |
| 160 | 160 | |
| 161 | 161 | (declaim (inline lrpo-greater)) |
| 166 | 166 | |
| 167 | 167 | (defun order-equalities-lrpo (clause &optional input?) |
| 168 | 168 | (declare (type clause clause) |
| 169 | (ignore input?)) | |
| 169 | (ignore input?)) | |
| 170 | 170 | (dolist (lit (clause-literals clause)) |
| 171 | 171 | (declare (type literal lit)) |
| 172 | 172 | (when (eq-literal? lit) |
| 173 | 173 | (let* ((eq (literal-atom lit)) |
| 174 | (alpha (term-arg-1 eq)) | |
| 175 | (beta (term-arg-2 eq))) | |
| 176 | (declare (type term eq alpha beta)) | |
| 177 | (if (lrpo-greater alpha beta) | |
| 178 | (set-bit (literal-stat-bits lit) oriented-eq-bit) | |
| 179 | (if (lrpo-greater beta alpha) | |
| 180 | (let ((new-atom | |
| 181 | (make-term-with-sort-check *fopl-eq* | |
| 182 | (list beta alpha)))) | |
| 183 | (setf (literal-atom lit) new-atom) | |
| 184 | (set-bit (literal-stat-bits lit) scratch-bit) | |
| 185 | (set-bit (literal-stat-bits lit) oriented-eq-bit) | |
| 186 | ))))))) | |
| 174 | (alpha (term-arg-1 eq)) | |
| 175 | (beta (term-arg-2 eq))) | |
| 176 | (declare (type term eq alpha beta)) | |
| 177 | (if (lrpo-greater alpha beta) | |
| 178 | (set-bit (literal-stat-bits lit) oriented-eq-bit) | |
| 179 | (if (lrpo-greater beta alpha) | |
| 180 | (let ((new-atom | |
| 181 | (make-term-with-sort-check *fopl-eq* | |
| 182 | (list beta alpha)))) | |
| 183 | (setf (literal-atom lit) new-atom) | |
| 184 | (set-bit (literal-stat-bits lit) scratch-bit) | |
| 185 | (set-bit (literal-stat-bits lit) oriented-eq-bit) | |
| 186 | ))))))) | |
| 187 | 187 | |
| 188 | 188 | ;;; |
| 189 | 189 | (defun pn-orient-term-pair (module pair) |
| 195 | 195 | (reset-module-proof-system module))) |
| 196 | 196 | (with-proof-context (module) |
| 197 | 197 | (if (lrpo (car pair) (cdr pair)) |
| 198 | (values (car pair) (cdr pair)) | |
| 198 | (values (car pair) (cdr pair)) | |
| 199 | 199 | (if (lrpo (cdr pair) (car pair)) |
| 200 | (values (cdr pair) (car pair)) | |
| 201 | (values (car pair) (cdr pair))))) | |
| 200 | (values (cdr pair) (car pair)) | |
| 201 | (values (car pair) (cdr pair))))) | |
| 202 | 202 | ) |
| 203 | 203 | |
| 204 | 204 | ;;; EOF |
| 0 | 0 | ;;;-*-Mode:LISP; Package: CHAOS; Base:10; Syntax:Common-lisp -*- |
| 1 | 1 | ;;; |
| 2 | ;;; Copyright (c) 2000-2014, Toshimi Sawada. All rights reserved. | |
| 2 | ;;; Copyright (c) 2000-2015, Toshimi Sawada. All rights reserved. | |
| 3 | 3 | ;;; |
| 4 | 4 | ;;; Redistribution and use in source and binary forms, with or without |
| 5 | 5 | ;;; modification, are permitted provided that the following conditions |
| 28 | 28 | ;;; |
| 29 | 29 | (in-package :chaos) |
| 30 | 30 | #|============================================================================= |
| 31 | System:Chaos | |
| 32 | Module:BigPink | |
| 33 | File:modconv.lisp | |
| 31 | System:Chaos | |
| 32 | Module:BigPink | |
| 33 | File:modconv.lisp | |
| 34 | 34 | =============================================================================|# |
| 35 | 35 | #-:chaos-debug |
| 36 | 36 | (declaim (optimize (speed 3) (safety 0) #-GCL (debug 0))) |
| 45 | 45 | ;;; |
| 46 | 46 | (defun make-pignose-axiom (lhs &key behavioural (type :pignose-axiom) label) |
| 47 | 47 | (make-rule :lhs lhs |
| 48 | :rhs *bool-true* | |
| 49 | :condition *bool-true* | |
| 50 | :labels label | |
| 51 | :behavioural behavioural | |
| 52 | :type type) | |
| 48 | :rhs *bool-true* | |
| 49 | :condition *bool-true* | |
| 50 | :labels label | |
| 51 | :behavioural behavioural | |
| 52 | :type type) | |
| 53 | 53 | ) |
| 54 | 54 | |
| 55 | 55 | ;;; AXIOM->FORMULA : Axiom -> FoplSentence |
| 72 | 72 | #|| |
| 73 | 73 | (eval-when (:execute :load-toplevel) |
| 74 | 74 | (setq .pn-ignore-ops. |
| 75 | (list *bool-and* ; _and_ | |
| 76 | *bool-or* ; _or_ | |
| 77 | *bool-not* ; not_ | |
| 78 | *sort-membership* ; _:<SortId> | |
| 79 | *bool-if* ; if_then_else_fi | |
| 80 | *bool-imply* ; _implies_ | |
| 81 | *bool-iff* ; _iff_ | |
| 82 | *bool-xor* ; _xor_ | |
| 83 | *bool-equal* ; _==_ | |
| 84 | *beh-equal* ; _=b=_ | |
| 85 | *bool-nonequal* ; _=/=_ | |
| 86 | *beh-eq-pred* ; _=*=_ | |
| 87 | *bool-and-also* ; _and-also_ | |
| 88 | *bool-or-else*))) ; _or-else_ | |
| 75 | (list *bool-and* ; _and_ | |
| 76 | *bool-or* ; _or_ | |
| 77 | *bool-not* ; not_ | |
| 78 | *sort-membership* ; _:<SortId> | |
| 79 | *bool-if* ; if_then_else_fi | |
| 80 | *bool-imply* ; _implies_ | |
| 81 | *bool-iff* ; _iff_ | |
| 82 | *bool-xor* ; _xor_ | |
| 83 | *bool-equal* ; _==_ | |
| 84 | *beh-equal* ; _=b=_ | |
| 85 | *bool-nonequal* ; _=/=_ | |
| 86 | *beh-eq-pred* ; _=*=_ | |
| 87 | *bool-and-also* ; _and-also_ | |
| 88 | *bool-or-else*))) ; _or-else_ | |
| 89 | 89 | ||# |
| 90 | 90 | |
| 91 | 91 | (defun axiom->formula (ax) |
| 92 | 92 | (declare (type axiom ax)) |
| 93 | 93 | (when *debug-formula* |
| 94 | (format t "~&>> start axiom->formula conversion <<") | |
| 94 | (format t "~%>> start axiom->formula conversion <<") | |
| 95 | 95 | (print-next) |
| 96 | 96 | (print-chaos-object ax)) |
| 97 | 97 | ;; we ignore axioms of built-in Boolean operations |
| 98 | 98 | ;; and, or, not, xor, ==, =/=, =b=, =*=, etc. user should be noticed. |
| 99 | 99 | (let* ((lhs (axiom-lhs ax)) |
| 100 | (head (if (term-is-applform? lhs) | |
| 101 | (term-head (axiom-lhs ax)) | |
| 102 | nil)) | |
| 103 | (type (axiom-type ax))) | |
| 100 | (head (if (term-is-applform? lhs) | |
| 101 | (term-head (axiom-lhs ax)) | |
| 102 | nil)) | |
| 103 | (type (axiom-type ax))) | |
| 104 | 104 | (declare (type (or null method) head) |
| 105 | (type symbol type)) | |
| 105 | (type symbol type)) | |
| 106 | 106 | (when (and head |
| 107 | (member head .pn-ignore-ops. | |
| 108 | :test #'pn-method-is-of-same-operator)) | |
| 107 | (member head .pn-ignore-ops. | |
| 108 | :test #'pn-method-is-of-same-operator)) | |
| 109 | 109 | (when *chaos-verbose* |
| 110 | (with-output-chaos-warning () | |
| 111 | (format t "~&axiom to formula translation: ignoring axiom") | |
| 112 | (print-next) | |
| 113 | (print-chaos-object ax))) | |
| 110 | (with-output-chaos-warning () | |
| 111 | (format t "axiom to formula translation: ignoring axiom") | |
| 112 | (print-next) | |
| 113 | (print-chaos-object ax))) | |
| 114 | 114 | (return-from axiom->formula nil)) |
| 115 | 115 | ;; |
| 116 | 116 | (case type |
| 117 | 117 | ((:equation :pignose-axiom :pignose-goal) |
| 118 | 118 | #|| too early !!! |
| 119 | 119 | (when (eq type :pignose-goal) |
| 120 | ;; we negate it before taking univeraly quantified closure: | |
| 121 | (setq lhs (copy-term-reusing-variables lhs | |
| 122 | (term-variables lhs))) | |
| 123 | (setq lhs | |
| 124 | (make-term-with-sort-check *fopl-neg* | |
| 125 | (list lhs)))) | |
| 120 | ;; we negate it before taking univeraly quantified closure: | |
| 121 | (setq lhs (copy-term-reusing-variables lhs | |
| 122 | (term-variables lhs))) | |
| 123 | (setq lhs | |
| 124 | (make-term-with-sort-check *fopl-neg* | |
| 125 | (list lhs)))) | |
| 126 | 126 | ||# |
| 127 | 127 | (let ((frm-lhs (cafeobj-term->formula lhs)) |
| 128 | (frm-rhs (if (eq type :equation) | |
| 129 | (cafeobj-term->formula (axiom-rhs ax)))) | |
| 130 | (frm-cond (if (eq type :equation) | |
| 131 | (if (term-is-similar? *bool-true* | |
| 132 | (axiom-condition ax)) | |
| 133 | nil | |
| 134 | (cafeobj-term->formula (axiom-condition ax))))) | |
| 135 | (frm nil) | |
| 136 | (*elim-tf-in-axioms* | |
| 137 | (if (not (eq (axiom-type ax) :equation)) | |
| 138 | t | |
| 139 | *elim-tf-in-axioms*))) | |
| 140 | (declare (type (or null term) | |
| 141 | frm-lhs frm-rhs frm-cond frm)) | |
| 142 | ;; | |
| 143 | (when *elim-tf-in-axioms* | |
| 144 | (when (term-is-similar? *bool-true* frm-lhs) | |
| 145 | (setq frm-lhs nil)) | |
| 146 | (when (term-is-similar? *bool-true* frm-rhs) | |
| 147 | (setq frm-rhs nil)) | |
| 148 | (when (term-is-similar? *bool-false* frm-lhs) | |
| 149 | (setq frm-lhs nil) | |
| 150 | (setq frm-rhs (make-term-with-sort-check | |
| 151 | *fopl-neg* | |
| 152 | (list frm-rhs)))) | |
| 153 | (when (term-is-similar? *bool-false* frm-rhs) | |
| 154 | (setq frm-rhs nil) | |
| 155 | (setq frm-lhs (make-term-with-sort-check | |
| 156 | *fopl-neg* | |
| 157 | (list frm-lhs)))) | |
| 158 | (unless frm-lhs | |
| 159 | (setq frm-lhs frm-rhs) | |
| 160 | (setq frm-rhs nil))) | |
| 161 | ;; | |
| 162 | (if (and frm-lhs frm-rhs) | |
| 163 | (if frm-cond | |
| 164 | ;; ~cond | lhs = rhs (cond -> lhs = rhs) | |
| 165 | (setq frm (make-term-with-sort-check | |
| 166 | *fopl-or* | |
| 167 | (list (make-term-with-sort-check | |
| 168 | *fopl-neg* | |
| 169 | (list frm-cond)) | |
| 170 | (make-term-with-sort-check | |
| 171 | (if (and *fopl-two-equalities* | |
| 172 | (axiom-is-behavioural ax)) | |
| 173 | *fopl-beq* | |
| 174 | *fopl-eq*) | |
| 175 | (list frm-lhs frm-rhs))))) | |
| 176 | ;; lhs = rhs | |
| 177 | (setq frm (make-term-with-sort-check | |
| 178 | (if (and *fopl-two-equalities* | |
| 179 | (axiom-is-behavioural ax)) | |
| 180 | *fopl-beq* | |
| 181 | *fopl-eq*) | |
| 182 | (list frm-lhs frm-rhs)))) | |
| 183 | ;; | |
| 184 | (if frm-cond | |
| 185 | ;; ~cond | lhs | |
| 186 | (setq frm (make-term-with-sort-check | |
| 187 | *fopl-or* | |
| 188 | (list (make-term-with-sort-check | |
| 189 | *fopl-neg* | |
| 190 | (list frm-cond)) | |
| 191 | frm-lhs))) | |
| 192 | ;; lhs | |
| 193 | (setq frm frm-lhs)) | |
| 194 | ) | |
| 195 | ;; | |
| 196 | (when *debug-formula* | |
| 197 | (format t "~%>> done <<") | |
| 198 | (print-next) | |
| 199 | (term-print frm)) | |
| 200 | ||
| 201 | ;; if the axioms is :pignose-goal, i.e. declared by | |
| 202 | ;; `goal', negate it. | |
| 203 | ||
| 204 | (when (eq type :pignose-goal) | |
| 205 | (setq frm (copy-term-reusing-variables frm | |
| 206 | (term-variables frm))) | |
| 207 | (normalize-quantifiers frm) | |
| 208 | (setq frm (make-term-with-sort-check *fopl-neg* | |
| 209 | (list frm)))) | |
| 210 | ||
| 211 | ;; | |
| 212 | frm)) | |
| 128 | (frm-rhs (if (eq type :equation) | |
| 129 | (cafeobj-term->formula (axiom-rhs ax)))) | |
| 130 | (frm-cond (if (eq type :equation) | |
| 131 | (if (term-is-similar? *bool-true* | |
| 132 | (axiom-condition ax)) | |
| 133 | nil | |
| 134 | (cafeobj-term->formula (axiom-condition ax))))) | |
| 135 | (frm nil) | |
| 136 | (*elim-tf-in-axioms* | |
| 137 | (if (not (eq (axiom-type ax) :equation)) | |
| 138 | t | |
| 139 | *elim-tf-in-axioms*))) | |
| 140 | (declare (type (or null term) | |
| 141 | frm-lhs frm-rhs frm-cond frm)) | |
| 142 | ;; | |
| 143 | (when *elim-tf-in-axioms* | |
| 144 | (when (term-is-similar? *bool-true* frm-lhs) | |
| 145 | (setq frm-lhs nil)) | |
| 146 | (when (term-is-similar? *bool-true* frm-rhs) | |
| 147 | (setq frm-rhs nil)) | |
| 148 | (when (term-is-similar? *bool-false* frm-lhs) | |
| 149 | (setq frm-lhs nil) | |
| 150 | (setq frm-rhs (make-term-with-sort-check | |
| 151 | *fopl-neg* | |
| 152 | (list frm-rhs)))) | |
| 153 | (when (term-is-similar? *bool-false* frm-rhs) | |
| 154 | (setq frm-rhs nil) | |
| 155 | (setq frm-lhs (make-term-with-sort-check | |
| 156 | *fopl-neg* | |
| 157 | (list frm-lhs)))) | |
| 158 | (unless frm-lhs | |
| 159 | (setq frm-lhs frm-rhs) | |
| 160 | (setq frm-rhs nil))) | |
| 161 | ;; | |
| 162 | (if (and frm-lhs frm-rhs) | |
| 163 | (if frm-cond | |
| 164 | ;; ~cond | lhs = rhs (cond -> lhs = rhs) | |
| 165 | (setq frm (make-term-with-sort-check | |
| 166 | *fopl-or* | |
| 167 | (list (make-term-with-sort-check | |
| 168 | *fopl-neg* | |
| 169 | (list frm-cond)) | |
| 170 | (make-term-with-sort-check | |
| 171 | (if (and *fopl-two-equalities* | |
| 172 | (axiom-is-behavioural ax)) | |
| 173 | *fopl-beq* | |
| 174 | *fopl-eq*) | |
| 175 | (list frm-lhs frm-rhs))))) | |
| 176 | ;; lhs = rhs | |
| 177 | (setq frm (make-term-with-sort-check | |
| 178 | (if (and *fopl-two-equalities* | |
| 179 | (axiom-is-behavioural ax)) | |
| 180 | *fopl-beq* | |
| 181 | *fopl-eq*) | |
| 182 | (list frm-lhs frm-rhs)))) | |
| 183 | ;; | |
| 184 | (if frm-cond | |
| 185 | ;; ~cond | lhs | |
| 186 | (setq frm (make-term-with-sort-check | |
| 187 | *fopl-or* | |
| 188 | (list (make-term-with-sort-check | |
| 189 | *fopl-neg* | |
| 190 | (list frm-cond)) | |
| 191 | frm-lhs))) | |
| 192 | ;; lhs | |
| 193 | (setq frm frm-lhs)) | |
| 194 | ) | |
| 195 | ;; | |
| 196 | (when *debug-formula* | |
| 197 | (format t "~%>> done <<") | |
| 198 | (print-next) | |
| 199 | (term-print frm)) | |
| 200 | ||
| 201 | ;; if the axioms is :pignose-goal, i.e. declared by | |
| 202 | ;; `goal', negate it. | |
| 203 | ||
| 204 | (when (eq type :pignose-goal) | |
| 205 | (setq frm (copy-term-reusing-variables frm | |
| 206 | (term-variables frm))) | |
| 207 | (normalize-quantifiers frm) | |
| 208 | (setq frm (make-term-with-sort-check *fopl-neg* | |
| 209 | (list frm)))) | |
| 210 | ||
| 211 | ;; | |
| 212 | frm)) | |
| 213 | 213 | (otherwise |
| 214 | 214 | (with-output-chaos-error () |
| 215 | (format t "sorry, but transitions are not supported yet.") | |
| 216 | (print-next) | |
| 217 | (print-chaos-object ax))) | |
| 215 | (format t "sorry, but transitions are not supported yet.") | |
| 216 | (print-next) | |
| 217 | (print-chaos-object ax))) | |
| 218 | 218 | ))) |
| 219 | 219 | |
| 220 | 220 | ;;; MODULE-AXIOMS->CLAUSE : Module -> List[Clause] |
| 221 | 221 | ;;; |
| 222 | 222 | (defun module-all-equations (mod) |
| 223 | 223 | (declare (type module mod) |
| 224 | (values list)) | |
| 224 | (values list)) | |
| 225 | 225 | (let ((*seen* nil)) |
| 226 | 226 | (declare (special *seen*) |
| 227 | (type list *seen*)) | |
| 227 | (type list *seen*)) | |
| 228 | 228 | (labels ((all-own-equations (mod) |
| 229 | (declare (type module mod)) | |
| 230 | (reverse (module-equations mod))) | |
| 231 | (imported-equations (mod) | |
| 232 | (declare (type module mod)) | |
| 233 | (let ((res nil) | |
| 234 | (subs (nreverse (module-direct-submodules mod)))) | |
| 235 | (declare (type list res subs)) | |
| 236 | (dolist (sub subs) | |
| 237 | (block next-sub | |
| 238 | (let ((sm (car sub))) | |
| 239 | (declare (type module sm)) | |
| 240 | (when (memq sm *seen*) | |
| 241 | (return-from next-sub nil)) | |
| 242 | (push sm *seen*) | |
| 243 | (when (eq :using (cdr sub)) | |
| 244 | (return-from next-sub nil)) | |
| 245 | (let ((sub-ax nil) | |
| 246 | (to-be-fixed (module-axioms-to-be-fixed mod))) | |
| 247 | (dolist (ax (all-own-equations sm)) | |
| 248 | (push (or (cdr (assq ax to-be-fixed)) | |
| 249 | ax) | |
| 250 | sub-ax)) | |
| 251 | (setq res | |
| 252 | (nconc res | |
| 253 | (nconc (nreverse sub-ax) | |
| 254 | (mapcar #'(lambda (x) | |
| 255 | (or (cdr (assq x to-be-fixed)) | |
| 256 | x)) | |
| 257 | (imported-equations sm))) | |
| 258 | )))))) | |
| 259 | ;; | |
| 260 | (delete-duplicates res :test #'eq)))) | |
| 229 | (declare (type module mod)) | |
| 230 | (reverse (module-equations mod))) | |
| 231 | (imported-equations (mod) | |
| 232 | (declare (type module mod)) | |
| 233 | (let ((res nil) | |
| 234 | (subs (nreverse (module-direct-submodules mod)))) | |
| 235 | (declare (type list res subs)) | |
| 236 | (dolist (sub subs) | |
| 237 | (block next-sub | |
| 238 | (let ((sm (car sub))) | |
| 239 | (declare (type module sm)) | |
| 240 | (when (memq sm *seen*) | |
| 241 | (return-from next-sub nil)) | |
| 242 | (push sm *seen*) | |
| 243 | (when (eq :using (cdr sub)) | |
| 244 | (return-from next-sub nil)) | |
| 245 | (let ((sub-ax nil) | |
| 246 | (to-be-fixed (module-axioms-to-be-fixed mod))) | |
| 247 | (dolist (ax (all-own-equations sm)) | |
| 248 | (push (or (cdr (assq ax to-be-fixed)) | |
| 249 | ax) | |
| 250 | sub-ax)) | |
| 251 | (setq res | |
| 252 | (nconc res | |
| 253 | (nconc (nreverse sub-ax) | |
| 254 | (mapcar #'(lambda (x) | |
| 255 | (or (cdr (assq x to-be-fixed)) | |
| 256 | x)) | |
| 257 | (imported-equations sm))) | |
| 258 | )))))) | |
| 259 | ;; | |
| 260 | (delete-duplicates res :test #'eq)))) | |
| 261 | 261 | ;; |
| 262 | 262 | (setq *seen* nil) |
| 263 | 263 | (nconc (all-own-equations mod) |
| 264 | (imported-equations mod)) | |
| 264 | (imported-equations mod)) | |
| 265 | 265 | ))) |
| 266 | 266 | |
| 267 | 267 | ;;; MODULE-INCLUDES-FORMULA : Module -> Bool |
| 278 | 278 | (make-term-with-sort-check |
| 279 | 279 | method |
| 280 | 280 | (mapcar #'(lambda (x) |
| 281 | (pn-make-var-on-the-fly x)) | |
| 282 | (method-arity method))))) | |
| 281 | (pn-make-var-on-the-fly x)) | |
| 282 | (method-arity method))))) | |
| 283 | 283 | |
| 284 | 284 | ;;; COVER-SET-OF-SORT |
| 285 | 285 | ;;; |
| 286 | 286 | (defun cover-set-of-sort (mod sort) |
| 287 | 287 | (declare (type module mod) |
| 288 | (type sort* sort) | |
| 289 | (values list)) | |
| 288 | (type sort* sort) | |
| 289 | (values list)) | |
| 290 | 290 | (let ((constructors (sort-constructors sort)) |
| 291 | (res nil)) | |
| 291 | (res nil)) | |
| 292 | 292 | (declare (type list constructors res)) |
| 293 | 293 | (dolist (constr constructors) |
| 294 | 294 | (push (make-pn-appl-pat mod constr) res)) |
| 298 | 298 | ;;; |
| 299 | 299 | (defun module-cover-sets (mod &optional (no-built-in t)) |
| 300 | 300 | (declare (type module mod) |
| 301 | (values list)) | |
| 301 | (values list)) | |
| 302 | 302 | (let ((res nil)) |
| 303 | 303 | (dolist (sort (module-all-sorts mod)) |
| 304 | 304 | (declare (type sort* sort)) |
| 305 | 305 | (block next |
| 306 | (when (and no-built-in | |
| 307 | (let ((smod (sort-module sort))) | |
| 308 | (or (module-is-hard-wired smod) | |
| 309 | (module-is-system-module smod)))) | |
| 310 | (return-from next nil)) | |
| 311 | (let ((cset (cover-set-of-sort mod sort))) | |
| 312 | (when cset | |
| 313 | (push (cons sort cset) res)))) | |
| 306 | (when (and no-built-in | |
| 307 | (let ((smod (sort-module sort))) | |
| 308 | (or (module-is-hard-wired smod) | |
| 309 | (module-is-system-module smod)))) | |
| 310 | (return-from next nil)) | |
| 311 | (let ((cset (cover-set-of-sort mod sort))) | |
| 312 | (when cset | |
| 313 | (push (cons sort cset) res)))) | |
| 314 | 314 | ) |
| 315 | 315 | res)) |
| 316 | 316 | |
| 317 | 317 | (defun get-all-methods-of-sort-strict (sort module) |
| 318 | 318 | (declare (type sort* sort) |
| 319 | (type module module)) | |
| 319 | (type module module)) | |
| 320 | 320 | (let ((res nil)) |
| 321 | 321 | (declare (type list res)) |
| 322 | 322 | (dolist (info (module-all-operators module)) |
| 323 | 323 | (dolist (m (opinfo-methods info)) |
| 324 | (unless (or (eq *void-method* m) | |
| 325 | (is-skolem m module)) | |
| 326 | (when (sort= (method-coarity m) sort) | |
| 327 | (push m res))))) | |
| 324 | (unless (or (eq *void-method* m) | |
| 325 | (is-skolem m module)) | |
| 326 | (when (sort= (method-coarity m) sort) | |
| 327 | (push m res))))) | |
| 328 | 328 | res)) |
| 329 | 329 | |
| 330 | 330 | ;;; INTRO-EXISTS : formula ex-vars -> formula |
| 331 | 331 | ;;; |
| 332 | 332 | (defun intro-exists (form vars) |
| 333 | 333 | (declare (type term form) |
| 334 | (type list vars)) | |
| 334 | (type list vars)) | |
| 335 | 335 | (if (null vars) |
| 336 | 336 | form |
| 337 | 337 | (let ((var-decl nil)) |
| 338 | 338 | (declare (type (or null term))) |
| 339 | 339 | (if (cdr vars) |
| 340 | (setq var-decl | |
| 341 | (make-right-assoc-normal-form *var-decl-list* | |
| 342 | vars)) | |
| 343 | (setq var-decl (car vars))) | |
| 340 | (setq var-decl | |
| 341 | (make-right-assoc-normal-form *var-decl-list* | |
| 342 | vars)) | |
| 343 | (setq var-decl (car vars))) | |
| 344 | 344 | (make-term-with-sort-check *fopl-exists* |
| 345 | (list var-decl form))))) | |
| 345 | (list var-decl form))))) | |
| 346 | 346 | |
| 347 | 347 | ;;; PN-NO-JUNK |
| 348 | 348 | ;;; genarates axioms of no-junk. |
| 352 | 352 | #+:chaos-debug |
| 353 | 353 | (declare (notinline op-lex-compare)) |
| 354 | 354 | (let ((csets (module-cover-sets mod)) |
| 355 | (all-axioms nil)) | |
| 355 | (all-axioms nil)) | |
| 356 | 356 | (declare (type list csets)) |
| 357 | 357 | (with-in-module (mod) |
| 358 | 358 | (dolist (cset csets) |
| 359 | (declare (type list cset)) | |
| 360 | (block next | |
| 361 | (let* ((sort (car cset)) | |
| 362 | (covers (cdr cset)) | |
| 363 | (axioms nil)) | |
| 364 | (declare (type sort* sort) | |
| 365 | (type list covers axioms)) | |
| 366 | (let ((constrs (sort-constructors sort)) | |
| 367 | (methods (get-all-methods-of-sort-strict sort mod)) | |
| 368 | (gen-methods nil)) | |
| 369 | (declare (type list constrs methods gen-methods)) | |
| 370 | ;; | |
| 371 | #| | |
| 372 | (dolist (const constrs) | |
| 373 | (when (method-arity const) (return-from next nil))) | |
| 374 | |# | |
| 375 | ;; | |
| 376 | (dolist (method methods) | |
| 377 | (unless (memq method constrs) | |
| 378 | (let* ((arg-1 (make-pn-appl-pat mod method)) | |
| 379 | (vars (term-variables arg-1)) | |
| 380 | (pat nil) | |
| 381 | (axiom-lhs nil)) | |
| 382 | (declare (type term arg-1) | |
| 383 | (list vars pat) | |
| 384 | (type (or null term) axiom-lhs)) | |
| 385 | (dolist (cover covers) | |
| 386 | (let* ((real-cover (term-unique-vars cover)) | |
| 387 | (cover-vars (term-variables real-cover)) | |
| 388 | (eq-pat (make-term-with-sort-check | |
| 389 | *fopl-eq* | |
| 390 | (list | |
| 391 | (copy-term-reusing-variables arg-1 vars) | |
| 392 | real-cover)))) | |
| 393 | (if (null cover-vars) | |
| 394 | (push eq-pat pat) | |
| 395 | ;; cover pat contains vars. | |
| 396 | ;; introduce existential quantifier. | |
| 397 | (push (intro-exists eq-pat cover-vars) pat)))) | |
| 398 | ||
| 399 | (if (cdr pat) ; more than one pat | |
| 400 | (setq axiom-lhs | |
| 401 | (make-right-assoc-normal-form *fopl-or* | |
| 402 | pat)) | |
| 403 | (setq axiom-lhs (car pat))) | |
| 404 | ;; | |
| 405 | (push (make-pignose-axiom axiom-lhs :label 'no-junk) | |
| 406 | axioms) | |
| 407 | (push method gen-methods))) | |
| 408 | ||
| 409 | ) ; done for all methods for a sort | |
| 410 | ;; redunduncy check. this is important | |
| 411 | ;; if there are some axioms of the form | |
| 412 | ;; foo(X) = bar(X) | |
| 413 | ;; and | |
| 414 | ;; foo > bar | |
| 415 | ;; foo from axioms. | |
| 416 | (let ((do-delete nil)) | |
| 417 | (declare (type list do-delete)) | |
| 418 | (dolist (ax axioms) | |
| 419 | (let* ((lhs (axiom-lhs ax)) | |
| 420 | (type (fopl-sentence-type lhs)) | |
| 421 | (lhs-meth nil) | |
| 422 | (rules nil)) | |
| 423 | ;; lhs ::= | |
| 424 | ;; | meth(x) = constr1 ... | |
| 425 | ;; | \E[...] X = Y ... | |
| 426 | (when (eq type :or) | |
| 427 | (setq lhs (term-arg-1 lhs)) | |
| 428 | (setq type (fopl-sentence-type lhs))) | |
| 429 | (case type | |
| 430 | (:eq (setq lhs (term-arg-1 lhs)) | |
| 431 | (setq lhs-meth (term-head lhs))) | |
| 432 | (:exists (setq lhs (term-arg-1 (term-arg-2 lhs))) | |
| 433 | (setq lhs-meth (term-head lhs))) | |
| 434 | (otherwise | |
| 435 | (with-output-panic-message () | |
| 436 | (format t "pn-no-junk: illegal type ~s" type))) | |
| 437 | ) | |
| 438 | (when lhs-meth | |
| 439 | (setq rules (method-rules-with-different-top lhs-meth))) | |
| 440 | ;; | |
| 441 | (dolist (rule rules) | |
| 442 | (let* ((rhs (rule-rhs rule))) | |
| 443 | (when (and (term-is-application-form? rhs) | |
| 444 | (let ((rhs-meth (term-head rhs))) | |
| 445 | (and (memq rhs-meth gen-methods) | |
| 446 | (eq :greater | |
| 447 | (op-lex-compare lhs-meth | |
| 448 | (term-head rhs)))) | |
| 449 | )) | |
| 450 | ;; | |
| 451 | (pushnew ax do-delete)))))) | |
| 452 | (dolist (ax do-delete) | |
| 453 | (setq axioms (delete ax axioms)))) | |
| 454 | #|| | |
| 455 | (unless axioms | |
| 456 | ;; we make | |
| 457 | ;; var = consr1 | var = constr2 ... | |
| 458 | (let ((var (pn-make-var-on-the-fly sort)) | |
| 459 | (pat nil) | |
| 460 | (axiom-lhs nil)) | |
| 461 | (declare (type term var)) | |
| 462 | (dolist (cover covers) | |
| 463 | (push | |
| 464 | (make-term-with-sort-check | |
| 465 | *fopl-eq* | |
| 466 | (list | |
| 467 | var | |
| 468 | (term-unique-vars cover))) | |
| 469 | pat)) | |
| 470 | (if (cdr pat) ; more than one pat | |
| 471 | (setq axiom-lhs | |
| 472 | (make-right-assoc-normal-form *fopl-or* | |
| 473 | pat)) | |
| 474 | (setq axiom-lhs (car pat))) | |
| 475 | ;; | |
| 476 | (push (make-pignose-axiom axiom-lhs :label 'no-junk) | |
| 477 | axioms))) | |
| 478 | ||# | |
| 479 | ) | |
| 480 | ;; | |
| 481 | (setq all-axioms (nconc all-axioms axioms)) | |
| 482 | ))) ; done for a sort | |
| 359 | (declare (type list cset)) | |
| 360 | (block next | |
| 361 | (let* ((sort (car cset)) | |
| 362 | (covers (cdr cset)) | |
| 363 | (axioms nil)) | |
| 364 | (declare (type sort* sort) | |
| 365 | (type list covers axioms)) | |
| 366 | (let ((constrs (sort-constructors sort)) | |
| 367 | (methods (get-all-methods-of-sort-strict sort mod)) | |
| 368 | (gen-methods nil)) | |
| 369 | (declare (type list constrs methods gen-methods)) | |
| 370 | ;; | |
| 371 | #| | |
| 372 | (dolist (const constrs) | |
| 373 | (when (method-arity const) (return-from next nil))) | |
| 374 | |# | |
| 375 | ;; | |
| 376 | (dolist (method methods) | |
| 377 | (unless (memq method constrs) | |
| 378 | (let* ((arg-1 (make-pn-appl-pat mod method)) | |
| 379 | (vars (term-variables arg-1)) | |
| 380 | (pat nil) | |
| 381 | (axiom-lhs nil)) | |
| 382 | (declare (type term arg-1) | |
| 383 | (list vars pat) | |
| 384 | (type (or null term) axiom-lhs)) | |
| 385 | (dolist (cover covers) | |
| 386 | (let* ((real-cover (term-unique-vars cover)) | |
| 387 | (cover-vars (term-variables real-cover)) | |
| 388 | (eq-pat (make-term-with-sort-check | |
| 389 | *fopl-eq* | |
| 390 | (list | |
| 391 | (copy-term-reusing-variables arg-1 vars) | |
| 392 | real-cover)))) | |
| 393 | (if (null cover-vars) | |
| 394 | (push eq-pat pat) | |
| 395 | ;; cover pat contains vars. | |
| 396 | ;; introduce existential quantifier. | |
| 397 | (push (intro-exists eq-pat cover-vars) pat)))) | |
| 398 | ||
| 399 | (if (cdr pat) ; more than one pat | |
| 400 | (setq axiom-lhs | |
| 401 | (make-right-assoc-normal-form *fopl-or* | |
| 402 | pat)) | |
| 403 | (setq axiom-lhs (car pat))) | |
| 404 | ;; | |
| 405 | (push (make-pignose-axiom axiom-lhs :label 'no-junk) | |
| 406 | axioms) | |
| 407 | (push method gen-methods))) | |
| 408 | ||
| 409 | ) ; done for all methods for a sort | |
| 410 | ;; redunduncy check. this is important | |
| 411 | ;; if there are some axioms of the form | |
| 412 | ;; foo(X) = bar(X) | |
| 413 | ;; and | |
| 414 | ;; foo > bar | |
| 415 | ;; foo from axioms. | |
| 416 | (let ((do-delete nil)) | |
| 417 | (declare (type list do-delete)) | |
| 418 | (dolist (ax axioms) | |
| 419 | (let* ((lhs (axiom-lhs ax)) | |
| 420 | (type (fopl-sentence-type lhs)) | |
| 421 | (lhs-meth nil) | |
| 422 | (rules nil)) | |
| 423 | ;; lhs ::= | |
| 424 | ;; | meth(x) = constr1 ... | |
| 425 | ;; | \E[...] X = Y ... | |
| 426 | (when (eq type :or) | |
| 427 | (setq lhs (term-arg-1 lhs)) | |
| 428 | (setq type (fopl-sentence-type lhs))) | |
| 429 | (case type | |
| 430 | (:eq (setq lhs (term-arg-1 lhs)) | |
| 431 | (setq lhs-meth (term-head lhs))) | |
| 432 | (:exists (setq lhs (term-arg-1 (term-arg-2 lhs))) | |
| 433 | (setq lhs-meth (term-head lhs))) | |
| 434 | (otherwise | |
| 435 | (with-output-panic-message () | |
| 436 | (format t "pn-no-junk: illegal type ~s" type))) | |
| 437 | ) | |
| 438 | (when lhs-meth | |
| 439 | (setq rules (method-rules-with-different-top lhs-meth))) | |
| 440 | ;; | |
| 441 | (dolist (rule rules) | |
| 442 | (let* ((rhs (rule-rhs rule))) | |
| 443 | (when (and (term-is-application-form? rhs) | |
| 444 | (let ((rhs-meth (term-head rhs))) | |
| 445 | (and (memq rhs-meth gen-methods) | |
| 446 | (eq :greater | |
| 447 | (op-lex-compare lhs-meth | |
| 448 | (term-head rhs)))) | |
| 449 | )) | |
| 450 | ;; | |
| 451 | (pushnew ax do-delete)))))) | |
| 452 | (dolist (ax do-delete) | |
| 453 | (setq axioms (delete ax axioms)))) | |
| 454 | #|| | |
| 455 | (unless axioms | |
| 456 | ;; we make | |
| 457 | ;; var = consr1 | var = constr2 ... | |
| 458 | (let ((var (pn-make-var-on-the-fly sort)) | |
| 459 | (pat nil) | |
| 460 | (axiom-lhs nil)) | |
| 461 | (declare (type term var)) | |
| 462 | (dolist (cover covers) | |
| 463 | (push | |
| 464 | (make-term-with-sort-check | |
| 465 | *fopl-eq* | |
| 466 | (list | |
| 467 | var | |
| 468 | (term-unique-vars cover))) | |
| 469 | pat)) | |
| 470 | (if (cdr pat) ; more than one pat | |
| 471 | (setq axiom-lhs | |
| 472 | (make-right-assoc-normal-form *fopl-or* | |
| 473 | pat)) | |
| 474 | (setq axiom-lhs (car pat))) | |
| 475 | ;; | |
| 476 | (push (make-pignose-axiom axiom-lhs :label 'no-junk) | |
| 477 | axioms))) | |
| 478 | ||# | |
| 479 | ) | |
| 480 | ;; | |
| 481 | (setq all-axioms (nconc all-axioms axioms)) | |
| 482 | ))) ; done for a sort | |
| 483 | 483 | all-axioms |
| 484 | 484 | ))) |
| 485 | 485 | |
| 489 | 489 | (defun pn-no-confusion (mod) |
| 490 | 490 | (declare (type module mod)) |
| 491 | 491 | (let ((csets (module-cover-sets mod)) |
| 492 | (axioms nil)) | |
| 492 | (axioms nil)) | |
| 493 | 493 | (declare (type list csets axioms)) |
| 494 | 494 | (with-in-module (mod) |
| 495 | 495 | (dolist (cset csets) |
| 496 | (declare (type list cset)) | |
| 497 | (let ((covers (cdr cset))) | |
| 498 | (do ((pat-list covers (cdr pat-list))) | |
| 499 | ((endp pat-list)) | |
| 500 | (dolist (pat2 (cdr pat-list)) | |
| 501 | #|| | |
| 502 | ;; ~(a = b) | |
| 503 | (push (make-pignose-axiom | |
| 504 | (make-term-with-sort-check | |
| 505 | *fopl-neg* | |
| 506 | (list (make-term-with-sort-check | |
| 507 | *fopl-eq* | |
| 508 | (list (term-unique-vars (car pat-list)) | |
| 509 | (term-unique-vars pat2))))) | |
| 510 | :label 'no-conf) | |
| 511 | axioms) | |
| 512 | ||# | |
| 513 | ;; (a = b) = false | |
| 514 | (push (make-pignose-axiom | |
| 515 | (make-term-with-sort-check | |
| 516 | *fopl-eq* | |
| 517 | (list (make-term-with-sort-check | |
| 518 | *fopl-eq* | |
| 519 | (list (term-unique-vars (car pat-list)) | |
| 520 | (term-unique-vars pat2))) | |
| 521 | *bool-false*)) | |
| 522 | :label 'no-conf) | |
| 523 | axioms) | |
| 524 | )))) | |
| 496 | (declare (type list cset)) | |
| 497 | (let ((covers (cdr cset))) | |
| 498 | (do ((pat-list covers (cdr pat-list))) | |
| 499 | ((endp pat-list)) | |
| 500 | (dolist (pat2 (cdr pat-list)) | |
| 501 | #|| | |
| 502 | ;; ~(a = b) | |
| 503 | (push (make-pignose-axiom | |
| 504 | (make-term-with-sort-check | |
| 505 | *fopl-neg* | |
| 506 | (list (make-term-with-sort-check | |
| 507 | *fopl-eq* | |
| 508 | (list (term-unique-vars (car pat-list)) | |
| 509 | (term-unique-vars pat2))))) | |
| 510 | :label 'no-conf) | |
| 511 | axioms) | |
| 512 | ||# | |
| 513 | ;; (a = b) = false | |
| 514 | (push (make-pignose-axiom | |
| 515 | (make-term-with-sort-check | |
| 516 | *fopl-eq* | |
| 517 | (list (make-term-with-sort-check | |
| 518 | *fopl-eq* | |
| 519 | (list (term-unique-vars (car pat-list)) | |
| 520 | (term-unique-vars pat2))) | |
| 521 | *bool-false*)) | |
| 522 | :label 'no-conf) | |
| 523 | axioms) | |
| 524 | )))) | |
| 525 | 525 | axioms |
| 526 | 526 | ))) |
| 527 | 527 | |
| 530 | 530 | ;;; |
| 531 | 531 | (defun module-axioms->clause (psys &aux (mod (psystem-module psys))) |
| 532 | 532 | (declare (type psystem psys) |
| 533 | (type module mod)) | |
| 533 | (type module mod)) | |
| 534 | 534 | (include-FOPL mod) |
| 535 | 535 | (compile-module mod) |
| 536 | 536 | (unless (module-includes-formula mod) |
| 538 | 538 | (princ "module does not import FOPL-CLAUSE module."))) |
| 539 | 539 | ;; |
| 540 | 540 | (flet ((clause-is-valid-for-resolution (clause) |
| 541 | (declare (type clause clause)) | |
| 542 | (if (unit-clause? clause) | |
| 543 | (let ((lit (car (clause-literals clause)))) | |
| 544 | (declare (type literal lit)) | |
| 545 | (if (positive-eq-literal? lit) | |
| 546 | (if (term-is-lisp-form? (term-arg-2 (literal-atom lit))) | |
| 547 | nil | |
| 548 | t) | |
| 549 | t)) | |
| 550 | t))) | |
| 541 | (declare (type clause clause)) | |
| 542 | (if (unit-clause? clause) | |
| 543 | (let ((lit (car (clause-literals clause)))) | |
| 544 | (declare (type literal lit)) | |
| 545 | (if (positive-eq-literal? lit) | |
| 546 | (if (term-is-lisp-form? (term-arg-2 (literal-atom lit))) | |
| 547 | nil | |
| 548 | t) | |
| 549 | t)) | |
| 550 | t))) | |
| 551 | 551 | (with-in-module (mod) |
| 552 | 552 | (let ((axs (module-all-equations mod)) |
| 553 | (ax-clauses nil) | |
| 554 | (demods nil) | |
| 555 | (bi-demods nil)) | |
| 556 | (declare (type list axs ax-clauses demods)) | |
| 557 | (dolist (ax axs) | |
| 558 | (let ((cls nil) | |
| 559 | (bi-demod nil) | |
| 560 | (demod nil)) | |
| 561 | (declare (type list cls demod)) | |
| 562 | (let ((lhs (axiom-lhs ax))) | |
| 563 | (when (or (not (term-is-applform? lhs)) | |
| 564 | (not (method-is-meta-demod (term-head lhs)))) | |
| 565 | (dolist (cl (formula->clause-1 | |
| 566 | (axiom->formula ax) | |
| 567 | psys | |
| 568 | ax)) | |
| 569 | (declare (type clause cl)) | |
| 570 | (if (clause-is-builtin-demod cl) | |
| 571 | (push cl bi-demod) | |
| 572 | (if (clause-axiom-declared-as-demodulator cl) | |
| 573 | (push cl demod) | |
| 574 | (when (clause-is-valid-for-resolution cl) | |
| 575 | (push cl cls))))))) | |
| 576 | (setq ax-clauses (nconc ax-clauses (nreverse cls))) | |
| 577 | (setq demods (nconc demods (nreverse demod))) | |
| 578 | (setq bi-demods (nconc bi-demods (nreverse bi-demod))))) | |
| 579 | (setf (psystem-axioms psys) ax-clauses) | |
| 580 | (setf (psystem-demods psys) demods) | |
| 581 | (setf (psystem-bi-demods psys) bi-demods)) | |
| 553 | (ax-clauses nil) | |
| 554 | (demods nil) | |
| 555 | (bi-demods nil)) | |
| 556 | (declare (type list axs ax-clauses demods)) | |
| 557 | (dolist (ax axs) | |
| 558 | (let ((cls nil) | |
| 559 | (bi-demod nil) | |
| 560 | (demod nil)) | |
| 561 | (declare (type list cls demod)) | |
| 562 | (let ((lhs (axiom-lhs ax))) | |
| 563 | (when (or (not (term-is-applform? lhs)) | |
| 564 | (not (method-is-meta-demod (term-head lhs)))) | |
| 565 | (dolist (cl (formula->clause-1 | |
| 566 | (axiom->formula ax) | |
| 567 | psys | |
| 568 | ax)) | |
| 569 | (declare (type clause cl)) | |
| 570 | (if (clause-is-builtin-demod cl) | |
| 571 | (push cl bi-demod) | |
| 572 | (if (clause-axiom-declared-as-demodulator cl) | |
| 573 | (push cl demod) | |
| 574 | (when (clause-is-valid-for-resolution cl) | |
| 575 | (push cl cls))))))) | |
| 576 | (setq ax-clauses (nconc ax-clauses (nreverse cls))) | |
| 577 | (setq demods (nconc demods (nreverse demod))) | |
| 578 | (setq bi-demods (nconc bi-demods (nreverse bi-demod))))) | |
| 579 | (setf (psystem-axioms psys) ax-clauses) | |
| 580 | (setf (psystem-demods psys) demods) | |
| 581 | (setf (psystem-bi-demods psys) bi-demods)) | |
| 582 | 582 | ;; no junk/ no confusion axioms if required |
| 583 | 583 | (when (pn-flag no-junk) |
| 584 | (let ((axs (pn-no-junk mod))) | |
| 585 | (dolist (ax axs) | |
| 586 | (dolist (cl (formula->clause-1 | |
| 587 | (axiom->formula ax) | |
| 588 | psys | |
| 589 | ax)) | |
| 590 | (declare (type clause cl)) | |
| 591 | (push cl (psystem-axioms psys)))))) | |
| 584 | (let ((axs (pn-no-junk mod))) | |
| 585 | (dolist (ax axs) | |
| 586 | (dolist (cl (formula->clause-1 | |
| 587 | (axiom->formula ax) | |
| 588 | psys | |
| 589 | ax)) | |
| 590 | (declare (type clause cl)) | |
| 591 | (push cl (psystem-axioms psys)))))) | |
| 592 | 592 | (when (pn-flag no-confusion) |
| 593 | (let ((axs (pn-no-confusion mod))) | |
| 594 | (dolist (ax axs) | |
| 595 | (dolist (cl (formula->clause-1 | |
| 596 | (axiom->formula ax) | |
| 597 | psys | |
| 598 | ax)) | |
| 599 | (declare (type clause cl)) | |
| 600 | (push cl (psystem-axioms psys)))))) | |
| 593 | (let ((axs (pn-no-confusion mod))) | |
| 594 | (dolist (ax axs) | |
| 595 | (dolist (cl (formula->clause-1 | |
| 596 | (axiom->formula ax) | |
| 597 | psys | |
| 598 | ax)) | |
| 599 | (declare (type clause cl)) | |
| 600 | (push cl (psystem-axioms psys)))))) | |
| 601 | 601 | ))) |
| 602 | 602 | |
| 603 | 603 | ;;; EOF |
| 0 | 0 | ;;;-*-Mode:LISP; Package: CHAOS; Base:10; Syntax:Common-lisp -*- |
| 1 | 1 | ;;; |
| 2 | ;;; Copyright (c) 2000-2014, Toshimi Sawada. All rights reserved. | |
| 2 | ;;; Copyright (c) 2000-2015, Toshimi Sawada. All rights reserved. | |
| 3 | 3 | ;;; |
| 4 | 4 | ;;; Redistribution and use in source and binary forms, with or without |
| 5 | 5 | ;;; modification, are permitted provided that the following conditions |
| 28 | 28 | ;;; |
| 29 | 29 | (in-package :chaos) |
| 30 | 30 | #|============================================================================= |
| 31 | System:Chaos | |
| 32 | Module:BigPink | |
| 33 | File:infer.lisp | |
| 31 | System:Chaos | |
| 32 | Module:BigPink | |
| 33 | File:infer.lisp | |
| 34 | 34 | =============================================================================|# |
| 35 | 35 | #-:chaos-debug |
| 36 | 36 | (declaim (optimize (speed 3) (safety 0) #-GCL (debug 0))) |
| 38 | 38 | (declaim (optimize (speed 1) (safety 3) #-GCL (debug 3))) |
| 39 | 39 | |
| 40 | 40 | ;;;============================================================================ |
| 41 | ;;; paramodulation inference rules | |
| 41 | ;;; paramodulation inference rules | |
| 42 | 42 | ;;;============================================================================ |
| 43 | 43 | |
| 44 | 44 | (declaim (inline get-term-at)) |
| 45 | 45 | |
| 46 | 46 | (defun get-term-at (pos term) |
| 47 | 47 | (declare (type list pos) |
| 48 | (type term term) | |
| 49 | (values term)) | |
| 48 | (type term term) | |
| 49 | (values term)) | |
| 50 | 50 | (let ((sub term)) |
| 51 | 51 | (declare (type term sub)) |
| 52 | 52 | (dolist (p (reverse pos)) |
| 57 | 57 | #|| |
| 58 | 58 | (defun apply-subst-2 (sigma atom target-term beta) |
| 59 | 59 | (declare (type list sigma) |
| 60 | (type term atom target-term beta)) | |
| 60 | (type term atom target-term beta)) | |
| 61 | 61 | (if (term-eq atom target-term) |
| 62 | 62 | (apply-subst sigma beta) |
| 63 | 63 | (cond ((term-is-variable? atom) |
| 64 | (let ((im (variable-image sigma atom))) | |
| 65 | (if im ; i.e. im = sigma(term) | |
| 66 | (values im t) | |
| 67 | (values atom nil)))) | |
| 68 | ((term-is-builtin-constant? atom) atom) | |
| 69 | ((term-is-constant? atom) | |
| 70 | (if (term-eq atom target-term) | |
| 71 | (apply-subst sigma beta) | |
| 72 | (apply-subst sigma atom))) | |
| 73 | ((term-is-application-form? atom) | |
| 74 | (let ((l-result nil) | |
| 75 | (modif-sort nil)) | |
| 76 | (declare (type list l-result)) | |
| 77 | (dolist (s-t (term-subterms atom)) | |
| 78 | (multiple-value-bind (image-s-t same-sort) | |
| 79 | (apply-subst-2 sigma s-t target-term beta) | |
| 80 | (declare (type term image-s-t)) | |
| 81 | (unless same-sort | |
| 82 | ;; (update-lowest-parse s-t) | |
| 83 | (setq modif-sort t)) | |
| 84 | (push image-s-t l-result))) | |
| 85 | (setq l-result (nreverse l-result)) | |
| 86 | (if modif-sort | |
| 87 | (let ((term-image | |
| 88 | (make-term-with-sort-check (term-head atom) | |
| 89 | l-result))) | |
| 90 | (values term-image | |
| 91 | (sort= (term-sort atom) | |
| 92 | (term-sort term-image)))) | |
| 93 | (values (make-applform (term-sort atom) | |
| 94 | (term-head atom) | |
| 95 | l-result) | |
| 96 | t)))) | |
| 97 | (t (with-output-panic-message () | |
| 98 | (princ "apply-subst: encoutered illegual term") | |
| 99 | (terpri) | |
| 100 | (term-print atom))))) | |
| 64 | (let ((im (variable-image sigma atom))) | |
| 65 | (if im ; i.e. im = sigma(term) | |
| 66 | (values im t) | |
| 67 | (values atom nil)))) | |
| 68 | ((term-is-builtin-constant? atom) atom) | |
| 69 | ((term-is-constant? atom) | |
| 70 | (if (term-eq atom target-term) | |
| 71 | (apply-subst sigma beta) | |
| 72 | (apply-subst sigma atom))) | |
| 73 | ((term-is-application-form? atom) | |
| 74 | (let ((l-result nil) | |
| 75 | (modif-sort nil)) | |
| 76 | (declare (type list l-result)) | |
| 77 | (dolist (s-t (term-subterms atom)) | |
| 78 | (multiple-value-bind (image-s-t same-sort) | |
| 79 | (apply-subst-2 sigma s-t target-term beta) | |
| 80 | (declare (type term image-s-t)) | |
| 81 | (unless same-sort | |
| 82 | ;; (update-lowest-parse s-t) | |
| 83 | (setq modif-sort t)) | |
| 84 | (push image-s-t l-result))) | |
| 85 | (setq l-result (nreverse l-result)) | |
| 86 | (if modif-sort | |
| 87 | (let ((term-image | |
| 88 | (make-term-with-sort-check (term-head atom) | |
| 89 | l-result))) | |
| 90 | (values term-image | |
| 91 | (sort= (term-sort atom) | |
| 92 | (term-sort term-image)))) | |
| 93 | (values (make-applform (term-sort atom) | |
| 94 | (term-head atom) | |
| 95 | l-result) | |
| 96 | t)))) | |
| 97 | (t (with-output-panic-message () | |
| 98 | (princ "apply-subst: encoutered illegual term") | |
| 99 | (terpri) | |
| 100 | (term-print atom))))) | |
| 101 | 101 | ) |
| 102 | 102 | ||# |
| 103 | 103 | |
| 104 | 104 | (defun apply-subst-2 (sigma atom target-term beta target-pos &optional arg-pos) |
| 105 | 105 | (declare (type list sigma) |
| 106 | (type term atom target-term beta)) | |
| 106 | (type term atom target-term beta)) | |
| 107 | 107 | (cond ((equal target-pos arg-pos) |
| 108 | (apply-subst sigma beta)) | |
| 109 | ((term-is-variable? atom) | |
| 110 | (let ((im (variable-image sigma atom))) | |
| 111 | (if im | |
| 112 | (values im t) | |
| 113 | (values atom nil)))) | |
| 114 | ((term-is-builtin-constant? atom) atom) | |
| 115 | ((term-is-constant? atom) | |
| 116 | (apply-subst sigma atom)) | |
| 117 | ((term-is-application-form? atom) | |
| 118 | (let ((l-result nil) | |
| 119 | (modif-sort nil)) | |
| 120 | (let ((pos 0)) | |
| 121 | (dolist (s-t (term-subterms atom)) | |
| 122 | (multiple-value-bind (image-s-t same-sort) | |
| 123 | (apply-subst-2 sigma s-t target-term beta | |
| 124 | target-pos | |
| 125 | (cons pos arg-pos)) | |
| 126 | (unless same-sort | |
| 127 | (setq modif-sort t)) | |
| 128 | (push image-s-t l-result) | |
| 129 | (incf pos))) | |
| 130 | (setq l-result (nreverse l-result)) | |
| 131 | (if modif-sort | |
| 132 | (let ((term-image | |
| 133 | (make-term-with-sort-check (term-head atom) | |
| 134 | l-result))) | |
| 135 | (values term-image | |
| 136 | (sort= (term-sort atom) | |
| 137 | (term-sort term-image)))) | |
| 138 | (values (make-applform (term-sort atom) | |
| 139 | (term-head atom) | |
| 140 | l-result) | |
| 141 | t))))) | |
| 142 | (t (with-output-panic-message () | |
| 143 | (princ "apply-subst: encoutered illegual term") | |
| 144 | (terpri) | |
| 145 | (term-print atom))))) | |
| 108 | (apply-subst sigma beta)) | |
| 109 | ((term-is-variable? atom) | |
| 110 | (let ((im (variable-image sigma atom))) | |
| 111 | (if im | |
| 112 | (values im t) | |
| 113 | (values atom nil)))) | |
| 114 | ((term-is-builtin-constant? atom) atom) | |
| 115 | ((term-is-constant? atom) | |
| 116 | (apply-subst sigma atom)) | |
| 117 | ((term-is-application-form? atom) | |
| 118 | (let ((l-result nil) | |
| 119 | (modif-sort nil)) | |
| 120 | (let ((pos 0)) | |
| 121 | (dolist (s-t (term-subterms atom)) | |
| 122 | (multiple-value-bind (image-s-t same-sort) | |
| 123 | (apply-subst-2 sigma s-t target-term beta | |
| 124 | target-pos | |
| 125 | (cons pos arg-pos)) | |
| 126 | (unless same-sort | |
| 127 | (setq modif-sort t)) | |
| 128 | (push image-s-t l-result) | |
| 129 | (incf pos))) | |
| 130 | (setq l-result (nreverse l-result)) | |
| 131 | (if modif-sort | |
| 132 | (let ((term-image | |
| 133 | (make-term-with-sort-check (term-head atom) | |
| 134 | l-result))) | |
| 135 | (values term-image | |
| 136 | (sort= (term-sort atom) | |
| 137 | (term-sort term-image)))) | |
| 138 | (values (make-applform (term-sort atom) | |
| 139 | (term-head atom) | |
| 140 | l-result) | |
| 141 | t))))) | |
| 142 | (t (with-output-panic-message () | |
| 143 | (princ "apply-subst: encoutered illegual term") | |
| 144 | (terpri) | |
| 145 | (term-print atom))))) | |
| 146 | 146 | |
| 147 | 147 | |
| 148 | 148 | ;;; BUILD-BIN-PARA |
| 150 | 150 | ;;; |
| 151 | 151 | (defun build-bin-para (rule target-term into-lit subst arg-pos) |
| 152 | 152 | (declare (type paramod rule) |
| 153 | (type term target-term) | |
| 154 | (type literal into-lit) | |
| 155 | (type list subst) | |
| 156 | (values clause)) | |
| 153 | (type term target-term) | |
| 154 | (type literal into-lit) | |
| 155 | (type list subst) | |
| 156 | (values clause)) | |
| 157 | 157 | (let ((beta (paramod-rhs rule)) |
| 158 | (from-lit (paramod-literal rule)) | |
| 159 | (into-clause (literal-clause into-lit)) | |
| 160 | (new-literals nil) | |
| 161 | (new-clause (new-clause *current-psys*))) | |
| 158 | (from-lit (paramod-literal rule)) | |
| 159 | (into-clause (literal-clause into-lit)) | |
| 160 | (new-literals nil) | |
| 161 | (new-clause (new-clause *current-psys*))) | |
| 162 | 162 | (declare (type term beta) |
| 163 | (type literal from-lit) | |
| 164 | (type clause into-clause new-clause) | |
| 165 | (type list new-literals)) | |
| 163 | (type literal from-lit) | |
| 164 | (type clause into-clause new-clause) | |
| 165 | (type list new-literals)) | |
| 166 | 166 | (when (or (pn-flag debug-para-into) |
| 167 | (pn-flag debug-para-from)) | |
| 167 | (pn-flag debug-para-from)) | |
| 168 | 168 | (with-output-msg () |
| 169 | (princ "build-bin-para:") | |
| 170 | (print-next) | |
| 171 | (princ "target-term=")(term-print target-term) | |
| 172 | (print-next) | |
| 173 | (princ "subst=") (print-substitution subst) | |
| 174 | (print-next) | |
| 175 | )) | |
| 169 | (princ "build-bin-para:") | |
| 170 | (print-next) | |
| 171 | (princ "target-term=")(term-print target-term) | |
| 172 | (print-next) | |
| 173 | (princ "subst=") (print-substitution subst) | |
| 174 | (print-next) | |
| 175 | )) | |
| 176 | 176 | |
| 177 | 177 | ;; into clause |
| 178 | 178 | (dolist (l (clause-literals into-clause)) |
| 179 | 179 | (declare (type literal l)) |
| 180 | 180 | (let ((new-atom nil) |
| 181 | (new-literal (shallow-copy-literal l new-clause))) | |
| 182 | (declare (type literal new-literal) | |
| 183 | (type (or null term) new-atom)) | |
| 184 | (if (eq l into-lit) | |
| 185 | (setq new-atom (apply-subst-2 subst | |
| 186 | (literal-atom l) | |
| 187 | target-term | |
| 188 | beta | |
| 189 | arg-pos)) | |
| 190 | (setq new-atom (apply-subst subst (literal-atom l)))) | |
| 191 | (setf (literal-atom new-literal) new-atom) | |
| 192 | (mark-literal new-literal) | |
| 193 | (push new-literal new-literals))) | |
| 181 | (new-literal (shallow-copy-literal l new-clause))) | |
| 182 | (declare (type literal new-literal) | |
| 183 | (type (or null term) new-atom)) | |
| 184 | (if (eq l into-lit) | |
| 185 | (setq new-atom (apply-subst-2 subst | |
| 186 | (literal-atom l) | |
| 187 | target-term | |
| 188 | beta | |
| 189 | arg-pos)) | |
| 190 | (setq new-atom (apply-subst subst (literal-atom l)))) | |
| 191 | (setf (literal-atom new-literal) new-atom) | |
| 192 | (mark-literal new-literal) | |
| 193 | (push new-literal new-literals))) | |
| 194 | 194 | ;; from clause |
| 195 | 195 | (dolist (l (clause-literals (literal-clause from-lit))) |
| 196 | 196 | (declare (type literal l)) |
| 197 | 197 | (unless (eq l from-lit) |
| 198 | (let ((new-atom nil) | |
| 199 | (new-literal (shallow-copy-literal l new-clause))) | |
| 200 | (setq new-atom (apply-subst subst (literal-atom l))) | |
| 201 | (setf (literal-atom new-literal) new-atom) | |
| 202 | (mark-literal new-literal) | |
| 203 | (push new-literal new-literals)))) | |
| 198 | (let ((new-atom nil) | |
| 199 | (new-literal (shallow-copy-literal l new-clause))) | |
| 200 | (setq new-atom (apply-subst subst (literal-atom l))) | |
| 201 | (setf (literal-atom new-literal) new-atom) | |
| 202 | (mark-literal new-literal) | |
| 203 | (push new-literal new-literals)))) | |
| 204 | 204 | ;; |
| 205 | 205 | (setf (clause-literals new-clause) (nreverse new-literals)) |
| 206 | 206 | (when (or (pn-flag debug-para-into) |
| 207 | (pn-flag debug-para-from)) | |
| 207 | (pn-flag debug-para-from)) | |
| 208 | 208 | (with-output-msg () |
| 209 | (princ "build-bin-pra: new clause=") | |
| 210 | (print-clause new-clause))) | |
| 209 | (princ "build-bin-pra: new clause=") | |
| 210 | (print-clause new-clause))) | |
| 211 | 211 | ;; |
| 212 | 212 | ;; (register-clause new-clause *current-psys*) |
| 213 | 213 | new-clause |
| 217 | 217 | ;;; |
| 218 | 218 | (defun para-into-terms-alpha (para-rule term lit &optional arg-pos) |
| 219 | 219 | (declare (type paramod para-rule) |
| 220 | (type term term) | |
| 221 | (type literal lit) | |
| 222 | (list arg-pos) | |
| 223 | (values list)) | |
| 220 | (type term term) | |
| 221 | (type literal lit) | |
| 222 | (list arg-pos) | |
| 223 | (values list)) | |
| 224 | 224 | (let ((paras nil)) |
| 225 | 225 | (declare (type list paras)) |
| 226 | 226 | (when (term-is-application-form? term) |
| 227 | 227 | (cond ((eq (term-head term) *fopl-eq*) |
| 228 | (when (pn-flag para-into-left) | |
| 229 | (setq paras | |
| 230 | (nconc paras | |
| 231 | (para-into-terms-alpha para-rule | |
| 232 | (term-arg-1 term) | |
| 233 | lit | |
| 234 | (cons 0 arg-pos) | |
| 235 | )))) | |
| 236 | (when (pn-flag para-into-right) | |
| 237 | (setq paras | |
| 238 | (nconc paras | |
| 239 | (para-into-terms-alpha para-rule | |
| 240 | (term-arg-2 term) | |
| 241 | lit | |
| 242 | (cons 1 arg-pos) | |
| 243 | )))) | |
| 244 | (return-from para-into-terms-alpha paras)) | |
| 245 | ;; | |
| 246 | (t (let ((pos 0)) | |
| 247 | (declare (type fixnum pos)) | |
| 248 | (dolist (sub-t (term-subterms term)) | |
| 249 | (setq paras | |
| 250 | (nconc paras | |
| 251 | (para-into-terms-alpha para-rule | |
| 252 | sub-t | |
| 253 | lit | |
| 254 | (cons pos arg-pos)))) | |
| 255 | (incf pos)))) | |
| 256 | )) | |
| 228 | (when (pn-flag para-into-left) | |
| 229 | (setq paras | |
| 230 | (nconc paras | |
| 231 | (para-into-terms-alpha para-rule | |
| 232 | (term-arg-1 term) | |
| 233 | lit | |
| 234 | (cons 0 arg-pos) | |
| 235 | )))) | |
| 236 | (when (pn-flag para-into-right) | |
| 237 | (setq paras | |
| 238 | (nconc paras | |
| 239 | (para-into-terms-alpha para-rule | |
| 240 | (term-arg-2 term) | |
| 241 | lit | |
| 242 | (cons 1 arg-pos) | |
| 243 | )))) | |
| 244 | (return-from para-into-terms-alpha paras)) | |
| 245 | ;; | |
| 246 | (t (let ((pos 0)) | |
| 247 | (declare (type fixnum pos)) | |
| 248 | (dolist (sub-t (term-subterms term)) | |
| 249 | (setq paras | |
| 250 | (nconc paras | |
| 251 | (para-into-terms-alpha para-rule | |
| 252 | sub-t | |
| 253 | lit | |
| 254 | (cons pos arg-pos)))) | |
| 255 | (incf pos)))) | |
| 256 | )) | |
| 257 | 257 | #|| |
| 258 | 258 | (when (term-is-application-form? term) |
| 259 | 259 | (let ((pos 0)) |
| 260 | (declare (type fixnum pos)) | |
| 261 | (dolist (sub-t (term-subterms term)) | |
| 262 | (setq paras | |
| 263 | (nconc paras | |
| 264 | (para-into-terms-alpha para-rule | |
| 265 | sub-t | |
| 266 | lit | |
| 267 | (cons pos arg-pos)))) | |
| 268 | (incf pos)))) | |
| 260 | (declare (type fixnum pos)) | |
| 261 | (dolist (sub-t (term-subterms term)) | |
| 262 | (setq paras | |
| 263 | (nconc paras | |
| 264 | (para-into-terms-alpha para-rule | |
| 265 | sub-t | |
| 266 | lit | |
| 267 | (cons pos arg-pos)))) | |
| 268 | (incf pos)))) | |
| 269 | 269 | ||# |
| 270 | 270 | ;; |
| 271 | 271 | ;; HEY! |
| 272 | 272 | ;; |
| 273 | 273 | (when (term-is-variable? term) |
| 274 | 274 | (unless (pn-flag para-into-vars) |
| 275 | (return-from para-into-terms-alpha nil))) | |
| 275 | (return-from para-into-terms-alpha nil))) | |
| 276 | 276 | ;; |
| 277 | 277 | (let ((lhs (paramod-lhs para-rule)) |
| 278 | (p-lit (paramod-literal para-rule)) | |
| 279 | (in-subst nil) | |
| 280 | (paramod nil) | |
| 281 | (same nil) | |
| 282 | (junk-cl-id nil)) | |
| 278 | (p-lit (paramod-literal para-rule)) | |
| 279 | (in-subst nil) | |
| 280 | (paramod nil) | |
| 281 | (same nil) | |
| 282 | (junk-cl-id nil)) | |
| 283 | 283 | (declare (ignore same) |
| 284 | (type term lhs) | |
| 285 | (type literal p-lit) | |
| 286 | (type list in-subst) | |
| 287 | (type (or null clause) paramod) | |
| 288 | (type (or null fixnum) junk-cl-id)) | |
| 284 | (type term lhs) | |
| 285 | (type literal p-lit) | |
| 286 | (type list in-subst) | |
| 287 | (type (or null clause) paramod) | |
| 288 | (type (or null fixnum) junk-cl-id)) | |
| 289 | 289 | ;; ** |
| 290 | 290 | (when (eq (literal-clause p-lit) |
| 291 | (literal-clause lit)) | |
| 292 | ;; (setq same t) | |
| 293 | (multiple-value-bind (new-cl llit id) | |
| 294 | (make-dummy-clause (literal-clause lit) lit) | |
| 295 | (declare (ignore new-cl)) | |
| 296 | (setq junk-cl-id id) | |
| 297 | (setq lit llit) | |
| 298 | (setq term (literal-atom lit)) | |
| 299 | (when arg-pos | |
| 300 | (setq term (get-term-at arg-pos term))) | |
| 301 | )) | |
| 291 | (literal-clause lit)) | |
| 292 | ;; (setq same t) | |
| 293 | (multiple-value-bind (new-cl llit id) | |
| 294 | (make-dummy-clause (literal-clause lit) lit) | |
| 295 | (declare (ignore new-cl)) | |
| 296 | (setq junk-cl-id id) | |
| 297 | (setq lit llit) | |
| 298 | (setq term (literal-atom lit)) | |
| 299 | (when arg-pos | |
| 300 | (setq term (get-term-at arg-pos term))) | |
| 301 | )) | |
| 302 | 302 | ;; |
| 303 | 303 | ;; (trace unify) |
| 304 | 304 | ;; |
| 305 | 305 | (multiple-value-bind (new-subst no-match e-equal) |
| 306 | (unify lhs term in-subst) | |
| 307 | (declare (ignore e-equal)) | |
| 308 | (if no-match | |
| 309 | (when junk-cl-id | |
| 310 | (delete-clause! junk-cl-id *current-psys*)) | |
| 311 | (progn | |
| 312 | ;; ******* | |
| 313 | #|| | |
| 314 | (when same | |
| 315 | ;; *****: | |
| 316 | (with-output-msg () | |
| 317 | (princ "TAAAAAAAAAAAAAAA!!!!") | |
| 318 | (print-next) | |
| 319 | (format t "from paramod: ~a" para-rule) | |
| 320 | (print-next) | |
| 321 | (format t "target cl : ") | |
| 322 | (print-clause (literal-clause lit)) | |
| 323 | (print-next) | |
| 324 | (format t "target term : ") | |
| 325 | (term-print (literal-atom lit)) | |
| 326 | ) | |
| 327 | ;; (setf (pn-flag debug-para-from) t) | |
| 328 | ) | |
| 329 | ||# | |
| 330 | ;; ***** | |
| 331 | ||
| 332 | (when (pn-flag debug-para-from) | |
| 333 | (with-output-msg () | |
| 334 | (princ "para-from: success with rule =") | |
| 335 | (prin1 para-rule) | |
| 336 | (print-next) | |
| 337 | (princ "from clause : ") (print-clause (literal-clause p-lit)) | |
| 338 | (print-next) | |
| 339 | (princ "target clause : ") (print-clause (literal-clause lit)) | |
| 340 | (print-next) | |
| 341 | (princ "target literal: ") (prin1 lit))) | |
| 342 | (setq paramod (build-bin-para para-rule term lit new-subst | |
| 343 | arg-pos)) | |
| 344 | (when junk-cl-id | |
| 345 | (delete-clause! junk-cl-id *current-psys*)) | |
| 346 | (setf (clause-parents paramod) | |
| 347 | (list (list :para-from-rule | |
| 348 | (clause-id (literal-clause p-lit)) | |
| 349 | (clause-id (literal-clause lit))))) | |
| 350 | ;; | |
| 351 | (incf (pn-stat cl-generated)) | |
| 352 | (incf (pn-stat para-from-gen)) | |
| 353 | (let ((pre-res nil)) | |
| 354 | (setq pre-res (pre-process paramod nil :sos)) | |
| 355 | (when pre-res | |
| 356 | (setq paras | |
| 357 | (nconc paras (list paramod))))) | |
| 358 | )))) | |
| 306 | (unify lhs term in-subst) | |
| 307 | (declare (ignore e-equal)) | |
| 308 | (if no-match | |
| 309 | (when junk-cl-id | |
| 310 | (delete-clause! junk-cl-id *current-psys*)) | |
| 311 | (progn | |
| 312 | ;; ******* | |
| 313 | #|| | |
| 314 | (when same | |
| 315 | ;; *****: | |
| 316 | (with-output-msg () | |
| 317 | (princ "TAAAAAAAAAAAAAAA!!!!") | |
| 318 | (print-next) | |
| 319 | (format t "from paramod: ~a" para-rule) | |
| 320 | (print-next) | |
| 321 | (format t "target cl : ") | |
| 322 | (print-clause (literal-clause lit)) | |
| 323 | (print-next) | |
| 324 | (format t "target term : ") | |
| 325 | (term-print (literal-atom lit)) | |
| 326 | ) | |
| 327 | ;; (setf (pn-flag debug-para-from) t) | |
| 328 | ) | |
| 329 | ||# | |
| 330 | ;; ***** | |
| 331 | ||
| 332 | (when (pn-flag debug-para-from) | |
| 333 | (with-output-msg () | |
| 334 | (princ "para-from: success with rule =") | |
| 335 | (prin1 para-rule) | |
| 336 | (print-next) | |
| 337 | (princ "from clause : ") (print-clause (literal-clause p-lit)) | |
| 338 | (print-next) | |
| 339 | (princ "target clause : ") (print-clause (literal-clause lit)) | |
| 340 | (print-next) | |
| 341 | (princ "target literal: ") (prin1 lit))) | |
| 342 | (setq paramod (build-bin-para para-rule term lit new-subst | |
| 343 | arg-pos)) | |
| 344 | (when junk-cl-id | |
| 345 | (delete-clause! junk-cl-id *current-psys*)) | |
| 346 | (setf (clause-parents paramod) | |
| 347 | (list (list :para-from-rule | |
| 348 | (clause-id (literal-clause p-lit)) | |
| 349 | (clause-id (literal-clause lit))))) | |
| 350 | ;; | |
| 351 | (incf (pn-stat cl-generated)) | |
| 352 | (incf (pn-stat para-from-gen)) | |
| 353 | (let ((pre-res nil)) | |
| 354 | (setq pre-res (pre-process paramod nil :sos)) | |
| 355 | (when pre-res | |
| 356 | (setq paras | |
| 357 | (nconc paras (list paramod))))) | |
| 358 | )))) | |
| 359 | 359 | ;;; |
| 360 | 360 | ;;; (setf (pn-flag debug-para-from) nil) |
| 361 | 361 | ;; (untrace unify) |
| 366 | 366 | ;;; |
| 367 | 367 | (defun para-from-alpha (para-rule from-lit) |
| 368 | 368 | (declare (type paramod para-rule) |
| 369 | (type literal from-lit) | |
| 370 | (values list)) | |
| 369 | (type literal from-lit) | |
| 370 | (values list)) | |
| 371 | 371 | (let ((list-para nil) |
| 372 | (lhs (paramod-lhs para-rule))) | |
| 372 | (lhs (paramod-lhs para-rule))) | |
| 373 | 373 | (declare (type list list-para)) |
| 374 | 374 | (dolist (cl (if (term-is-variable? lhs) |
| 375 | *usable* | |
| 376 | (get-clashable-clauses-from-atom *clash-lit-table* | |
| 377 | lhs))) | |
| 375 | *usable* | |
| 376 | (get-clashable-clauses-from-atom *clash-lit-table* | |
| 377 | lhs))) | |
| 378 | 378 | (declare (type clause cl)) |
| 379 | 379 | (when (or (not (pn-flag para-from-units-only)) |
| 380 | (unit-clause? cl)) | |
| 381 | (dolist (lit (clause-literals cl)) | |
| 382 | (unless (eq lit from-lit) | |
| 383 | (let ((atom (literal-atom lit))) | |
| 384 | (setq list-para | |
| 385 | (nconc list-para | |
| 386 | (para-into-terms-alpha para-rule atom lit)))) | |
| 387 | ) | |
| 388 | ) | |
| 389 | )) | |
| 380 | (unit-clause? cl)) | |
| 381 | (dolist (lit (clause-literals cl)) | |
| 382 | (unless (eq lit from-lit) | |
| 383 | (let ((atom (literal-atom lit))) | |
| 384 | (setq list-para | |
| 385 | (nconc list-para | |
| 386 | (para-into-terms-alpha para-rule atom lit)))) | |
| 387 | ) | |
| 388 | ) | |
| 389 | )) | |
| 390 | 390 | list-para |
| 391 | 391 | )) |
| 392 | 392 | |
| 396 | 396 | ;;; |
| 397 | 397 | (defun paramodulation-from (clause) |
| 398 | 398 | (declare (type clause clause) |
| 399 | (values list)) | |
| 399 | (values list)) | |
| 400 | 400 | (let ((paras nil)) |
| 401 | 401 | (declare (type list paras)) |
| 402 | 402 | (when (or (pn-flag debug-infer) |
| 403 | (pn-flag debug-para-from)) | |
| 403 | (pn-flag debug-para-from)) | |
| 404 | 404 | (with-output-msg () |
| 405 | (princ "Begin[paramod-from]:"))) | |
| 405 | (princ "Begin[paramod-from]:"))) | |
| 406 | 406 | (when (or (not (pn-flag para-from-units-only)) |
| 407 | (unit-clause? clause)) | |
| 407 | (unit-clause? clause)) | |
| 408 | 408 | (dolist (from-lit (clause-literals clause)) |
| 409 | (declare (type literal from-lit)) | |
| 410 | (block next | |
| 411 | (let ((atom (literal-atom from-lit))) | |
| 412 | (declare (type term atom)) | |
| 413 | (when (and (positive-eq-literal? from-lit) | |
| 414 | (not (term-is-identical (term-arg-1 atom) | |
| 415 | (term-arg-2 atom)))) | |
| 416 | (let ((para-rule (make-paramod :literal from-lit))) | |
| 417 | (declare (type paramod para-rule)) | |
| 418 | (when (pn-flag para-from-left) | |
| 419 | (when (term-is-variable? (term-arg-1 atom)) | |
| 420 | (unless (pn-flag para-from-vars) | |
| 421 | (return-from next nil))) | |
| 422 | (setf (paramod-lhs para-rule) (term-arg-1 atom) | |
| 423 | (paramod-rhs para-rule) (term-arg-2 atom)) | |
| 424 | (setq paras | |
| 425 | (nconc paras | |
| 426 | (para-from-alpha para-rule from-lit)))) | |
| 427 | (when (pn-flag para-from-right) | |
| 428 | (when (term-is-variable? (term-arg-2 atom)) | |
| 429 | (unless (pn-flag para-from-vars) | |
| 430 | (return-from next nil))) | |
| 431 | (setf (paramod-lhs para-rule) (term-arg-2 atom)) | |
| 432 | (setf (paramod-rhs para-rule) (term-arg-1 atom)) | |
| 433 | (setq paras | |
| 434 | (nconc paras | |
| 435 | (para-from-alpha para-rule from-lit)))))) | |
| 436 | )) ; block next | |
| 437 | ) ; dolist | |
| 409 | (declare (type literal from-lit)) | |
| 410 | (block next | |
| 411 | (let ((atom (literal-atom from-lit))) | |
| 412 | (declare (type term atom)) | |
| 413 | (when (and (positive-eq-literal? from-lit) | |
| 414 | (not (term-is-identical (term-arg-1 atom) | |
| 415 | (term-arg-2 atom)))) | |
| 416 | (let ((para-rule (make-paramod :literal from-lit))) | |
| 417 | (declare (type paramod para-rule)) | |
| 418 | (when (pn-flag para-from-left) | |
| 419 | (when (term-is-variable? (term-arg-1 atom)) | |
| 420 | (unless (pn-flag para-from-vars) | |
| 421 | (return-from next nil))) | |
| 422 | (setf (paramod-lhs para-rule) (term-arg-1 atom) | |
| 423 | (paramod-rhs para-rule) (term-arg-2 atom)) | |
| 424 | (setq paras | |
| 425 | (nconc paras | |
| 426 | (para-from-alpha para-rule from-lit)))) | |
| 427 | (when (pn-flag para-from-right) | |
| 428 | (when (term-is-variable? (term-arg-2 atom)) | |
| 429 | (unless (pn-flag para-from-vars) | |
| 430 | (return-from next nil))) | |
| 431 | (setf (paramod-lhs para-rule) (term-arg-2 atom)) | |
| 432 | (setf (paramod-rhs para-rule) (term-arg-1 atom)) | |
| 433 | (setq paras | |
| 434 | (nconc paras | |
| 435 | (para-from-alpha para-rule from-lit)))))) | |
| 436 | )) ; block next | |
| 437 | ) ; dolist | |
| 438 | 438 | ) |
| 439 | 439 | ;; |
| 440 | 440 | (when (or (pn-flag debug-infer) |
| 441 | (pn-flag debug-para-from)) | |
| 441 | (pn-flag debug-para-from)) | |
| 442 | 442 | (with-output-msg () |
| 443 | (princ "End[paramod-from]:"))) | |
| 443 | (princ "End[paramod-from]:"))) | |
| 444 | 444 | paras)) |
| 445 | 445 | |
| 446 | 446 | ;;; PARA-INTO-TERMS |
| 447 | 447 | ;;; |
| 448 | 448 | (defun para-into-terms (target-term into-lit &optional arg-pos) |
| 449 | 449 | (declare (type term target-term) |
| 450 | (type literal into-lit) | |
| 451 | (type list arg-pos) | |
| 452 | (values list)) | |
| 450 | (type literal into-lit) | |
| 451 | (type list arg-pos) | |
| 452 | (values list)) | |
| 453 | 453 | (let ((paras nil)) |
| 454 | 454 | (declare (type list paras)) |
| 455 | 455 | (when (term-is-application-form? target-term) |
| 456 | 456 | #|| |
| 457 | 457 | (let ((pos 0)) |
| 458 | (declare (type fixnum pos)) | |
| 459 | (dolist (sub-t (term-subterms target-term)) | |
| 460 | (setq paras | |
| 461 | (nconc paras | |
| 462 | (para-into-terms sub-t | |
| 463 | into-lit | |
| 464 | (cons pos arg-pos)))) | |
| 465 | (incf pos))) | |
| 458 | (declare (type fixnum pos)) | |
| 459 | (dolist (sub-t (term-subterms target-term)) | |
| 460 | (setq paras | |
| 461 | (nconc paras | |
| 462 | (para-into-terms sub-t | |
| 463 | into-lit | |
| 464 | (cons pos arg-pos)))) | |
| 465 | (incf pos))) | |
| 466 | 466 | ||# |
| 467 | 467 | (cond ((eq (term-head target-term) *fopl-eq*) |
| 468 | (when (pn-flag para-into-left) | |
| 469 | (setq paras | |
| 470 | (nconc paras (para-into-terms (term-arg-1 target-term) | |
| 471 | into-lit | |
| 472 | ;; arg-pos ; '(0) | |
| 473 | (cons 0 arg-pos) | |
| 474 | )))) | |
| 475 | (when (pn-flag para-into-right) | |
| 476 | (setq paras | |
| 477 | (nconc paras (para-into-terms (term-arg-2 target-term) | |
| 478 | into-lit | |
| 479 | ;; arg-pos ; '(1) | |
| 480 | (cons 1 arg-pos) | |
| 481 | )))) | |
| 482 | (return-from para-into-terms paras)) | |
| 483 | ;; | |
| 484 | (t (let ((pos 0)) | |
| 485 | (declare (type fixnum pos)) | |
| 486 | (dolist (sub-t (term-subterms target-term)) | |
| 487 | (setq paras | |
| 488 | (nconc paras | |
| 489 | (para-into-terms sub-t | |
| 490 | into-lit | |
| 491 | (cons pos arg-pos)))) | |
| 492 | (incf pos)))) | |
| 493 | ) | |
| 468 | (when (pn-flag para-into-left) | |
| 469 | (setq paras | |
| 470 | (nconc paras (para-into-terms (term-arg-1 target-term) | |
| 471 | into-lit | |
| 472 | ;; arg-pos ; '(0) | |
| 473 | (cons 0 arg-pos) | |
| 474 | )))) | |
| 475 | (when (pn-flag para-into-right) | |
| 476 | (setq paras | |
| 477 | (nconc paras (para-into-terms (term-arg-2 target-term) | |
| 478 | into-lit | |
| 479 | ;; arg-pos ; '(1) | |
| 480 | (cons 1 arg-pos) | |
| 481 | )))) | |
| 482 | (return-from para-into-terms paras)) | |
| 483 | ;; | |
| 484 | (t (let ((pos 0)) | |
| 485 | (declare (type fixnum pos)) | |
| 486 | (dolist (sub-t (term-subterms target-term)) | |
| 487 | (setq paras | |
| 488 | (nconc paras | |
| 489 | (para-into-terms sub-t | |
| 490 | into-lit | |
| 491 | (cons pos arg-pos)))) | |
| 492 | (incf pos)))) | |
| 493 | ) | |
| 494 | 494 | ) |
| 495 | 495 | #|| |
| 496 | 496 | (when (and (term-is-variable? target-term) |
| 497 | (not (pn-flag para-into-vars))) | |
| 497 | (not (pn-flag para-into-vars))) | |
| 498 | 498 | (return-from para-into-terms nil)) |
| 499 | 499 | ||# |
| 500 | 500 | (when (pn-flag debug-para-into) |
| 501 | 501 | (with-output-msg () |
| 502 | (princ "para-into-terms: target=") | |
| 503 | (term-print target-term))) | |
| 502 | (princ "para-into-terms: target=") | |
| 503 | (term-print target-term))) | |
| 504 | 504 | ;; |
| 505 | 505 | (dolist (para-rule |
| 506 | #|| | |
| 507 | (append (get-literal-entry-from-atom *paramod-rules* | |
| 508 | target-term) | |
| 509 | (if (pn-flag para-from-vars) | |
| 510 | (get-literal-entry-from-atom *paramod-rules* | |
| 511 | (term-sort | |
| 512 | target-term))) | |
| 513 | nil) | |
| 514 | ||# | |
| 515 | (is-paramod-fetch-concat target-term *paramod-rules*) | |
| 516 | ) | |
| 506 | #|| | |
| 507 | (append (get-literal-entry-from-atom *paramod-rules* | |
| 508 | target-term) | |
| 509 | (if (pn-flag para-from-vars) | |
| 510 | (get-literal-entry-from-atom *paramod-rules* | |
| 511 | (term-sort | |
| 512 | target-term))) | |
| 513 | nil) | |
| 514 | ||# | |
| 515 | (is-paramod-fetch-concat target-term *paramod-rules*) | |
| 516 | ) | |
| 517 | 517 | (declare (type paramod para-rule)) |
| 518 | 518 | (block next |
| 519 | 519 | |
| 520 | (when (pn-flag debug-para-into) | |
| 521 | (with-output-simple-msg () | |
| 522 | (princ "para-into: rule = ") | |
| 523 | (princ para-rule))) | |
| 524 | ||
| 525 | (let* ((lhs (paramod-lhs para-rule)) | |
| 526 | (from-lit (paramod-literal para-rule)) | |
| 527 | (in-subst nil) | |
| 528 | (paramod nil) | |
| 529 | (same nil) | |
| 530 | (obso-cl-id nil)) | |
| 531 | (declare (ignore in-subst) | |
| 532 | (type term lhs) | |
| 533 | (type literal from-lit) | |
| 534 | (type list in-subst) | |
| 535 | (type (or null clause) paramod) | |
| 536 | (ignore same) | |
| 537 | (type (or null fixnum) obso-cl-id)) | |
| 538 | #|| | |
| 539 | (when (term-eq lhs target-term) | |
| 540 | (return-from next nil)) | |
| 541 | ||# | |
| 542 | ;; *** | |
| 543 | (when (eq (literal-clause into-lit) | |
| 544 | (literal-clause from-lit)) | |
| 545 | ;; (setq same t) | |
| 546 | (multiple-value-bind (new-cl llit cl-id) | |
| 547 | (make-dummy-clause (literal-clause into-lit) into-lit) | |
| 548 | (declare (ignore new-cl) | |
| 549 | (type literal llit) | |
| 550 | (type fixnum cl-id)) | |
| 551 | (setq into-lit llit) | |
| 552 | (setq obso-cl-id cl-id) | |
| 553 | (setq target-term (literal-atom into-lit)) | |
| 554 | (when arg-pos | |
| 555 | (setq target-term (get-term-at arg-pos target-term)) | |
| 556 | )) | |
| 557 | ) | |
| 558 | ;; *** | |
| 559 | ;; (trace unify) | |
| 560 | (multiple-value-bind (new-subst no-match e-equal) | |
| 561 | (unify lhs target-term nil) | |
| 562 | (declare (ignore e-equal) | |
| 563 | (type list new-subst)) | |
| 564 | (when no-match | |
| 565 | (when obso-cl-id | |
| 566 | (delete-clause! obso-cl-id *current-psys*)) | |
| 567 | (return-from next nil)) | |
| 568 | ;; | |
| 569 | #|| | |
| 570 | (when same | |
| 571 | ;; *** | |
| 572 | (with-output-msg () | |
| 573 | (princ "HAAAAAAAAAAAAAAAAA!!!!!!") | |
| 574 | (print-next) | |
| 575 | (format t "paramod : ~a" para-rule) | |
| 576 | (print-next) | |
| 577 | (format t "into : ") | |
| 578 | (print-clause (literal-clause into-lit)) | |
| 579 | (print-next) | |
| 580 | (format t "target term : ") | |
| 581 | (term-print (literal-atom into-lit)) | |
| 582 | ) | |
| 583 | ;; (setf (pn-flag debug-para-into) t) | |
| 584 | ) | |
| 585 | ||# | |
| 586 | ;; *** | |
| 587 | ||
| 588 | (when (pn-flag debug-para-into) | |
| 589 | (with-output-msg () | |
| 590 | (format t "para-into-terms: matched p-rule = ") | |
| 591 | (pr-paramod para-rule)) | |
| 592 | ) | |
| 593 | (setq paramod | |
| 594 | (build-bin-para para-rule target-term into-lit new-subst arg-pos)) | |
| 595 | (when obso-cl-id | |
| 596 | (delete-clause! obso-cl-id *current-psys*)) | |
| 597 | (setf (clause-parents paramod) | |
| 598 | (list (list :para-into-rule | |
| 599 | (clause-id (literal-clause into-lit)) | |
| 600 | (clause-id (literal-clause from-lit))))) | |
| 601 | ;; | |
| 602 | (incf (pn-stat cl-generated)) | |
| 603 | (incf (pn-stat para-into-gen)) | |
| 604 | (let ((pre-res nil)) | |
| 605 | (setq pre-res (pre-process paramod nil :sos)) | |
| 606 | (when pre-res | |
| 607 | (setq paras | |
| 608 | (nconc paras (list paramod))))) | |
| 609 | )))) | |
| 520 | (when (pn-flag debug-para-into) | |
| 521 | (with-output-simple-msg () | |
| 522 | (princ "para-into: rule = ") | |
| 523 | (princ para-rule))) | |
| 524 | ||
| 525 | (let* ((lhs (paramod-lhs para-rule)) | |
| 526 | (from-lit (paramod-literal para-rule)) | |
| 527 | (in-subst nil) | |
| 528 | (paramod nil) | |
| 529 | (same nil) | |
| 530 | (obso-cl-id nil)) | |
| 531 | (declare (ignore in-subst) | |
| 532 | (type term lhs) | |
| 533 | (type literal from-lit) | |
| 534 | (type list in-subst) | |
| 535 | (type (or null clause) paramod) | |
| 536 | (ignore same) | |
| 537 | (type (or null fixnum) obso-cl-id)) | |
| 538 | #|| | |
| 539 | (when (term-eq lhs target-term) | |
| 540 | (return-from next nil)) | |
| 541 | ||# | |
| 542 | ;; *** | |
| 543 | (when (eq (literal-clause into-lit) | |
| 544 | (literal-clause from-lit)) | |
| 545 | ;; (setq same t) | |
| 546 | (multiple-value-bind (new-cl llit cl-id) | |
| 547 | (make-dummy-clause (literal-clause into-lit) into-lit) | |
| 548 | (declare (ignore new-cl) | |
| 549 | (type literal llit) | |
| 550 | (type fixnum cl-id)) | |
| 551 | (setq into-lit llit) | |
| 552 | (setq obso-cl-id cl-id) | |
| 553 | (setq target-term (literal-atom into-lit)) | |
| 554 | (when arg-pos | |
| 555 | (setq target-term (get-term-at arg-pos target-term)) | |
| 556 | )) | |
| 557 | ) | |
| 558 | ;; *** | |
| 559 | ;; (trace unify) | |
| 560 | (multiple-value-bind (new-subst no-match e-equal) | |
| 561 | (unify lhs target-term nil) | |
| 562 | (declare (ignore e-equal) | |
| 563 | (type list new-subst)) | |
| 564 | (when no-match | |
| 565 | (when obso-cl-id | |
| 566 | (delete-clause! obso-cl-id *current-psys*)) | |
| 567 | (return-from next nil)) | |
| 568 | ;; | |
| 569 | #|| | |
| 570 | (when same | |
| 571 | ;; *** | |
| 572 | (with-output-msg () | |
| 573 | (princ "HAAAAAAAAAAAAAAAAA!!!!!!") | |
| 574 | (print-next) | |
| 575 | (format t "paramod : ~a" para-rule) | |
| 576 | (print-next) | |
| 577 | (format t "into : ") | |
| 578 | (print-clause (literal-clause into-lit)) | |
| 579 | (print-next) | |
| 580 | (format t "target term : ") | |
| 581 | (term-print (literal-atom into-lit)) | |
| 582 | ) | |
| 583 | ;; (setf (pn-flag debug-para-into) t) | |
| 584 | ) | |
| 585 | ||# | |
| 586 | ;; *** | |
| 587 | ||
| 588 | (when (pn-flag debug-para-into) | |
| 589 | (with-output-msg () | |
| 590 | (format t "para-into-terms: matched p-rule = ") | |
| 591 | (pr-paramod para-rule)) | |
| 592 | ) | |
| 593 | (setq paramod | |
| 594 | (build-bin-para para-rule target-term into-lit new-subst arg-pos)) | |
| 595 | (when obso-cl-id | |
| 596 | (delete-clause! obso-cl-id *current-psys*)) | |
| 597 | (setf (clause-parents paramod) | |
| 598 | (list (list :para-into-rule | |
| 599 | (clause-id (literal-clause into-lit)) | |
| 600 | (clause-id (literal-clause from-lit))))) | |
| 601 | ;; | |
| 602 | (incf (pn-stat cl-generated)) | |
| 603 | (incf (pn-stat para-into-gen)) | |
| 604 | (let ((pre-res nil)) | |
| 605 | (setq pre-res (pre-process paramod nil :sos)) | |
| 606 | (when pre-res | |
| 607 | (setq paras | |
| 608 | (nconc paras (list paramod))))) | |
| 609 | )))) | |
| 610 | 610 | ;; ::: |
| 611 | 611 | ;; (setf (pn-flag debug-para-into) nil) |
| 612 | 612 | ;; (untrace unify) |
| 619 | 619 | ;;; |
| 620 | 620 | (defun paramodulation-into (clause) |
| 621 | 621 | (declare (type clause clause) |
| 622 | (values list)) | |
| 622 | (values list)) | |
| 623 | 623 | (let ((list-para nil)) |
| 624 | 624 | (declare (type list list-para)) |
| 625 | 625 | (when (or (not (pn-flag para-into-units-only)) |
| 626 | (unit-clause? clause)) | |
| 626 | (unit-clause? clause)) | |
| 627 | 627 | ;; |
| 628 | 628 | (when (or (pn-flag debug-infer) |
| 629 | (pn-flag debug-para-into)) | |
| 630 | (with-output-msg () | |
| 631 | (format t "Start[paramodulation-into]: "))) | |
| 629 | (pn-flag debug-para-into)) | |
| 630 | (with-output-msg () | |
| 631 | (format t "Start[paramodulation-into]: "))) | |
| 632 | 632 | ;; |
| 633 | 633 | (dolist (into-lit (clause-literals clause)) |
| 634 | (declare (type literal into-lit)) | |
| 635 | (block next | |
| 636 | (unless (answer-literal? into-lit) | |
| 637 | (let ((atom (literal-atom into-lit))) | |
| 638 | (setq list-para | |
| 639 | (nconc list-para | |
| 640 | (para-into-terms atom into-lit)))))))) | |
| 634 | (declare (type literal into-lit)) | |
| 635 | (block next | |
| 636 | (unless (answer-literal? into-lit) | |
| 637 | (let ((atom (literal-atom into-lit))) | |
| 638 | (setq list-para | |
| 639 | (nconc list-para | |
| 640 | (para-into-terms atom into-lit)))))))) | |
| 641 | 641 | ;; |
| 642 | 642 | (when (or (pn-flag debug-infer) |
| 643 | (pn-flag debug-para-into)) | |
| 643 | (pn-flag debug-para-into)) | |
| 644 | 644 | (with-output-msg () |
| 645 | (format t "End[para-into]:") | |
| 646 | (print-next) | |
| 647 | (pr-clause-list list-para t))) | |
| 645 | (format t "End[para-into]:") | |
| 646 | (print-next) | |
| 647 | (pr-clause-list list-para t))) | |
| 648 | 648 | ;; |
| 649 | 649 | list-para |
| 650 | 650 | )) |
| 0 | 0 | ;;;-*-Mode:LISP; Package: CHAOS; Base:10; Syntax:Common-lisp -*- |
| 1 | 1 | ;;; |
| 2 | ;;; Copyright (c) 2000-2014, Toshimi Sawada. All rights reserved. | |
| 2 | ;;; Copyright (c) 2000-2015, Toshimi Sawada. All rights reserved. | |
| 3 | 3 | ;;; |
| 4 | 4 | ;;; Redistribution and use in source and binary forms, with or without |
| 5 | 5 | ;;; modification, are permitted provided that the following conditions |
| 28 | 28 | ;;; |
| 29 | 29 | (in-package :chaos) |
| 30 | 30 | #|============================================================================= |
| 31 | System:Chaos | |
| 32 | Module:BigPink | |
| 33 | File:proof-sys.lisp | |
| 31 | System:Chaos | |
| 32 | Module:BigPink | |
| 33 | File:proof-sys.lisp | |
| 34 | 34 | =============================================================================|# |
| 35 | 35 | #-:chaos-debug |
| 36 | 36 | (declaim (optimize (speed 3) (safety 0) #-GCL (debug 0))) |
| 38 | 38 | (declaim (optimize (speed 1) (safety 3) #-GCL (debug 3))) |
| 39 | 39 | |
| 40 | 40 | ;;;***************************************************************************** |
| 41 | ;;; PROOF SYSTEM ASSOCIATED WITH MODULE | |
| 41 | ;;; PROOF SYSTEM ASSOCIATED WITH MODULE | |
| 42 | 42 | ;;;***************************************************************************** |
| 43 | 43 | |
| 44 | 44 | ;;; extend module info |
| 45 | 45 | |
| 46 | 46 | (defmacro module-proof-system (_mod) |
| 47 | 47 | `(getf (object-misc-info ,_mod) :proof-system)) |
| 48 | ||
| 48 | ||
| 49 | 49 | (defun create-module-psystem (mod) |
| 50 | 50 | (declare (type module mod)) |
| 51 | 51 | (if (module-proof-system mod) |
| 52 | 52 | (let ((psys (module-proof-system mod))) |
| 53 | (initialize-psystem psys mod)) | |
| 53 | (initialize-psystem psys mod)) | |
| 54 | 54 | (setf (module-proof-system mod) |
| 55 | 55 | (make-psystem :module mod |
| 56 | :clause-hash (make-hash-table :test #'eql) | |
| 57 | :demodulators (make-hash-table :test #'eq))) | |
| 56 | :clause-hash (make-hash-table :test #'eql) | |
| 57 | :demodulators (make-hash-table :test #'eq))) | |
| 58 | 58 | )) |
| 59 | 59 | |
| 60 | 60 | (defun update-module-proof-system (mod &optional do-anyway) |
| 61 | 61 | (declare (type module mod) |
| 62 | (ignore do-anyway)) | |
| 62 | (ignore do-anyway)) | |
| 63 | 63 | (let ((clear-passive nil)) |
| 64 | 64 | (when (need-rewriting-preparation mod) |
| 65 | 65 | (compile-module mod) |
| 70 | 70 | |
| 71 | 71 | (let ((psystem (create-module-psystem mod))) |
| 72 | 72 | (when clear-passive |
| 73 | (setf (psystem-passive psystem) nil)) | |
| 73 | (setf (psystem-passive psystem) nil)) | |
| 74 | 74 | ;; reset clause counter |
| 75 | 75 | (reset-clause-db psystem) |
| 76 | 76 | ;; generate axioms in clause form |
| 89 | 89 | |
| 90 | 90 | ;;; PN-DB-RESET |
| 91 | 91 | ;;; |
| 92 | (defun pn-db-reset (&optional (mod (or *current-module* | |
| 93 | *last-module*))) | |
| 92 | (defun pn-db-reset (&optional (mod (get-context-module))) | |
| 94 | 93 | (clear-all-index-tables) |
| 95 | 94 | (reset-module-proof-system mod)) |
| 96 | 95 | |
| 107 | 106 | (once-only (_module_) |
| 108 | 107 | `(block with-proof-context |
| 109 | 108 | (block with-in-module |
| 110 | (let* ((*current-module* ,_module_) | |
| 111 | (*current-sort-order* (module-sort-order *current-module*)) | |
| 112 | (*current-opinfo-table* (module-opinfo-table *current-module*)) | |
| 113 | (*current-ext-rule-table* (module-ext-rule-table *current-module*))) | |
| 114 | (declare (special *current-module* | |
| 115 | *current-sort-order* | |
| 116 | *current-opinfo-table* | |
| 117 | *current-ext-rule-table*)) | |
| 118 | (let* ((*current-proof-system* *current-module*) | |
| 119 | (*current-psys* (module-proof-system *current-module*)) | |
| 120 | (*clause-hash* (psystem-clause-hash *current-psys*)) | |
| 121 | (*sos* (psystem-sos *current-psys*)) | |
| 122 | (*usable* (psystem-usable *current-psys*)) | |
| 123 | (*demodulators* (psystem-demodulators *current-psys*)) | |
| 124 | (*passive* (psystem-passive *current-psys*)) | |
| 125 | (*clause-given* nil) | |
| 126 | ) | |
| 127 | (declare (special *current-proof-system* | |
| 128 | *current-psys* | |
| 129 | *clause-hash* | |
| 130 | *sos* | |
| 131 | *usable* | |
| 132 | *clause-given* | |
| 133 | *passive*)) | |
| 134 | ;; | |
| 135 | ,@body) | |
| 136 | ))))) | |
| 109 | (let* ((*current-module* ,_module_) | |
| 110 | (*current-sort-order* (module-sort-order *current-module*)) | |
| 111 | (*current-opinfo-table* (module-opinfo-table *current-module*)) | |
| 112 | (*current-ext-rule-table* (module-ext-rule-table *current-module*))) | |
| 113 | (declare (special *current-module* | |
| 114 | *current-sort-order* | |
| 115 | *current-opinfo-table* | |
| 116 | *current-ext-rule-table*)) | |
| 117 | (let* ((*current-proof-system* *current-module*) | |
| 118 | (*current-psys* (module-proof-system *current-module*)) | |
| 119 | (*clause-hash* (psystem-clause-hash *current-psys*)) | |
| 120 | (*sos* (psystem-sos *current-psys*)) | |
| 121 | (*usable* (psystem-usable *current-psys*)) | |
| 122 | (*demodulators* (psystem-demodulators *current-psys*)) | |
| 123 | (*passive* (psystem-passive *current-psys*)) | |
| 124 | (*clause-given* nil) | |
| 125 | ) | |
| 126 | (declare (special *current-proof-system* | |
| 127 | *current-psys* | |
| 128 | *clause-hash* | |
| 129 | *sos* | |
| 130 | *usable* | |
| 131 | *clause-given* | |
| 132 | *passive*)) | |
| 133 | ;; | |
| 134 | ,@body) | |
| 135 | ))))) | |
| 137 | 136 | |
| 138 | 137 | ;;; EOF |
| 139 | 138 | |
| 0 | 0 | ;;;-*-Mode:LISP; Package: CHAOS; Base:10; Syntax:Common-lisp -*- |
| 1 | 1 | ;;; |
| 2 | ;;; Copyright (c) 2000-2014, Toshimi Sawada. All rights reserved. | |
| 2 | ;;; Copyright (c) 2000-2015, Toshimi Sawada. All rights reserved. | |
| 3 | 3 | ;;; |
| 4 | 4 | ;;; Redistribution and use in source and binary forms, with or without |
| 5 | 5 | ;;; modification, are permitted provided that the following conditions |
| 28 | 28 | ;;; |
| 29 | 29 | (in-package :chaos) |
| 30 | 30 | #|============================================================================= |
| 31 | System:Chaos | |
| 32 | Module:BigPink | |
| 33 | File:refine.lisp | |
| 31 | System:Chaos | |
| 32 | Module:BigPink | |
| 33 | File:refine.lisp | |
| 34 | 34 | =============================================================================|# |
| 35 | 35 | #-:chaos-debug |
| 36 | 36 | (declaim (optimize (speed 3) (safety 0) #-GCL (debug 0))) |
| 44 | 44 | (defun pn-get-image-of-axioms (view) |
| 45 | 45 | (declare (type view-struct view)) |
| 46 | 46 | (let* ((source (view-source view)) |
| 47 | (target (view-target view)) | |
| 48 | (morph (convert-view-to-modmorph source | |
| 49 | view))) | |
| 47 | (target (view-target view)) | |
| 48 | (morph (convert-view-to-modmorph source | |
| 49 | view))) | |
| 50 | 50 | (declare (type module source target) |
| 51 | (type modmorph morph)) | |
| 51 | (type modmorph morph)) | |
| 52 | 52 | (let ((sort-map (modmorph-sort morph)) |
| 53 | (op-map (modmorph-op morph)) | |
| 54 | (mod-map (modmorph-module morph)) | |
| 55 | (axs nil)) | |
| 53 | (op-map (modmorph-op morph)) | |
| 54 | (mod-map (modmorph-module morph)) | |
| 55 | (axs nil)) | |
| 56 | 56 | (dolist (ax (get-module-axioms source)) |
| 57 | (let ((ax-image (modmorph-recreate-axiom target | |
| 58 | sort-map | |
| 59 | op-map | |
| 60 | mod-map | |
| 61 | ax))) | |
| 62 | (push ax-image axs))) | |
| 57 | (let ((ax-image (modmorph-recreate-axiom target | |
| 58 | sort-map | |
| 59 | op-map | |
| 60 | mod-map | |
| 61 | ax))) | |
| 62 | (push ax-image axs))) | |
| 63 | 63 | (nreverse axs))) |
| 64 | 64 | ) |
| 65 | 65 | |
| 66 | 66 | (defun pn-axiom-image (ax morph target) |
| 67 | 67 | (declare (type axiom ax) |
| 68 | (type modmorph morph) | |
| 69 | (type module target)) | |
| 68 | (type modmorph morph) | |
| 69 | (type module target)) | |
| 70 | 70 | (let ((sort-map (modmorph-sort morph)) |
| 71 | (op-map (modmorph-op morph)) | |
| 72 | (mod-map (modmorph-module morph))) | |
| 71 | (op-map (modmorph-op morph)) | |
| 72 | (mod-map (modmorph-module morph))) | |
| 73 | 73 | (modmorph-recreate-axiom target |
| 74 | sort-map | |
| 75 | op-map | |
| 76 | mod-map | |
| 77 | ax))) | |
| 74 | sort-map | |
| 75 | op-map | |
| 76 | mod-map | |
| 77 | ax))) | |
| 78 | 78 | |
| 79 | 79 | (defun check-refine (view-expr) |
| 80 | 80 | (let ((view (find-view-in-env (normalize-modexp view-expr))) |
| 81 | (source nil) | |
| 82 | (morph nil) | |
| 83 | (target-mod nil) | |
| 84 | (ng-axs nil) | |
| 85 | (*chaos-quiet* (if (pn-flag debug-refine) | |
| 86 | nil | |
| 87 | t))) | |
| 81 | (source nil) | |
| 82 | (morph nil) | |
| 83 | (target-mod nil) | |
| 84 | (ng-axs nil) | |
| 85 | (*chaos-quiet* (if (pn-flag debug-refine) | |
| 86 | nil | |
| 87 | t))) | |
| 88 | 88 | (declare (type (or null view-struct) view) |
| 89 | (type (or null module) source target-mod) | |
| 90 | (type (or null modmorph) morph) | |
| 91 | (type list ng-axs)) | |
| 89 | (type (or null module) source target-mod) | |
| 90 | (type (or null modmorph) morph) | |
| 91 | (type list ng-axs)) | |
| 92 | 92 | (unless view |
| 93 | 93 | (with-output-chaos-error ('no-such-view) |
| 94 | (format t "no such view \"~a\"" view-expr))) | |
| 94 | (format t "no such view \"~a\"" view-expr))) | |
| 95 | 95 | (setq source (view-source view)) |
| 96 | 96 | (setq morph (convert-view-to-modmorph source view)) |
| 97 | 97 | (setq target-mod (view-target view)) |
| 98 | 98 | ;; |
| 99 | 99 | (when (pn-flag debug-refine) |
| 100 | 100 | (let ((*chaos-quiet* nil)) |
| 101 | (with-output-simple-msg () | |
| 102 | (format t "** starting refinement check with view ~a" view-expr)))) | |
| 101 | (with-output-simple-msg () | |
| 102 | (format t "** starting refinement check with view ~a" view-expr)))) | |
| 103 | 103 | ;; |
| 104 | 104 | (dolist (im-ax (get-module-axioms source)) |
| 105 | 105 | (block next |
| 106 | (let ((lhs (axiom-lhs im-ax))) | |
| 107 | (when (and (term-is-application-form? lhs) | |
| 108 | (equal (method-symbol (term-head lhs)) | |
| 109 | (method-symbol *beh-equal*))) | |
| 110 | (return-from next nil))) | |
| 111 | (when (module-proof-system *pn-refinement-check-module*) | |
| 112 | (initialize-psystem (module-proof-system *pn-refinement-check-module*) | |
| 113 | *pn-refinement-check-module*)) | |
| 114 | (initialize-module *pn-refinement-check-module*) | |
| 115 | (import-module *pn-refinement-check-module* :protecting target-mod) | |
| 116 | (import-module *pn-refinement-check-module* :protecting | |
| 117 | *fopl-sentence-module*) | |
| 118 | (compile-module *pn-refinement-check-module*) | |
| 119 | (with-in-module (*pn-refinement-check-module*) | |
| 120 | (let ((ax (pn-axiom-image im-ax morph *current-module*)) | |
| 121 | (ax-form nil) | |
| 122 | (ax-cls nil) | |
| 123 | (psys nil) | |
| 124 | (flags (save-pn-flags)) | |
| 125 | (parameters (save-pn-parameters)) | |
| 126 | (ret-code nil) | |
| 127 | (*pn-no-db-reset* t)) | |
| 128 | ;; | |
| 129 | (when (pn-flag debug-refine) | |
| 130 | (let ((*chaos-quiet* nil)) | |
| 131 | (with-output-msg () | |
| 132 | (princ "check axiom : ") | |
| 133 | (print-next) | |
| 134 | (print-axiom-brief ax)))) | |
| 135 | ;; db reset by hand | |
| 136 | (clear-all-index-tables) | |
| 137 | (reset-module-proof-system *current-module*) | |
| 138 | (setq psys (module-proof-system *current-module*)) | |
| 139 | ;; negate then convert to clause form | |
| 140 | (setq ax-form (axiom->formula ax)) | |
| 141 | (normalize-quantifiers ax-form) | |
| 142 | (setq ax-form (negate-sentence ax-form)) | |
| 106 | (let ((lhs (axiom-lhs im-ax))) | |
| 107 | (when (and (term-is-application-form? lhs) | |
| 108 | (equal (method-symbol (term-head lhs)) | |
| 109 | (method-symbol *beh-equal*))) | |
| 110 | (return-from next nil))) | |
| 111 | (when (module-proof-system *pn-refinement-check-module*) | |
| 112 | (initialize-psystem (module-proof-system *pn-refinement-check-module*) | |
| 113 | *pn-refinement-check-module*)) | |
| 114 | (initialize-module *pn-refinement-check-module*) | |
| 115 | (import-module *pn-refinement-check-module* :protecting target-mod) | |
| 116 | (import-module *pn-refinement-check-module* :protecting | |
| 117 | *fopl-sentence-module*) | |
| 118 | (compile-module *pn-refinement-check-module*) | |
| 119 | (with-in-module (*pn-refinement-check-module*) | |
| 120 | (let ((ax (pn-axiom-image im-ax morph *current-module*)) | |
| 121 | (ax-form nil) | |
| 122 | (ax-cls nil) | |
| 123 | (psys nil) | |
| 124 | (flags (save-pn-flags)) | |
| 125 | (parameters (save-pn-parameters)) | |
| 126 | (ret-code nil) | |
| 127 | (*pn-no-db-reset* t)) | |
| 128 | ;; | |
| 129 | (when (pn-flag debug-refine) | |
| 130 | (let ((*chaos-quiet* nil)) | |
| 131 | (with-output-msg () | |
| 132 | (princ "check axiom : ") | |
| 133 | (print-next) | |
| 134 | (print-axiom-brief ax)))) | |
| 135 | ;; db reset by hand | |
| 136 | (clear-all-index-tables) | |
| 137 | (reset-module-proof-system *current-module*) | |
| 138 | (setq psys (module-proof-system *current-module*)) | |
| 139 | ;; negate then convert to clause form | |
| 140 | (setq ax-form (axiom->formula ax)) | |
| 141 | (normalize-quantifiers ax-form) | |
| 142 | (setq ax-form (negate-sentence ax-form)) | |
| 143 | 143 | |
| 144 | (setq ax-cls (formula->clause-1 ax-form | |
| 145 | psys)) | |
| 146 | (dolist (a ax-cls) | |
| 147 | (push a (psystem-axioms psys))) | |
| 148 | ;; invoke PigNose | |
| 149 | (unless (pn-flag debug-refine) | |
| 150 | (setf (pn-flag print-message) nil) | |
| 151 | (auto-change-flag quiet t) | |
| 152 | (auto-change-flag print-proofs nil)) | |
| 153 | (auto-change-flag auto t) | |
| 154 | (auto-change-flag universal-symmetry t) | |
| 155 | (setf (pn-parameter max-proofs) 1) | |
| 156 | (setq ret-code (do-resolve *current-module*)) | |
| 157 | ;; | |
| 158 | (restore-pn-flags flags) | |
| 159 | (restore-pn-parameters parameters) | |
| 160 | ;; | |
| 161 | (unless (eq ret-code :max-proofs-exit) | |
| 162 | (push im-ax ng-axs))) | |
| 163 | ||
| 164 | ))) ; done for all axioms | |
| 144 | (setq ax-cls (formula->clause-1 ax-form | |
| 145 | psys)) | |
| 146 | (dolist (a ax-cls) | |
| 147 | (push a (psystem-axioms psys))) | |
| 148 | ;; invoke PigNose | |
| 149 | (unless (pn-flag debug-refine) | |
| 150 | (setf (pn-flag print-message) nil) | |
| 151 | (auto-change-flag quiet t) | |
| 152 | (auto-change-flag print-proofs nil)) | |
| 153 | (auto-change-flag auto t) | |
| 154 | (auto-change-flag universal-symmetry t) | |
| 155 | (setf (pn-parameter max-proofs) 1) | |
| 156 | (setq ret-code (do-resolve *current-module*)) | |
| 157 | ;; | |
| 158 | (restore-pn-flags flags) | |
| 159 | (restore-pn-parameters parameters) | |
| 160 | ;; | |
| 161 | (unless (eq ret-code :max-proofs-exit) | |
| 162 | (push im-ax ng-axs))) | |
| 163 | ||
| 164 | ))) ; done for all axioms | |
| 165 | 165 | ;; |
| 166 | 166 | (if ng-axs |
| 167 | (values ng-axs source target-mod) | |
| 167 | (values ng-axs source target-mod) | |
| 168 | 168 | (values nil source target-mod)) |
| 169 | 169 | )) |
| 170 | 170 | |
| 179 | 179 | ) |
| 180 | 180 | (let ((view-expr (car args))) |
| 181 | 181 | (multiple-value-bind (ng? source-mod target-mod) |
| 182 | (check-refine view-expr) | |
| 182 | (check-refine view-expr) | |
| 183 | 183 | (declare (ignore target-mod)) |
| 184 | 184 | (if ng? |
| 185 | (with-in-module (source-mod) | |
| 186 | (with-output-simple-msg () | |
| 187 | (princ "no") | |
| 188 | (dolist (ax ng?) | |
| 189 | (print-next) | |
| 190 | (print-axiom-brief ax)))) | |
| 191 | (with-output-simple-msg () | |
| 192 | (princ "yes")))) | |
| 185 | (with-in-module (source-mod) | |
| 186 | (with-output-simple-msg () | |
| 187 | (princ "no") | |
| 188 | (dolist (ax ng?) | |
| 189 | (print-next) | |
| 190 | (print-axiom-brief ax)))) | |
| 191 | (with-output-simple-msg () | |
| 192 | (princ "yes")))) | |
| 193 | 193 | )) |
| 194 | 194 | |
| 195 | 195 | ;;; EOF |
| 0 | 0 | ;;;-*-Mode:LISP; Package: CHAOS; Base:10; Syntax:Common-lisp -*- |
| 1 | 1 | ;;; |
| 2 | ;;; Copyright (c) 2000-2014, Toshimi Sawada. All rights reserved. | |
| 2 | ;;; Copyright (c) 2000-2015, Toshimi Sawada. All rights reserved. | |
| 3 | 3 | ;;; |
| 4 | 4 | ;;; Redistribution and use in source and binary forms, with or without |
| 5 | 5 | ;;; modification, are permitted provided that the following conditions |
| 28 | 28 | ;;; |
| 29 | 29 | (in-package :chaos) |
| 30 | 30 | #|============================================================================= |
| 31 | System:Chaos | |
| 32 | Module:BigPink | |
| 33 | File:resolve.lisp | |
| 31 | System:Chaos | |
| 32 | Module:BigPink | |
| 33 | File:resolve.lisp | |
| 34 | 34 | =============================================================================|# |
| 35 | 35 | #-:chaos-debug |
| 36 | 36 | (declaim (optimize (speed 3) (safety 0) #-GCL (debug 0))) |
| 38 | 38 | (declaim (optimize (speed 1) (safety 3) #-GCL (debug 3))) |
| 39 | 39 | |
| 40 | 40 | ;;; *********** |
| 41 | ;;; RESOLVERS | |
| 41 | ;;; RESOLVERS | |
| 42 | 42 | ;;; *********** |
| 43 | 43 | |
| 44 | 44 | |
| 49 | 49 | |
| 50 | 50 | (defun comb-clash-subst (giv-subst clash) |
| 51 | 51 | (declare (type list giv-subst) |
| 52 | (type (or null clash) clash)) | |
| 52 | (type (or null clash) clash)) | |
| 53 | 53 | (if clash |
| 54 | 54 | (let ((subst nil) |
| 55 | (c clash)) | |
| 56 | (loop (unless c (return)) | |
| 57 | (let ((nsub (clash-subst c))) | |
| 58 | (if nsub | |
| 59 | (setq subst nsub))) | |
| 60 | (setq c (clash-next c))) | |
| 61 | (compose-subst giv-subst subst)) | |
| 55 | (c clash)) | |
| 56 | (loop (unless c (return)) | |
| 57 | (let ((nsub (clash-subst c))) | |
| 58 | (if nsub | |
| 59 | (setq subst nsub))) | |
| 60 | (setq c (clash-next c))) | |
| 61 | (compose-subst giv-subst subst)) | |
| 62 | 62 | giv-subst)) |
| 63 | 63 | |
| 64 | 64 | (defun build-hyper (clash given-subst nuc-lits nucleus giv-lits giv-sat inf-id nuc-pos) |
| 65 | 65 | (declare (ignore nuc-pos) |
| 66 | (type (or null clash) clash) | |
| 67 | (type list given-subst) | |
| 68 | (type list nuc-lits) | |
| 69 | (type clause nucleus) | |
| 70 | (type list giv-lits) | |
| 71 | (type (or null clause) giv-sat) | |
| 72 | (type symbol inf-id)) | |
| 66 | (type (or null clash) clash) | |
| 67 | (type list given-subst) | |
| 68 | (type list nuc-lits) | |
| 69 | (type clause nucleus) | |
| 70 | (type list giv-lits) | |
| 71 | (type (or null clause) giv-sat) | |
| 72 | (type symbol inf-id)) | |
| 73 | 73 | (let ((new-literals nil) |
| 74 | (new-clause (new-clause *current-psys*)) | |
| 75 | (history nil) | |
| 76 | (subst nil) | |
| 77 | (clashes clash)) | |
| 74 | (new-clause (new-clause *current-psys*)) | |
| 75 | (history nil) | |
| 76 | (subst nil) | |
| 77 | (clashes clash)) | |
| 78 | 78 | (declare (type list new-literals) |
| 79 | (type clause new-clause) | |
| 80 | (type list history subst) | |
| 81 | (type (or null clash) clashes)) | |
| 79 | (type clause new-clause) | |
| 80 | (type list history subst) | |
| 81 | (type (or null clash) clashes)) | |
| 82 | 82 | ;; |
| 83 | 83 | (setq subst |
| 84 | 84 | (comb-clash-subst given-subst clash)) |
| 103 | 103 | (dolist (lit giv-lits) |
| 104 | 104 | (declare (type literal lit)) |
| 105 | 105 | (let ((new-literal (shallow-copy-literal lit new-clause))) |
| 106 | (declare (type literal new-literal)) | |
| 107 | (setf (literal-atom new-literal) | |
| 108 | (apply-subst subst (literal-atom lit))) | |
| 109 | (push new-literal new-literals))) | |
| 106 | (declare (type literal new-literal)) | |
| 107 | (setf (literal-atom new-literal) | |
| 108 | (apply-subst subst (literal-atom lit))) | |
| 109 | (push new-literal new-literals))) | |
| 110 | 110 | |
| 111 | 111 | (dolist (lit nuc-lits) |
| 112 | 112 | (declare (type literal lit)) |
| 113 | 113 | (let ((new-literal (shallow-copy-literal lit new-clause))) |
| 114 | (declare (type literal new-literal)) | |
| 115 | (setf (literal-atom new-literal) | |
| 116 | (apply-subst subst (literal-atom lit))) | |
| 117 | (push new-literal new-literals))) | |
| 114 | (declare (type literal new-literal)) | |
| 115 | (setf (literal-atom new-literal) | |
| 116 | (apply-subst subst (literal-atom lit))) | |
| 117 | (push new-literal new-literals))) | |
| 118 | 118 | |
| 119 | 119 | (while clashes |
| 120 | 120 | (if (clash-evaluable clashes) |
| 121 | (push :eval history) | |
| 122 | (let* ((found-lit (clash-found-lit clashes)) | |
| 123 | (sat-clause (literal-clause found-lit)) | |
| 124 | ) | |
| 125 | (declare (type literal found-lit) | |
| 126 | (type clause sat-clause)) | |
| 127 | (push (clause-id sat-clause) history) | |
| 128 | (dolist (lit (clause-literals sat-clause)) | |
| 129 | (declare (type literal lit)) | |
| 130 | (unless (eq lit found-lit) | |
| 131 | (let ((new-literal (shallow-copy-literal lit new-clause))) | |
| 132 | (declare (type literal new-literal)) | |
| 133 | (setf (literal-atom new-literal) | |
| 134 | ;; clash-subst? | |
| 135 | (apply-subst subst (literal-atom lit)) | |
| 136 | ;; (apply-subst (clash-subst clashes) (literal-atom lit)) | |
| 137 | ) | |
| 138 | (push new-literal new-literals)))) | |
| 139 | (let ((junk-id (cdr (assq :dummy-clause | |
| 140 | (clause-attributes sat-clause))))) | |
| 141 | (when junk-id | |
| 142 | (delete-clause! junk-id *current-psys*)) | |
| 143 | ))) | |
| 121 | (push :eval history) | |
| 122 | (let* ((found-lit (clash-found-lit clashes)) | |
| 123 | (sat-clause (literal-clause found-lit)) | |
| 124 | ) | |
| 125 | (declare (type literal found-lit) | |
| 126 | (type clause sat-clause)) | |
| 127 | (push (clause-id sat-clause) history) | |
| 128 | (dolist (lit (clause-literals sat-clause)) | |
| 129 | (declare (type literal lit)) | |
| 130 | (unless (eq lit found-lit) | |
| 131 | (let ((new-literal (shallow-copy-literal lit new-clause))) | |
| 132 | (declare (type literal new-literal)) | |
| 133 | (setf (literal-atom new-literal) | |
| 134 | ;; clash-subst? | |
| 135 | (apply-subst subst (literal-atom lit)) | |
| 136 | ;; (apply-subst (clash-subst clashes) (literal-atom lit)) | |
| 137 | ) | |
| 138 | (push new-literal new-literals)))) | |
| 139 | (let ((junk-id (cdr (assq :dummy-clause | |
| 140 | (clause-attributes sat-clause))))) | |
| 141 | (when junk-id | |
| 142 | (delete-clause! junk-id *current-psys*)) | |
| 143 | ))) | |
| 144 | 144 | (setq clashes (clash-next clashes))) |
| 145 | 145 | ;; |
| 146 | 146 | (setf (clause-literals new-clause) |
| 172 | 172 | ;;; nuc-pos : if not nil, given clause is a satelite |
| 173 | 173 | |
| 174 | 174 | (declaim (special _clash_so_far_) |
| 175 | (type list _clash_so_far_)) | |
| 175 | (type list _clash_so_far_)) | |
| 176 | 176 | (defvar _clash_so_far_ nil) |
| 177 | 177 | |
| 178 | 178 | (declaim (inline rename-subst)) |
| 179 | 179 | |
| 180 | 180 | (defun rename-subst (subst var-map) |
| 181 | 181 | (declare (type list subst var-map) |
| 182 | (values list)) | |
| 182 | (values list)) | |
| 183 | 183 | (if subst |
| 184 | 184 | (let ((res nil)) |
| 185 | (declare (list res)) | |
| 186 | (dolist (s subst) | |
| 187 | (let ((bind (variable-image var-map (car s)))) | |
| 188 | (declare (type (or null term) bind)) | |
| 189 | (if bind | |
| 190 | (progn | |
| 191 | (push (cons (car s) bind) res) | |
| 192 | (when (term-is-variable? bind) | |
| 193 | (push (cons bind | |
| 194 | (apply-subst var-map (cdr s))) | |
| 195 | res)) | |
| 196 | ) | |
| 197 | (push (cons (car s) | |
| 198 | (apply-subst var-map (cdr s))) | |
| 199 | res)))) | |
| 200 | (setq res (nreverse res)) | |
| 201 | (dolist (vm var-map) | |
| 202 | (unless (variable-image res (car vm)) | |
| 203 | (push vm res))) | |
| 204 | res) | |
| 185 | (declare (list res)) | |
| 186 | (dolist (s subst) | |
| 187 | (let ((bind (variable-image var-map (car s)))) | |
| 188 | (declare (type (or null term) bind)) | |
| 189 | (if bind | |
| 190 | (progn | |
| 191 | (push (cons (car s) bind) res) | |
| 192 | (when (term-is-variable? bind) | |
| 193 | (push (cons bind | |
| 194 | (apply-subst var-map (cdr s))) | |
| 195 | res)) | |
| 196 | ) | |
| 197 | (push (cons (car s) | |
| 198 | (apply-subst var-map (cdr s))) | |
| 199 | res)))) | |
| 200 | (setq res (nreverse res)) | |
| 201 | (dolist (vm var-map) | |
| 202 | (unless (variable-image res (car vm)) | |
| 203 | (push vm res))) | |
| 204 | res) | |
| 205 | 205 | (if var-map |
| 206 | var-map | |
| 206 | var-map | |
| 207 | 207 | nil))) |
| 208 | 208 | |
| 209 | 209 | (defun maximal-literal (l1) |
| 210 | 210 | (declare (type literal l1) |
| 211 | (values symbol)) | |
| 211 | (values symbol)) | |
| 212 | 212 | (flet ((opcompare (m1 m2) |
| 213 | (declare (type method m1 m2)) | |
| 214 | (if (method-w= m1 m2) | |
| 215 | nil | |
| 216 | (let ((p1 (method-lex-prec m1)) | |
| 217 | (p2 (method-lex-prec m2))) | |
| 218 | (declare (type fixnum p1 p2)) | |
| 219 | (if (< p1 p2) | |
| 220 | :less | |
| 221 | nil))))) | |
| 213 | (declare (type method m1 m2)) | |
| 214 | (if (method-w= m1 m2) | |
| 215 | nil | |
| 216 | (let ((p1 (method-lex-prec m1)) | |
| 217 | (p2 (method-lex-prec m2))) | |
| 218 | (declare (type fixnum p1 p2)) | |
| 219 | (if (< p1 p2) | |
| 220 | :less | |
| 221 | nil))))) | |
| 222 | 222 | ;; |
| 223 | 223 | (let ((atom (literal-atom l1))) |
| 224 | 224 | (declare (type term atom)) |
| 225 | 225 | (dolist (l2 (clause-literals (literal-clause l1)) t) |
| 226 | (declare (type literal l2)) | |
| 227 | (if (and (not (eq l1 l2)) | |
| 228 | (not (answer-literal? l2))) | |
| 229 | (if (and (positive-literal? l2) | |
| 230 | (not (positive-literal? l1))) | |
| 231 | (return nil) | |
| 232 | (if (and (eq (literal-sign l1) | |
| 233 | (literal-sign l2)) | |
| 234 | (eq :less | |
| 235 | #|| | |
| 236 | (op-lex-compare (term-head atom) | |
| 237 | (term-head (literal-atom l2))) | |
| 238 | ||# | |
| 239 | (opcompare (term-head atom) | |
| 240 | (term-head (literal-atom l2))) | |
| 241 | )) | |
| 242 | (return nil)))))) | |
| 226 | (declare (type literal l2)) | |
| 227 | (if (and (not (eq l1 l2)) | |
| 228 | (not (answer-literal? l2))) | |
| 229 | (if (and (positive-literal? l2) | |
| 230 | (not (positive-literal? l1))) | |
| 231 | (return nil) | |
| 232 | (if (and (eq (literal-sign l1) | |
| 233 | (literal-sign l2)) | |
| 234 | (eq :less | |
| 235 | #|| | |
| 236 | (op-lex-compare (term-head atom) | |
| 237 | (term-head (literal-atom l2))) | |
| 238 | ||# | |
| 239 | (opcompare (term-head atom) | |
| 240 | (term-head (literal-atom l2))) | |
| 241 | )) | |
| 242 | (return nil)))))) | |
| 243 | 243 | )) |
| 244 | 244 | |
| 245 | 245 | (declaim (inline compose-subst2)) |
| 247 | 247 | (defun compose-subst2 (s1 s2) |
| 248 | 248 | (declare (type list s1 s2)) |
| 249 | 249 | (labels ((add-new (s newsl) |
| 250 | (declare (type (or null term) s) | |
| 251 | (type list newsl)) | |
| 252 | (cond ((null s) newsl) | |
| 253 | ((variable-image newsl (caar s)) | |
| 254 | (add-new (cdr s) newsl)) | |
| 255 | (t (cons (car s) (add-new (cdr s) newsl))))) | |
| 256 | (composel (s1 s2) | |
| 257 | (cond ((null s1) nil) | |
| 258 | ;; !!! | |
| 259 | ((variable-image s2 (caar s1)) | |
| 260 | (composel (cdr s1) s2)) | |
| 261 | (t (cons (cons (caar s1) | |
| 262 | (apply-subst s2 (cdar s1))) | |
| 263 | (composel (cdr s1) s2)))))) | |
| 250 | (declare (type (or null term) s) | |
| 251 | (type list newsl)) | |
| 252 | (cond ((null s) newsl) | |
| 253 | ((variable-image newsl (caar s)) | |
| 254 | (add-new (cdr s) newsl)) | |
| 255 | (t (cons (car s) (add-new (cdr s) newsl))))) | |
| 256 | (composel (s1 s2) | |
| 257 | (cond ((null s1) nil) | |
| 258 | ;; !!! | |
| 259 | ((variable-image s2 (caar s1)) | |
| 260 | (composel (cdr s1) s2)) | |
| 261 | (t (cons (cons (caar s1) | |
| 262 | (apply-subst s2 (cdar s1))) | |
| 263 | (composel (cdr s1) s2)))))) | |
| 264 | 264 | ;; |
| 265 | 265 | (if (car s2) |
| 266 | (add-new s2 (composel s1 s2)) | |
| 266 | (add-new s2 (composel s1 s2)) | |
| 267 | 267 | s1))) |
| 268 | 268 | |
| 269 | 269 | (declaim (inline cl-occurs-in-clash)) |
| 270 | ||
| 270 | ||
| 271 | 271 | (defun cl-occurs-in-clash (clash-clause clash) |
| 272 | 272 | (declare (type clause clash-clause) |
| 273 | (type clash)) | |
| 273 | (type clash)) | |
| 274 | 274 | (let ((clh clash)) |
| 275 | 275 | (declare (type (or null clash) clh)) |
| 276 | 276 | (loop |
| 277 | 277 | (setq clh (clash-prev clh)) |
| 278 | 278 | (unless clh (return-from cl-occurs-in-clash nil)) |
| 279 | 279 | (when (and (clash-found-lit clh) |
| 280 | (eq (literal-clause (clash-found-lit clh)) | |
| 281 | clash-clause)) | |
| 282 | (return-from cl-occurs-in-clash t)))) | |
| 280 | (eq (literal-clause (clash-found-lit clh)) | |
| 281 | clash-clause)) | |
| 282 | (return-from cl-occurs-in-clash t)))) | |
| 283 | 283 | nil) |
| 284 | 284 | |
| 285 | 285 | (defun clash-one (clash clause-pred given-subst inf-id &optional giv-sat) |
| 286 | 286 | (declare (type clash clash) |
| 287 | (type list given-subst) | |
| 288 | (type symbol inf-id) | |
| 289 | (type (or null clause) giv-sat)) | |
| 287 | (type list given-subst) | |
| 288 | (type symbol inf-id) | |
| 289 | (type (or null clause) giv-sat)) | |
| 290 | 290 | #|| |
| 291 | 291 | (when (pn-flag debug-hyper-res) |
| 292 | 292 | (with-output-msg () |
| 302 | 302 | (format t "giv-sat = ~s" giv-sat))) |
| 303 | 303 | ||# |
| 304 | 304 | (let ((clashables (if (clash-clashables clash) |
| 305 | (cdr (clash-clashables clash)) | |
| 306 | (setf (clash-clashables clash) | |
| 307 | #|| | |
| 308 | (get-literal-entry-from-atom | |
| 309 | (clash-db clash) | |
| 310 | (literal-atom (clash-literal clash))) | |
| 311 | ||# | |
| 312 | (is-fetch-concat (literal-atom (clash-literal clash)) | |
| 313 | (clash-db clash)) | |
| 314 | ))) | |
| 315 | (atom (literal-atom (clash-literal clash))) | |
| 316 | (subst (if (clash-prev clash) | |
| 317 | (or (get-nsubst (clash-prev clash)) | |
| 318 | given-subst) | |
| 319 | ;; (or (clash-subst (clash-prev clash)) | |
| 320 | ;; given-subst) | |
| 321 | given-subst))) | |
| 305 | (cdr (clash-clashables clash)) | |
| 306 | (setf (clash-clashables clash) | |
| 307 | #|| | |
| 308 | (get-literal-entry-from-atom | |
| 309 | (clash-db clash) | |
| 310 | (literal-atom (clash-literal clash))) | |
| 311 | ||# | |
| 312 | (is-fetch-concat (literal-atom (clash-literal clash)) | |
| 313 | (clash-db clash)) | |
| 314 | ))) | |
| 315 | (atom (literal-atom (clash-literal clash))) | |
| 316 | (subst (if (clash-prev clash) | |
| 317 | (or (get-nsubst (clash-prev clash)) | |
| 318 | given-subst) | |
| 319 | ;; (or (clash-subst (clash-prev clash)) | |
| 320 | ;; given-subst) | |
| 321 | given-subst))) | |
| 322 | 322 | (declare (type list clashables) |
| 323 | (type term atom) | |
| 324 | (type list subst)) | |
| 323 | (type term atom) | |
| 324 | (type list subst)) | |
| 325 | 325 | ;; |
| 326 | 326 | (loop |
| 327 | 327 | (unless clashables |
| 328 | (return nil)) | |
| 328 | (return nil)) | |
| 329 | 329 | (block next |
| 330 | ;; | |
| 331 | (let* ((lit-data (car clashables)) | |
| 332 | ;; (clash-lit (literal-entry-literal lit-data)) | |
| 333 | (clash-lit lit-data) | |
| 334 | (clash-clause (literal-clause clash-lit)) | |
| 335 | (junk-cl-id nil)) | |
| 336 | (declare (type literal clash-lit) | |
| 337 | (type clause clash-clause) | |
| 338 | (type (or null fixnum) junk-cl-id)) | |
| 339 | (when (and (funcall clause-pred clash-clause) | |
| 340 | (or (not (pn-flag order-hyper)) | |
| 341 | (eq :ur-res-rule inf-id) | |
| 342 | (maximal-literal clash-lit))) | |
| 343 | (let (;; (clash-atom (literal-entry-atom clash-lit)) | |
| 344 | (clash-atom (literal-atom clash-lit)) | |
| 345 | (varmap nil) | |
| 346 | (natom atom) | |
| 347 | ;; (renamed nil) | |
| 348 | ) | |
| 349 | (declare (ignore varmap) | |
| 350 | (type term clash-atom natom)) | |
| 351 | ;; | |
| 352 | (setq atom (apply-subst subst atom)) | |
| 353 | (when (or (eq giv-sat clash-clause) | |
| 354 | (cl-occurs-in-clash clash-clause clash)) | |
| 355 | (unless (term-eq natom atom) | |
| 356 | (multiple-value-bind (dcl tlit id) | |
| 357 | (make-dummy-clause clash-clause | |
| 358 | clash-lit) | |
| 359 | (declare (type clause dcl) | |
| 360 | (type literal tlit) | |
| 361 | (type fixnum id)) | |
| 362 | (setq junk-cl-id id) | |
| 363 | (setq clash-lit tlit) | |
| 364 | (setq clash-atom (literal-atom tlit)) | |
| 365 | (setq clash-clause dcl)) | |
| 366 | )) | |
| 367 | ;; | |
| 368 | (when (pn-flag debug-hyper-res) | |
| 369 | (with-output-msg () | |
| 370 | (princ "chash-one trying unify:") | |
| 371 | (print-next) | |
| 372 | (format t "clash = ~s" (literal-clause (clash-literal clash))) | |
| 373 | (print-next) | |
| 374 | (princ "atom = ") (term-print atom) | |
| 375 | (print-next) | |
| 376 | (format t "target clause = ~s " clash-clause) | |
| 377 | (print-next) | |
| 378 | (princ "target atom = ") (term-print clash-atom) | |
| 379 | )) | |
| 380 | ;; | |
| 381 | (multiple-value-bind (new-subst no-match e-equal) | |
| 382 | (unify clash-atom | |
| 383 | atom | |
| 384 | ;; subst | |
| 385 | nil) | |
| 386 | (declare (ignore e-equal) | |
| 387 | (type list new-subst)) | |
| 388 | ;; | |
| 389 | (when no-match | |
| 390 | (when junk-cl-id | |
| 391 | (delete-clause! junk-cl-id *current-psys*)) | |
| 392 | (return-from next nil)) | |
| 393 | ;; | |
| 394 | (if new-subst | |
| 395 | (progn | |
| 396 | (setq new-subst (compose-subst subst new-subst)) | |
| 397 | ;; (setq new-subst (compose-subst2 subst new-subst)) | |
| 398 | ) | |
| 399 | (setq new-subst subst)) | |
| 400 | (when (pn-flag debug-hyper-res) | |
| 401 | (with-output-simple-msg () | |
| 402 | (princ "* clash-one success: ") | |
| 403 | (princ "nuc = ") (print-clause | |
| 404 | (literal-clause | |
| 405 | (clash-literal clash))) | |
| 406 | (print-next) | |
| 407 | (princ "nuc atom = ") (term-print atom) | |
| 408 | (print-next) | |
| 409 | (princ "target(electron) = ") (term-print clash-atom) | |
| 410 | (print-next) | |
| 411 | (format t "target cl-id = ~D" | |
| 412 | (clause-id clash-clause)) | |
| 413 | (print-next) | |
| 414 | (princ "subst = ") | |
| 415 | (print-substitution new-subst) | |
| 416 | )) | |
| 417 | ||
| 418 | ;; success! | |
| 419 | (setf (clash-subst clash) new-subst) | |
| 420 | (setf (clash-clashables clash) clashables) | |
| 421 | (setf (clash-found-lit clash) clash-lit) | |
| 422 | (return-from clash-one t)) | |
| 423 | ))) | |
| 424 | ) ; block next | |
| 330 | ;; | |
| 331 | (let* ((lit-data (car clashables)) | |
| 332 | ;; (clash-lit (literal-entry-literal lit-data)) | |
| 333 | (clash-lit lit-data) | |
| 334 | (clash-clause (literal-clause clash-lit)) | |
| 335 | (junk-cl-id nil)) | |
| 336 | (declare (type literal clash-lit) | |
| 337 | (type clause clash-clause) | |
| 338 | (type (or null fixnum) junk-cl-id)) | |
| 339 | (when (and (funcall clause-pred clash-clause) | |
| 340 | (or (not (pn-flag order-hyper)) | |
| 341 | (eq :ur-res-rule inf-id) | |
| 342 | (maximal-literal clash-lit))) | |
| 343 | (let (;; (clash-atom (literal-entry-atom clash-lit)) | |
| 344 | (clash-atom (literal-atom clash-lit)) | |
| 345 | (varmap nil) | |
| 346 | (natom atom) | |
| 347 | ;; (renamed nil) | |
| 348 | ) | |
| 349 | (declare (ignore varmap) | |
| 350 | (type term clash-atom natom)) | |
| 351 | ;; | |
| 352 | (setq atom (apply-subst subst atom)) | |
| 353 | (when (or (eq giv-sat clash-clause) | |
| 354 | (cl-occurs-in-clash clash-clause clash)) | |
| 355 | (unless (term-eq natom atom) | |
| 356 | (multiple-value-bind (dcl tlit id) | |
| 357 | (make-dummy-clause clash-clause | |
| 358 | clash-lit) | |
| 359 | (declare (type clause dcl) | |
| 360 | (type literal tlit) | |
| 361 | (type fixnum id)) | |
| 362 | (setq junk-cl-id id) | |
| 363 | (setq clash-lit tlit) | |
| 364 | (setq clash-atom (literal-atom tlit)) | |
| 365 | (setq clash-clause dcl)) | |
| 366 | )) | |
| 367 | ;; | |
| 368 | (when (pn-flag debug-hyper-res) | |
| 369 | (with-output-msg () | |
| 370 | (princ "chash-one trying unify:") | |
| 371 | (print-next) | |
| 372 | (format t "clash = ~s" (literal-clause (clash-literal clash))) | |
| 373 | (print-next) | |
| 374 | (princ "atom = ") (term-print atom) | |
| 375 | (print-next) | |
| 376 | (format t "target clause = ~s " clash-clause) | |
| 377 | (print-next) | |
| 378 | (princ "target atom = ") (term-print clash-atom) | |
| 379 | )) | |
| 380 | ;; | |
| 381 | (multiple-value-bind (new-subst no-match e-equal) | |
| 382 | (unify clash-atom | |
| 383 | atom | |
| 384 | ;; subst | |
| 385 | nil) | |
| 386 | (declare (ignore e-equal) | |
| 387 | (type list new-subst)) | |
| 388 | ;; | |
| 389 | (when no-match | |
| 390 | (when junk-cl-id | |
| 391 | (delete-clause! junk-cl-id *current-psys*)) | |
| 392 | (return-from next nil)) | |
| 393 | ;; | |
| 394 | (if new-subst | |
| 395 | (progn | |
| 396 | (setq new-subst (compose-subst subst new-subst)) | |
| 397 | ;; (setq new-subst (compose-subst2 subst new-subst)) | |
| 398 | ) | |
| 399 | (setq new-subst subst)) | |
| 400 | (when (pn-flag debug-hyper-res) | |
| 401 | (with-output-simple-msg () | |
| 402 | (princ "* clash-one success: ") | |
| 403 | (princ "nuc = ") (print-clause | |
| 404 | (literal-clause | |
| 405 | (clash-literal clash))) | |
| 406 | (print-next) | |
| 407 | (princ "nuc atom = ") (term-print atom) | |
| 408 | (print-next) | |
| 409 | (princ "target(electron) = ") (term-print clash-atom) | |
| 410 | (print-next) | |
| 411 | (format t "target cl-id = ~D" | |
| 412 | (clause-id clash-clause)) | |
| 413 | (print-next) | |
| 414 | (princ "subst = ") | |
| 415 | (print-substitution new-subst) | |
| 416 | )) | |
| 417 | ||
| 418 | ;; success! | |
| 419 | (setf (clash-subst clash) new-subst) | |
| 420 | (setf (clash-clashables clash) clashables) | |
| 421 | (setf (clash-found-lit clash) clash-lit) | |
| 422 | (return-from clash-one t)) | |
| 423 | ))) | |
| 424 | ) ; block next | |
| 425 | 425 | ;; try next clashable |
| 426 | 426 | (setq clashables (cdr clashables)) |
| 427 | ) ; end loop | |
| 427 | ) ; end loop | |
| 428 | 428 | nil)) |
| 429 | 429 | |
| 430 | 430 | (defun get-nsubst (clashes) |
| 431 | 431 | (if (null clashes) |
| 432 | 432 | nil |
| 433 | 433 | (or (clash-subst clashes) |
| 434 | (get-nsubst (clash-prev clashes))))) | |
| 434 | (get-nsubst (clash-prev clashes))))) | |
| 435 | 435 | |
| 436 | 436 | (defun hyper-clash! (c-start |
| 437 | given-subst | |
| 438 | nuc-lits | |
| 439 | nuc | |
| 440 | giv-lits | |
| 441 | giv-sat | |
| 442 | sat-proc | |
| 443 | inf-id | |
| 444 | nuc-pos) | |
| 437 | given-subst | |
| 438 | nuc-lits | |
| 439 | nuc | |
| 440 | giv-lits | |
| 441 | giv-sat | |
| 442 | sat-proc | |
| 443 | inf-id | |
| 444 | nuc-pos) | |
| 445 | 445 | (declare (type (or null clash) c-start) |
| 446 | (type list given-subst) | |
| 447 | (type list nuc-lits) | |
| 448 | (type (or null clause) nuc) | |
| 449 | (type list giv-lits) | |
| 450 | (type (or null clause) giv-sat) | |
| 451 | (type symbol inf-id) | |
| 452 | (type (or null fixnum) nuc-pos)) | |
| 446 | (type list given-subst) | |
| 447 | (type list nuc-lits) | |
| 448 | (type (or null clause) nuc) | |
| 449 | (type list giv-lits) | |
| 450 | (type (or null clause) giv-sat) | |
| 451 | (type symbol inf-id) | |
| 452 | (type (or null fixnum) nuc-pos)) | |
| 453 | 453 | (let ((clashes nil) |
| 454 | (list-resolvent nil) | |
| 455 | (backup nil) | |
| 456 | (c-end nil)) | |
| 454 | (list-resolvent nil) | |
| 455 | (backup nil) | |
| 456 | (c-end nil)) | |
| 457 | 457 | (declare (type (or null clash) clashes) |
| 458 | (type list list-resolvent) | |
| 459 | (type (or null clash) c-end)) | |
| 458 | (type list list-resolvent) | |
| 459 | (type (or null clash) c-end)) | |
| 460 | 460 | ;; |
| 461 | 461 | (loop |
| 462 | 462 | (if (not backup) |
| 463 | (if (or (null c-start) | |
| 464 | (and clashes | |
| 465 | (null (clash-next clashes)))) | |
| 466 | ;; clash is complete | |
| 467 | (let ((resolvent nil)) | |
| 468 | (setq resolvent (build-hyper c-start ; clash list | |
| 469 | given-subst | |
| 470 | nuc-lits ; non-clash lits of nucleus | |
| 471 | nuc ; nucleus clause | |
| 472 | giv-lits | |
| 473 | giv-sat | |
| 474 | inf-id | |
| 475 | nuc-pos | |
| 476 | )) | |
| 477 | (case inf-id | |
| 478 | (:hyper-res-rule | |
| 479 | (incf (pn-stat hyper-res-gen))) | |
| 480 | (:neg-hyper-res-rule | |
| 481 | (incf (pn-stat neg-hyper-res-gen))) | |
| 482 | (otherwise | |
| 483 | (incf (pn-stat ur-res-gen)))) | |
| 484 | (incf (pn-stat cl-generated)) | |
| 485 | ;; pre-process the hyper-resolvent | |
| 486 | (when (pre-process resolvent nil :sos) | |
| 487 | (push resolvent list-resolvent)) | |
| 488 | ;; | |
| 489 | (setq backup t) | |
| 490 | (setq c-end clashes) ; the last success clash | |
| 491 | (setq clashes nil) | |
| 492 | ) | |
| 493 | ;; else | |
| 494 | (progn | |
| 495 | (if (null clashes) ; just starting | |
| 496 | (setq clashes c-start) | |
| 497 | ;; try next clash | |
| 498 | (setq clashes (clash-next clashes))) | |
| 499 | (when (clash-evaluable clashes) | |
| 500 | ;; (setf (clash-subst clashes) nil) | |
| 501 | (let* ((lit (clash-literal clashes)) | |
| 502 | (atom (literal-atom lit)) | |
| 503 | (subst (get-nsubst clashes)) | |
| 504 | (inst nil)) | |
| 505 | ;; (setf (clash-subst clashes) subst) | |
| 506 | (unless subst (setq subst given-subst)) | |
| 507 | (setq inst (demod-atom (apply-subst subst atom))) | |
| 508 | (if (positive-literal? lit) | |
| 509 | (setf (clash-evaluation clashes) | |
| 510 | (is-false? inst)) | |
| 511 | (setf (clash-evaluation clashes) | |
| 512 | (is-true? inst))) | |
| 513 | (setf (clash-already-evaluated clashes) nil))) | |
| 514 | ;; initialize clashsable list | |
| 515 | (setf (clash-clashables clashes) nil))) | |
| 516 | ;; | |
| 517 | ;; else backup | |
| 518 | ;; | |
| 519 | (if (or (null c-start) | |
| 520 | (and clashes | |
| 521 | (null (clash-prev clashes)))) | |
| 522 | ;; done with this nucleus | |
| 523 | (return-from hyper-clash! list-resolvent) | |
| 524 | ;; else | |
| 525 | (progn | |
| 526 | (if (null clashes) | |
| 527 | (progn | |
| 528 | (setq clashes c-end) ; restart from the | |
| 529 | ; last successed clash | |
| 530 | ) | |
| 531 | ;; else | |
| 532 | ;; back track to previous one. | |
| 533 | (progn | |
| 534 | (setf (clash-clashables clashes) nil) | |
| 535 | (setq clashes (clash-prev clashes)))) | |
| 536 | ;; try again | |
| 537 | (unless (clash-evaluable clashes) | |
| 538 | (setf (clash-subst clashes) nil)) | |
| 539 | (setq backup nil)))) | |
| 463 | (if (or (null c-start) | |
| 464 | (and clashes | |
| 465 | (null (clash-next clashes)))) | |
| 466 | ;; clash is complete | |
| 467 | (let ((resolvent nil)) | |
| 468 | (setq resolvent (build-hyper c-start ; clash list | |
| 469 | given-subst | |
| 470 | nuc-lits ; non-clash lits of nucleus | |
| 471 | nuc ; nucleus clause | |
| 472 | giv-lits | |
| 473 | giv-sat | |
| 474 | inf-id | |
| 475 | nuc-pos | |
| 476 | )) | |
| 477 | (case inf-id | |
| 478 | (:hyper-res-rule | |
| 479 | (incf (pn-stat hyper-res-gen))) | |
| 480 | (:neg-hyper-res-rule | |
| 481 | (incf (pn-stat neg-hyper-res-gen))) | |
| 482 | (otherwise | |
| 483 | (incf (pn-stat ur-res-gen)))) | |
| 484 | (incf (pn-stat cl-generated)) | |
| 485 | ;; pre-process the hyper-resolvent | |
| 486 | (when (pre-process resolvent nil :sos) | |
| 487 | (push resolvent list-resolvent)) | |
| 488 | ;; | |
| 489 | (setq backup t) | |
| 490 | (setq c-end clashes) ; the last success clash | |
| 491 | (setq clashes nil) | |
| 492 | ) | |
| 493 | ;; else | |
| 494 | (progn | |
| 495 | (if (null clashes) ; just starting | |
| 496 | (setq clashes c-start) | |
| 497 | ;; try next clash | |
| 498 | (setq clashes (clash-next clashes))) | |
| 499 | (when (clash-evaluable clashes) | |
| 500 | ;; (setf (clash-subst clashes) nil) | |
| 501 | (let* ((lit (clash-literal clashes)) | |
| 502 | (atom (literal-atom lit)) | |
| 503 | (subst (get-nsubst clashes)) | |
| 504 | (inst nil)) | |
| 505 | ;; (setf (clash-subst clashes) subst) | |
| 506 | (unless subst (setq subst given-subst)) | |
| 507 | (setq inst (demod-atom (apply-subst subst atom))) | |
| 508 | (if (positive-literal? lit) | |
| 509 | (setf (clash-evaluation clashes) | |
| 510 | (is-false? inst)) | |
| 511 | (setf (clash-evaluation clashes) | |
| 512 | (is-true? inst))) | |
| 513 | (setf (clash-already-evaluated clashes) nil))) | |
| 514 | ;; initialize clashsable list | |
| 515 | (setf (clash-clashables clashes) nil))) | |
| 516 | ;; | |
| 517 | ;; else backup | |
| 518 | ;; | |
| 519 | (if (or (null c-start) | |
| 520 | (and clashes | |
| 521 | (null (clash-prev clashes)))) | |
| 522 | ;; done with this nucleus | |
| 523 | (return-from hyper-clash! list-resolvent) | |
| 524 | ;; else | |
| 525 | (progn | |
| 526 | (if (null clashes) | |
| 527 | (progn | |
| 528 | (setq clashes c-end) ; restart from the | |
| 529 | ; last successed clash | |
| 530 | ) | |
| 531 | ;; else | |
| 532 | ;; back track to previous one. | |
| 533 | (progn | |
| 534 | (setf (clash-clashables clashes) nil) | |
| 535 | (setq clashes (clash-prev clashes)))) | |
| 536 | ;; try again | |
| 537 | (unless (clash-evaluable clashes) | |
| 538 | (setf (clash-subst clashes) nil)) | |
| 539 | (setq backup nil)))) | |
| 540 | 540 | ;; |
| 541 | 541 | (unless backup |
| 542 | (if (clash-evaluable clashes) | |
| 543 | (if (or (clash-already-evaluated clashes) | |
| 544 | (not (clash-evaluation clashes))) | |
| 545 | (setq backup t) | |
| 546 | ;; set flag and proceed | |
| 547 | (setf (clash-already-evaluated clashes) t)) | |
| 548 | (unless (clash-one clashes sat-proc given-subst inf-id giv-sat) | |
| 549 | (setq backup t)))) | |
| 550 | ) ; loop end | |
| 542 | (if (clash-evaluable clashes) | |
| 543 | (if (or (clash-already-evaluated clashes) | |
| 544 | (not (clash-evaluation clashes))) | |
| 545 | (setq backup t) | |
| 546 | ;; set flag and proceed | |
| 547 | (setf (clash-already-evaluated clashes) t)) | |
| 548 | (unless (clash-one clashes sat-proc given-subst inf-id giv-sat) | |
| 549 | (setq backup t)))) | |
| 550 | ) ; loop end | |
| 551 | 551 | ;; done |
| 552 | 552 | list-resolvent)) |
| 553 | 553 | |
| 563 | 563 | (return-from hyper-resolution nil)) |
| 564 | 564 | ;; |
| 565 | 565 | (let ((resolvent-list nil) |
| 566 | (given-literals nil) | |
| 567 | (clash-start nil) | |
| 568 | (last-clash nil) | |
| 569 | (nuc-literals nil) | |
| 570 | (nuc-pos 0)) | |
| 566 | (given-literals nil) | |
| 567 | (clash-start nil) | |
| 568 | (last-clash nil) | |
| 569 | (nuc-literals nil) | |
| 570 | (nuc-pos 0)) | |
| 571 | 571 | (declare (type list resolvent-list) |
| 572 | (type list given-literals) | |
| 573 | (type (or null clash) clash-start) | |
| 574 | (type (or null clash) last-clash) | |
| 575 | (type list nuc-literals) | |
| 576 | (type fixnum nuc-pos)) | |
| 572 | (type list given-literals) | |
| 573 | (type (or null clash) clash-start) | |
| 574 | (type (or null clash) last-clash) | |
| 575 | (type list nuc-literals) | |
| 576 | (type fixnum nuc-pos)) | |
| 577 | 577 | (when (pn-flag debug-hyper-res) |
| 578 | 578 | (with-output-simple-msg () |
| 579 | (princ "Start[hyper-resolution]:") | |
| 580 | (print-next) | |
| 581 | (print-clause clause))) | |
| 579 | (princ "Start[hyper-resolution]:") | |
| 580 | (print-next) | |
| 581 | (print-clause clause))) | |
| 582 | 582 | (cond |
| 583 | 583 | ((not (positive-clause? clause)) |
| 584 | 584 | ;; given clause is nucleus,i.e, contains at least one |
| 585 | 585 | ;; negative literal |
| 586 | 586 | (setq clash-start nil |
| 587 | last-clash nil | |
| 588 | nuc-literals nil) | |
| 587 | last-clash nil | |
| 588 | nuc-literals nil) | |
| 589 | 589 | (dolist (lit (clause-literals clause)) |
| 590 | (cond ((or (positive-literal? lit) (answer-literal? lit)) | |
| 591 | (push lit nuc-literals)) | |
| 592 | ;; | |
| 593 | (t (let ((new-clash (make-clash :literal lit | |
| 594 | :db *clash-pos-literals*))) | |
| 595 | (declare (type clash new-clash)) | |
| 596 | (if (null clash-start) | |
| 597 | (setq clash-start new-clash) | |
| 598 | (progn | |
| 599 | (setf (clash-prev new-clash) last-clash) | |
| 600 | (setf (clash-next last-clash) new-clash))) | |
| 601 | (when (method-is-meta-demod (term-head (literal-atom lit))) | |
| 602 | (setf (clash-evaluable new-clash) t)) | |
| 603 | (setq last-clash new-clash))))) | |
| 590 | (cond ((or (positive-literal? lit) (answer-literal? lit)) | |
| 591 | (push lit nuc-literals)) | |
| 592 | ;; | |
| 593 | (t (let ((new-clash (make-clash :literal lit | |
| 594 | :db *clash-pos-literals*))) | |
| 595 | (declare (type clash new-clash)) | |
| 596 | (if (null clash-start) | |
| 597 | (setq clash-start new-clash) | |
| 598 | (progn | |
| 599 | (setf (clash-prev new-clash) last-clash) | |
| 600 | (setf (clash-next last-clash) new-clash))) | |
| 601 | (when (method-is-meta-demod (term-head (literal-atom lit))) | |
| 602 | (setf (clash-evaluable new-clash) t)) | |
| 603 | (setq last-clash new-clash))))) | |
| 604 | 604 | ;; |
| 605 | 605 | (let ((res (hyper-clash! clash-start |
| 606 | nil ; subst | |
| 607 | nuc-literals | |
| 608 | clause | |
| 609 | nil | |
| 610 | nil | |
| 611 | #'positive-clause? | |
| 612 | :hyper-res-rule | |
| 613 | nil))) | |
| 614 | (when res | |
| 615 | (setq resolvent-list (nconc res resolvent-list))))) | |
| 606 | nil ; subst | |
| 607 | nuc-literals | |
| 608 | clause | |
| 609 | nil | |
| 610 | nil | |
| 611 | #'positive-clause? | |
| 612 | :hyper-res-rule | |
| 613 | nil))) | |
| 614 | (when res | |
| 615 | (setq resolvent-list (nconc res resolvent-list))))) | |
| 616 | 616 | ;; |
| 617 | 617 | (t |
| 618 | 618 | ;; |
| 619 | 619 | ;; given clause is a satellite. |
| 620 | 620 | ;; |
| 621 | 621 | (dolist (l3 (clause-literals clause)) |
| 622 | (declare (type literal l3)) | |
| 623 | (when (or (not (pn-flag order-hyper)) | |
| 624 | (maximal-literal l3)) | |
| 625 | (setq given-literals nil) | |
| 626 | (dolist (lit (clause-literals clause)) | |
| 627 | (declare (type literal lit)) | |
| 628 | (unless (eq l3 lit) | |
| 629 | (push lit given-literals))) | |
| 630 | (let ((clashables | |
| 631 | ;; (get-literal-entry-from-atom *clash-neg-literals* | |
| 632 | ;; (literal-atom l3)) | |
| 633 | (is-fetch-concat (literal-atom l3) *clash-neg-literals*) | |
| 634 | ) | |
| 635 | ) | |
| 636 | (dolist (lit-data clashables) | |
| 637 | (block next | |
| 638 | (let* (;; (nuc-lit (literal-entry-literal lit-data)) | |
| 639 | (nuc-lit lit-data) | |
| 640 | (nuc (literal-clause (the literal nuc-lit)))) | |
| 641 | (when (not (positive-clause? nuc)) | |
| 642 | (multiple-value-bind (new-subst no-match e-equal) | |
| 643 | (unify (literal-atom l3) | |
| 644 | (literal-atom nuc-lit) | |
| 645 | nil) | |
| 646 | (declare (ignore e-equal) | |
| 647 | (type list new-subst)) | |
| 648 | ;; | |
| 649 | (when no-match (return-from next)) ; try next | |
| 650 | ||
| 651 | ;; found a nucleus | |
| 652 | (setq nuc-literals nil) | |
| 653 | (setq clash-start nil | |
| 654 | last-clash nil) | |
| 655 | (let ((i 0)) | |
| 656 | (declare (type fixnum i)) | |
| 657 | (dolist (lit (clause-literals nuc)) | |
| 658 | (declare (type literal lit)) | |
| 659 | (cond ((eq nuc-lit lit) | |
| 660 | (setq nuc-pos i)) | |
| 661 | ((or (positive-literal? lit) | |
| 662 | (answer-literal? lit)) | |
| 663 | (push lit nuc-literals)) | |
| 664 | (t | |
| 665 | ;; negative literal, put into clash structure | |
| 666 | (let ((new-clash (make-clash :literal lit | |
| 667 | :db *clash-pos-literals*))) | |
| 668 | (declare (type clash new-clash)) | |
| 669 | (if (null clash-start) | |
| 670 | (setq clash-start new-clash) | |
| 671 | (progn | |
| 672 | (setf (clash-prev new-clash) | |
| 673 | last-clash) | |
| 674 | (setf (clash-next last-clash) | |
| 675 | new-clash))) | |
| 676 | (when (method-is-meta-demod | |
| 677 | (term-head (literal-atom lit))) | |
| 678 | (setf (clash-evaluable new-clash) t)) | |
| 679 | (setq last-clash new-clash)))))) | |
| 680 | ;; | |
| 681 | (let ((res (hyper-clash! clash-start | |
| 682 | new-subst | |
| 683 | nuc-literals | |
| 684 | nuc | |
| 685 | given-literals | |
| 686 | clause | |
| 687 | #'positive-clause? | |
| 688 | :hyper-res-rule | |
| 689 | nuc-pos))) | |
| 690 | (when res | |
| 691 | (setq resolvent-list (nconc res | |
| 692 | resolvent-list))) | |
| 693 | ))))) ; block next | |
| 694 | )) ; done for all possible clash | |
| 695 | ) | |
| 696 | ) ; done for all literals | |
| 622 | (declare (type literal l3)) | |
| 623 | (when (or (not (pn-flag order-hyper)) | |
| 624 | (maximal-literal l3)) | |
| 625 | (setq given-literals nil) | |
| 626 | (dolist (lit (clause-literals clause)) | |
| 627 | (declare (type literal lit)) | |
| 628 | (unless (eq l3 lit) | |
| 629 | (push lit given-literals))) | |
| 630 | (let ((clashables | |
| 631 | ;; (get-literal-entry-from-atom *clash-neg-literals* | |
| 632 | ;; (literal-atom l3)) | |
| 633 | (is-fetch-concat (literal-atom l3) *clash-neg-literals*) | |
| 634 | ) | |
| 635 | ) | |
| 636 | (dolist (lit-data clashables) | |
| 637 | (block next | |
| 638 | (let* (;; (nuc-lit (literal-entry-literal lit-data)) | |
| 639 | (nuc-lit lit-data) | |
| 640 | (nuc (literal-clause (the literal nuc-lit)))) | |
| 641 | (when (not (positive-clause? nuc)) | |
| 642 | (multiple-value-bind (new-subst no-match e-equal) | |
| 643 | (unify (literal-atom l3) | |
| 644 | (literal-atom nuc-lit) | |
| 645 | nil) | |
| 646 | (declare (ignore e-equal) | |
| 647 | (type list new-subst)) | |
| 648 | ;; | |
| 649 | (when no-match (return-from next)) ; try next | |
| 650 | ||
| 651 | ;; found a nucleus | |
| 652 | (setq nuc-literals nil) | |
| 653 | (setq clash-start nil | |
| 654 | last-clash nil) | |
| 655 | (let ((i 0)) | |
| 656 | (declare (type fixnum i)) | |
| 657 | (dolist (lit (clause-literals nuc)) | |
| 658 | (declare (type literal lit)) | |
| 659 | (cond ((eq nuc-lit lit) | |
| 660 | (setq nuc-pos i)) | |
| 661 | ((or (positive-literal? lit) | |
| 662 | (answer-literal? lit)) | |
| 663 | (push lit nuc-literals)) | |
| 664 | (t | |
| 665 | ;; negative literal, put into clash structure | |
| 666 | (let ((new-clash (make-clash :literal lit | |
| 667 | :db *clash-pos-literals*))) | |
| 668 | (declare (type clash new-clash)) | |
| 669 | (if (null clash-start) | |
| 670 | (setq clash-start new-clash) | |
| 671 | (progn | |
| 672 | (setf (clash-prev new-clash) | |
| 673 | last-clash) | |
| 674 | (setf (clash-next last-clash) | |
| 675 | new-clash))) | |
| 676 | (when (method-is-meta-demod | |
| 677 | (term-head (literal-atom lit))) | |
| 678 | (setf (clash-evaluable new-clash) t)) | |
| 679 | (setq last-clash new-clash)))))) | |
| 680 | ;; | |
| 681 | (let ((res (hyper-clash! clash-start | |
| 682 | new-subst | |
| 683 | nuc-literals | |
| 684 | nuc | |
| 685 | given-literals | |
| 686 | clause | |
| 687 | #'positive-clause? | |
| 688 | :hyper-res-rule | |
| 689 | nuc-pos))) | |
| 690 | (when res | |
| 691 | (setq resolvent-list (nconc res | |
| 692 | resolvent-list))) | |
| 693 | ))))) ; block next | |
| 694 | )) ; done for all possible clash | |
| 695 | ) | |
| 696 | ) ; done for all literals | |
| 697 | 697 | ) |
| 698 | 698 | ) |
| 699 | 699 | ;; done |
| 700 | 700 | (when (pn-flag debug-hyper-res) |
| 701 | 701 | (with-output-simple-msg () |
| 702 | (princ "End[hyper-res]") | |
| 703 | (print-next) | |
| 704 | (pr-clause-list resolvent-list))) | |
| 702 | (princ "End[hyper-res]") | |
| 703 | (print-next) | |
| 704 | (pr-clause-list resolvent-list))) | |
| 705 | 705 | ;; |
| 706 | 706 | (nreverse resolvent-list) |
| 707 | 707 | )) |
| 719 | 719 | (return-from neg-hyper-resolution nil)) |
| 720 | 720 | ;; |
| 721 | 721 | (let ((resolvent-list nil) |
| 722 | (given-literals nil) | |
| 723 | (clash-start nil) | |
| 724 | (last-clash nil) | |
| 725 | (nuc-literals nil) | |
| 726 | (nuc-pos 0)) | |
| 722 | (given-literals nil) | |
| 723 | (clash-start nil) | |
| 724 | (last-clash nil) | |
| 725 | (nuc-literals nil) | |
| 726 | (nuc-pos 0)) | |
| 727 | 727 | (declare (type list resolvent-list) |
| 728 | (type list given-literals) | |
| 729 | (type (or null clash) clash-start) | |
| 730 | (type (or null clash) last-clash) | |
| 731 | (type list nuc-literals) | |
| 732 | (type fixnum nuc-pos)) | |
| 728 | (type list given-literals) | |
| 729 | (type (or null clash) clash-start) | |
| 730 | (type (or null clash) last-clash) | |
| 731 | (type list nuc-literals) | |
| 732 | (type fixnum nuc-pos)) | |
| 733 | 733 | (when (pn-flag debug-hyper-res) |
| 734 | 734 | (with-output-simple-msg () |
| 735 | (princ "Start[neg-hyper-resolution]:") | |
| 736 | (print-next) | |
| 737 | (print-clause clause))) | |
| 735 | (princ "Start[neg-hyper-resolution]:") | |
| 736 | (print-next) | |
| 737 | (print-clause clause))) | |
| 738 | 738 | (cond |
| 739 | ((not (negative-clause? clause)) ; given clause is nucleus | |
| 739 | ((not (negative-clause? clause)) ; given clause is nucleus | |
| 740 | 740 | ;; given clause is nucleus,i.e, contains at least one |
| 741 | 741 | ;; positive literal |
| 742 | 742 | (setq clash-start nil |
| 743 | last-clash nil | |
| 744 | nuc-literals nil) | |
| 743 | last-clash nil | |
| 744 | nuc-literals nil) | |
| 745 | 745 | (dolist (lit (clause-literals clause)) |
| 746 | (declare (type literal lit)) | |
| 747 | (cond ((or (negative-literal? lit) (answer-literal? lit)) | |
| 748 | (push lit nuc-literals)) | |
| 749 | ;; put positive literal into clash structure | |
| 750 | (t (let ((new-clash (make-clash :literal lit | |
| 751 | :db *clash-neg-literals*))) | |
| 752 | (declare (type clash new-clash)) | |
| 753 | (if (null clash-start) | |
| 754 | (setq clash-start new-clash) | |
| 755 | (progn | |
| 756 | (setf (clash-prev new-clash) last-clash) | |
| 757 | (setf (clash-next last-clash) new-clash))) | |
| 758 | (when (method-is-meta-demod (term-head (literal-atom lit))) | |
| 759 | (setf (clash-evaluable new-clash) t)) | |
| 760 | (setq last-clash new-clash))))) | |
| 746 | (declare (type literal lit)) | |
| 747 | (cond ((or (negative-literal? lit) (answer-literal? lit)) | |
| 748 | (push lit nuc-literals)) | |
| 749 | ;; put positive literal into clash structure | |
| 750 | (t (let ((new-clash (make-clash :literal lit | |
| 751 | :db *clash-neg-literals*))) | |
| 752 | (declare (type clash new-clash)) | |
| 753 | (if (null clash-start) | |
| 754 | (setq clash-start new-clash) | |
| 755 | (progn | |
| 756 | (setf (clash-prev new-clash) last-clash) | |
| 757 | (setf (clash-next last-clash) new-clash))) | |
| 758 | (when (method-is-meta-demod (term-head (literal-atom lit))) | |
| 759 | (setf (clash-evaluable new-clash) t)) | |
| 760 | (setq last-clash new-clash))))) | |
| 761 | 761 | ;; |
| 762 | 762 | (let ((res (hyper-clash! clash-start |
| 763 | nil ; subst | |
| 764 | nuc-literals | |
| 765 | clause | |
| 766 | nil | |
| 767 | nil | |
| 768 | #'negative-clause? | |
| 769 | :neg-hyper-res-rule | |
| 770 | nil))) | |
| 771 | (when res | |
| 772 | (setq resolvent-list (nconc res resolvent-list))))) | |
| 763 | nil ; subst | |
| 764 | nuc-literals | |
| 765 | clause | |
| 766 | nil | |
| 767 | nil | |
| 768 | #'negative-clause? | |
| 769 | :neg-hyper-res-rule | |
| 770 | nil))) | |
| 771 | (when res | |
| 772 | (setq resolvent-list (nconc res resolvent-list))))) | |
| 773 | 773 | ;; |
| 774 | 774 | ;; given clause is a sattelite. |
| 775 | 775 | ;; |
| 776 | 776 | (t |
| 777 | 777 | (dolist (l3 (clause-literals clause)) |
| 778 | (declare (type literal l3)) | |
| 779 | (when (or (not (pn-flag order-hyper)) | |
| 780 | (maximal-literal l3)) | |
| 781 | (setq given-literals nil) | |
| 782 | (dolist (lit (clause-literals clause)) | |
| 783 | (declare (type literal lit)) | |
| 784 | (unless (eq l3 lit) | |
| 785 | (push lit given-literals))) | |
| 786 | (let ((clashables | |
| 787 | ;; (get-literal-entry-from-atom *clash-pos-literals* | |
| 788 | ;; (literal-atom l3)) | |
| 789 | (is-fetch-concat (literal-atom l3) *clash-pos-literals*) | |
| 790 | ) | |
| 791 | ) | |
| 792 | (dolist (lit-data clashables) | |
| 793 | (block next | |
| 794 | (let* (;; (nuc-lit (literal-entry-literal lit-data)) | |
| 795 | (nuc-lit lit-data) | |
| 796 | (nuc (literal-clause (the literal nuc-lit)))) | |
| 797 | (when (not (negative-clause? nuc)) | |
| 798 | (multiple-value-bind (new-subst no-match e-equal) | |
| 799 | (unify (literal-atom l3) | |
| 800 | (literal-atom nuc-lit) | |
| 801 | nil) | |
| 802 | (declare (ignore e-equal) | |
| 803 | (type list new-subst)) | |
| 804 | ;; | |
| 805 | (when no-match (return-from next)) ; try next | |
| 806 | ||
| 807 | ;; found a nucleus | |
| 808 | (setq nuc-literals nil) | |
| 809 | (setq clash-start nil | |
| 810 | last-clash nil) | |
| 811 | (let ((i 0)) | |
| 812 | (declare (type fixnum i)) | |
| 813 | (dolist (lit (clause-literals nuc)) | |
| 814 | (declare (type literal lit)) | |
| 815 | (cond ((eq nuc-lit lit) | |
| 816 | (setq nuc-pos i)) | |
| 817 | ((or (negative-literal? lit) | |
| 818 | (answer-literal? lit)) | |
| 819 | (push lit nuc-literals)) | |
| 820 | (t | |
| 821 | ;; pos literal, put into clash structure | |
| 822 | (let ((new-clash (make-clash :literal lit | |
| 823 | :db *clash-neg-literals*))) | |
| 824 | (declare (type clash new-clash)) | |
| 825 | (if (null clash-start) | |
| 826 | (setq clash-start new-clash) | |
| 827 | (progn | |
| 828 | (setf (clash-prev new-clash) | |
| 829 | last-clash) | |
| 830 | (setf (clash-next last-clash) | |
| 831 | new-clash))) | |
| 832 | (when (method-is-meta-demod | |
| 833 | (term-head (literal-atom lit))) | |
| 834 | (setf (clash-evaluable new-clash) t)) | |
| 835 | (setq last-clash new-clash)))))) | |
| 836 | ;; | |
| 837 | (let ((res (hyper-clash! clash-start | |
| 838 | new-subst | |
| 839 | nuc-literals | |
| 840 | nuc | |
| 841 | given-literals | |
| 842 | clause | |
| 843 | #'negative-clause? | |
| 844 | :neg-hyper-res-rule | |
| 845 | nuc-pos))) | |
| 846 | (when res | |
| 847 | (setq resolvent-list (nconc res | |
| 848 | resolvent-list))) | |
| 849 | ))))) ; block next | |
| 850 | )) ; done for all possible clash | |
| 851 | ) | |
| 852 | ) ; done for all literals | |
| 778 | (declare (type literal l3)) | |
| 779 | (when (or (not (pn-flag order-hyper)) | |
| 780 | (maximal-literal l3)) | |
| 781 | (setq given-literals nil) | |
| 782 | (dolist (lit (clause-literals clause)) | |
| 783 | (declare (type literal lit)) | |
| 784 | (unless (eq l3 lit) | |
| 785 | (push lit given-literals))) | |
| 786 | (let ((clashables | |
| 787 | ;; (get-literal-entry-from-atom *clash-pos-literals* | |
| 788 | ;; (literal-atom l3)) | |
| 789 | (is-fetch-concat (literal-atom l3) *clash-pos-literals*) | |
| 790 | ) | |
| 791 | ) | |
| 792 | (dolist (lit-data clashables) | |
| 793 | (block next | |
| 794 | (let* (;; (nuc-lit (literal-entry-literal lit-data)) | |
| 795 | (nuc-lit lit-data) | |
| 796 | (nuc (literal-clause (the literal nuc-lit)))) | |
| 797 | (when (not (negative-clause? nuc)) | |
| 798 | (multiple-value-bind (new-subst no-match e-equal) | |
| 799 | (unify (literal-atom l3) | |
| 800 | (literal-atom nuc-lit) | |
| 801 | nil) | |
| 802 | (declare (ignore e-equal) | |
| 803 | (type list new-subst)) | |
| 804 | ;; | |
| 805 | (when no-match (return-from next)) ; try next | |
| 806 | ||
| 807 | ;; found a nucleus | |
| 808 | (setq nuc-literals nil) | |
| 809 | (setq clash-start nil | |
| 810 | last-clash nil) | |
| 811 | (let ((i 0)) | |
| 812 | (declare (type fixnum i)) | |
| 813 | (dolist (lit (clause-literals nuc)) | |
| 814 | (declare (type literal lit)) | |
| 815 | (cond ((eq nuc-lit lit) | |
| 816 | (setq nuc-pos i)) | |
| 817 | ((or (negative-literal? lit) | |
| 818 | (answer-literal? lit)) | |
| 819 | (push lit nuc-literals)) | |
| 820 | (t | |
| 821 | ;; pos literal, put into clash structure | |
| 822 | (let ((new-clash (make-clash :literal lit | |
| 823 | :db *clash-neg-literals*))) | |
| 824 | (declare (type clash new-clash)) | |
| 825 | (if (null clash-start) | |
| 826 | (setq clash-start new-clash) | |
| 827 | (progn | |
| 828 | (setf (clash-prev new-clash) | |
| 829 | last-clash) | |
| 830 | (setf (clash-next last-clash) | |
| 831 | new-clash))) | |
| 832 | (when (method-is-meta-demod | |
| 833 | (term-head (literal-atom lit))) | |
| 834 | (setf (clash-evaluable new-clash) t)) | |
| 835 | (setq last-clash new-clash)))))) | |
| 836 | ;; | |
| 837 | (let ((res (hyper-clash! clash-start | |
| 838 | new-subst | |
| 839 | nuc-literals | |
| 840 | nuc | |
| 841 | given-literals | |
| 842 | clause | |
| 843 | #'negative-clause? | |
| 844 | :neg-hyper-res-rule | |
| 845 | nuc-pos))) | |
| 846 | (when res | |
| 847 | (setq resolvent-list (nconc res | |
| 848 | resolvent-list))) | |
| 849 | ))))) ; block next | |
| 850 | )) ; done for all possible clash | |
| 851 | ) | |
| 852 | ) ; done for all literals | |
| 853 | 853 | ) |
| 854 | 854 | ) |
| 855 | 855 | ;; done |
| 856 | 856 | (when (pn-flag debug-hyper-res) |
| 857 | 857 | (with-output-simple-msg () |
| 858 | (princ "End[neg-hyper-res]") | |
| 859 | (print-next) | |
| 860 | (pr-clause-list resolvent-list))) | |
| 858 | (princ "End[neg-hyper-res]") | |
| 859 | (print-next) | |
| 860 | (pr-clause-list resolvent-list))) | |
| 861 | 861 | ;; |
| 862 | 862 | (nreverse resolvent-list) |
| 863 | 863 | )) |
| 871 | 871 | ;;; |
| 872 | 872 | (defun ur-resolution (clause) |
| 873 | 873 | (let ((num-lits 0) |
| 874 | (resolvent-list nil) | |
| 875 | (given-literals nil) | |
| 876 | (clash-start nil) | |
| 877 | (last-clash nil) | |
| 878 | (nuc-literals nil) | |
| 879 | (nuc-pos 0)) | |
| 874 | (resolvent-list nil) | |
| 875 | (given-literals nil) | |
| 876 | (clash-start nil) | |
| 877 | (last-clash nil) | |
| 878 | (nuc-literals nil) | |
| 879 | (nuc-pos 0)) | |
| 880 | 880 | (setq num-lits (num-literals clause)) |
| 881 | 881 | (when (= 0 num-lits) |
| 882 | 882 | (return-from ur-resolution nil)) |
| 883 | (cond ((> num-lits 1) ; given clause is nucleus | |
| 884 | (setq clash-start nil ; i.e., non-unit clause | |
| 885 | last-clash nil | |
| 886 | nuc-literals nil) | |
| 887 | (dolist (lit (clause-literals clause)) | |
| 888 | (declare (type literal lit)) | |
| 889 | (cond ((answer-literal? lit) | |
| 890 | (push lit nuc-literals)))) | |
| 891 | ;; setup nlits - 1 empty clash nodes | |
| 892 | (dotimes (x (1- num-lits)) | |
| 893 | (let ((new-clash (make-clash))) | |
| 894 | (if (null clash-start) | |
| 895 | (setq clash-start new-clash) | |
| 896 | (progn | |
| 897 | (setf (clash-prev new-clash) last-clash) | |
| 898 | (setf (clash-next last-clash) new-clash))) | |
| 899 | (setq last-clash new-clash))) | |
| 900 | (dolist (box (clause-literals clause)) | |
| 901 | (unless (answer-literal? box) | |
| 902 | (push box nuc-literals) | |
| 903 | (let ((c1 clash-start)) | |
| 904 | (dolist (lit (clause-literals clause)) | |
| 905 | (when (and (not (eq lit box)) (not (answer-literal? lit))) | |
| 906 | (setf (clash-literal c1) lit) | |
| 907 | (setf (clash-db c1) (if (positive-literal? lit) | |
| 908 | *clash-neg-literals* | |
| 909 | *clash-pos-literals*)) | |
| 910 | (setq c1 (clash-next c1)))) | |
| 911 | (when c1 | |
| 912 | (with-output-panic-message () | |
| 913 | (princ "ur-res: too many clash nodes (nuc)."))) | |
| 914 | (let ((res (hyper-clash! clash-start | |
| 915 | nil ; subst | |
| 916 | nuc-literals | |
| 917 | clause | |
| 918 | nil | |
| 919 | nil | |
| 920 | #'unit-clause? | |
| 921 | :ur-res-rule | |
| 922 | nil))) | |
| 923 | (when res | |
| 924 | (setq resolvent-list (nconc res resolvent-list)))) | |
| 925 | (pop nuc-literals)))) | |
| 926 | ) ; end of case nucleus | |
| 927 | ;; | |
| 928 | (t ; given clause is satellite (unit). | |
| 929 | ;; collect any answer literal from given satellite | |
| 930 | ;; and get clashable literal (l3). | |
| 931 | (let ((l3 nil)) | |
| 932 | (dolist (lit (clause-literals clause)) | |
| 933 | (if (not (answer-literal? lit)) | |
| 934 | (setq l3 lit) ; the only non-answer literal | |
| 935 | (progn | |
| 936 | (push lit given-literals)))) | |
| 937 | (let ((clashables | |
| 938 | #|| | |
| 939 | (get-literal-entry-from-atom (if (positive-literal? l3) | |
| 940 | *clash-neg-literals* | |
| 941 | *clash-pos-literals*) | |
| 942 | (literal-atom l3)) | |
| 943 | ||# | |
| 944 | (is-fetch-concat (literal-atom l3) | |
| 945 | (if (positive-literal? l3) | |
| 946 | *clash-neg-literals* | |
| 947 | *clash-pos-literals*)) | |
| 948 | )) | |
| 949 | (dolist (lit-data clashables) | |
| 950 | (block next | |
| 951 | (let* (;; (nuc-lit (literal-entry-literal lit-data)) | |
| 952 | (nuc-lit lit-data) | |
| 953 | (nuc (literal-clause nuc-lit)) | |
| 954 | (nlits (num-literals nuc)) | |
| 955 | (new-subst nil) | |
| 956 | (no-match nil) | |
| 957 | (e-equal nil)) | |
| 958 | (declare (ignore e-equal)) | |
| 959 | (when (> nlits 1) | |
| 960 | (multiple-value-setq (new-subst no-match e-equal) | |
| 961 | (unify (literal-atom l3) | |
| 962 | (literal-atom nuc-lit) | |
| 963 | nil)) | |
| 964 | (when no-match (return-from next)) ; try next | |
| 965 | ;; found a nucleus | |
| 966 | (setq nuc-literals nil) | |
| 967 | (setq clash-start nil | |
| 968 | last-clash nil) | |
| 969 | ;; put answer literal into nuc-literals | |
| 970 | (dolist (lit (clause-literals nuc)) | |
| 971 | (when (answer-literal? lit) | |
| 972 | (push lit nuc-literals))) | |
| 973 | ;; build clash structure for this nucleus | |
| 974 | ;; nlits - 2 empty clash nodes | |
| 975 | (dotimes (x (- nlits 2)) | |
| 976 | (let ((new-clash (make-clash))) | |
| 977 | (if (null clash-start) | |
| 978 | (setq clash-start new-clash) | |
| 979 | (progn | |
| 980 | (setf (clash-prev new-clash) last-clash) | |
| 981 | (setf (clash-next last-clash) new-clash))) | |
| 982 | (setq last-clash new-clash)) | |
| 983 | ) | |
| 984 | (dolist (box (clause-literals nuc)) | |
| 985 | (let ((j 1) | |
| 986 | (c1 nil)) | |
| 987 | ;; if not clashed or answer literal | |
| 988 | (when (and (not (eq box nuc-lit)) | |
| 989 | (not (answer-literal? box))) | |
| 990 | (setq c1 clash-start) | |
| 991 | (push box nuc-literals) | |
| 992 | (dolist (lit (clause-literals nuc)) | |
| 993 | (when (and (not (eq lit box)) | |
| 994 | (not (eq lit nuc-lit)) | |
| 995 | (not (answer-literal? lit))) | |
| 996 | (setf (clash-literal c1) lit) | |
| 997 | (setf (clash-db c1) (if (positive-literal? lit) | |
| 998 | *clash-neg-literals* | |
| 999 | *clash-pos-literals*)) | |
| 1000 | (setq c1 (clash-next c1)) | |
| 1001 | (incf j)) | |
| 1002 | (when (eq lit nuc-lit) | |
| 1003 | (setq nuc-pos j)) | |
| 1004 | ) | |
| 1005 | (unless (null c1) | |
| 1006 | (princ c1) | |
| 1007 | (break "aho!") | |
| 1008 | (with-output-panic-message () | |
| 1009 | (princ "ur-res: too many clash nodes (sat)."))) | |
| 1010 | (let ((res (hyper-clash! clash-start | |
| 1011 | new-subst | |
| 1012 | nuc-literals | |
| 1013 | nuc | |
| 1014 | given-literals | |
| 1015 | clause | |
| 1016 | #'unit-clause? | |
| 1017 | :ur-res | |
| 1018 | nuc-pos)) | |
| 1019 | ) | |
| 1020 | (when res | |
| 1021 | (setq resolvent-list | |
| 1022 | (nconc res resolvent-list))) | |
| 1023 | ;; | |
| 1024 | (pop nuc-literals))))) | |
| 1025 | ))) ; block next | |
| 1026 | )) ; done for all possible clash | |
| 1027 | ) ; end case of satelite | |
| 1028 | )) | |
| 883 | (cond ((> num-lits 1) ; given clause is nucleus | |
| 884 | (setq clash-start nil ; i.e., non-unit clause | |
| 885 | last-clash nil | |
| 886 | nuc-literals nil) | |
| 887 | (dolist (lit (clause-literals clause)) | |
| 888 | (declare (type literal lit)) | |
| 889 | (cond ((answer-literal? lit) | |
| 890 | (push lit nuc-literals)))) | |
| 891 | ;; setup nlits - 1 empty clash nodes | |
| 892 | (dotimes (x (1- num-lits)) | |
| 893 | (let ((new-clash (make-clash))) | |
| 894 | (if (null clash-start) | |
| 895 | (setq clash-start new-clash) | |
| 896 | (progn | |
| 897 | (setf (clash-prev new-clash) last-clash) | |
| 898 | (setf (clash-next last-clash) new-clash))) | |
| 899 | (setq last-clash new-clash))) | |
| 900 | (dolist (box (clause-literals clause)) | |
| 901 | (unless (answer-literal? box) | |
| 902 | (push box nuc-literals) | |
| 903 | (let ((c1 clash-start)) | |
| 904 | (dolist (lit (clause-literals clause)) | |
| 905 | (when (and (not (eq lit box)) (not (answer-literal? lit))) | |
| 906 | (setf (clash-literal c1) lit) | |
| 907 | (setf (clash-db c1) (if (positive-literal? lit) | |
| 908 | *clash-neg-literals* | |
| 909 | *clash-pos-literals*)) | |
| 910 | (setq c1 (clash-next c1)))) | |
| 911 | (when c1 | |
| 912 | (with-output-panic-message () | |
| 913 | (princ "ur-res: too many clash nodes (nuc)."))) | |
| 914 | (let ((res (hyper-clash! clash-start | |
| 915 | nil ; subst | |
| 916 | nuc-literals | |
| 917 | clause | |
| 918 | nil | |
| 919 | nil | |
| 920 | #'unit-clause? | |
| 921 | :ur-res-rule | |
| 922 | nil))) | |
| 923 | (when res | |
| 924 | (setq resolvent-list (nconc res resolvent-list)))) | |
| 925 | (pop nuc-literals)))) | |
| 926 | ) ; end of case nucleus | |
| 927 | ;; | |
| 928 | (t ; given clause is satellite (unit). | |
| 929 | ;; collect any answer literal from given satellite | |
| 930 | ;; and get clashable literal (l3). | |
| 931 | (let ((l3 nil)) | |
| 932 | (dolist (lit (clause-literals clause)) | |
| 933 | (if (not (answer-literal? lit)) | |
| 934 | (setq l3 lit) ; the only non-answer literal | |
| 935 | (progn | |
| 936 | (push lit given-literals)))) | |
| 937 | (let ((clashables | |
| 938 | #|| | |
| 939 | (get-literal-entry-from-atom (if (positive-literal? l3) | |
| 940 | *clash-neg-literals* | |
| 941 | *clash-pos-literals*) | |
| 942 | (literal-atom l3)) | |
| 943 | ||# | |
| 944 | (is-fetch-concat (literal-atom l3) | |
| 945 | (if (positive-literal? l3) | |
| 946 | *clash-neg-literals* | |
| 947 | *clash-pos-literals*)) | |
| 948 | )) | |
| 949 | (dolist (lit-data clashables) | |
| 950 | (block next | |
| 951 | (let* (;; (nuc-lit (literal-entry-literal lit-data)) | |
| 952 | (nuc-lit lit-data) | |
| 953 | (nuc (literal-clause nuc-lit)) | |
| 954 | (nlits (num-literals nuc)) | |
| 955 | (new-subst nil) | |
| 956 | (no-match nil) | |
| 957 | (e-equal nil)) | |
| 958 | (declare (ignore e-equal)) | |
| 959 | (when (> nlits 1) | |
| 960 | (multiple-value-setq (new-subst no-match e-equal) | |
| 961 | (unify (literal-atom l3) | |
| 962 | (literal-atom nuc-lit) | |
| 963 | nil)) | |
| 964 | (when no-match (return-from next)) ; try next | |
| 965 | ;; found a nucleus | |
| 966 | (setq nuc-literals nil) | |
| 967 | (setq clash-start nil | |
| 968 | last-clash nil) | |
| 969 | ;; put answer literal into nuc-literals | |
| 970 | (dolist (lit (clause-literals nuc)) | |
| 971 | (when (answer-literal? lit) | |
| 972 | (push lit nuc-literals))) | |
| 973 | ;; build clash structure for this nucleus | |
| 974 | ;; nlits - 2 empty clash nodes | |
| 975 | (dotimes (x (- nlits 2)) | |
| 976 | (let ((new-clash (make-clash))) | |
| 977 | (if (null clash-start) | |
| 978 | (setq clash-start new-clash) | |
| 979 | (progn | |
| 980 | (setf (clash-prev new-clash) last-clash) | |
| 981 | (setf (clash-next last-clash) new-clash))) | |
| 982 | (setq last-clash new-clash)) | |
| 983 | ) | |
| 984 | (dolist (box (clause-literals nuc)) | |
| 985 | (let ((j 1) | |
| 986 | (c1 nil)) | |
| 987 | ;; if not clashed or answer literal | |
| 988 | (when (and (not (eq box nuc-lit)) | |
| 989 | (not (answer-literal? box))) | |
| 990 | (setq c1 clash-start) | |
| 991 | (push box nuc-literals) | |
| 992 | (dolist (lit (clause-literals nuc)) | |
| 993 | (when (and (not (eq lit box)) | |
| 994 | (not (eq lit nuc-lit)) | |
| 995 | (not (answer-literal? lit))) | |
| 996 | (setf (clash-literal c1) lit) | |
| 997 | (setf (clash-db c1) (if (positive-literal? lit) | |
| 998 | *clash-neg-literals* | |
| 999 | *clash-pos-literals*)) | |
| 1000 | (setq c1 (clash-next c1)) | |
| 1001 | (incf j)) | |
| 1002 | (when (eq lit nuc-lit) | |
| 1003 | (setq nuc-pos j)) | |
| 1004 | ) | |
| 1005 | (unless (null c1) | |
| 1006 | (princ c1) | |
| 1007 | (break "aho!") | |
| 1008 | (with-output-panic-message () | |
| 1009 | (princ "ur-res: too many clash nodes (sat)."))) | |
| 1010 | (let ((res (hyper-clash! clash-start | |
| 1011 | new-subst | |
| 1012 | nuc-literals | |
| 1013 | nuc | |
| 1014 | given-literals | |
| 1015 | clause | |
| 1016 | #'unit-clause? | |
| 1017 | :ur-res | |
| 1018 | nuc-pos)) | |
| 1019 | ) | |
| 1020 | (when res | |
| 1021 | (setq resolvent-list | |
| 1022 | (nconc res resolvent-list))) | |
| 1023 | ;; | |
| 1024 | (pop nuc-literals))))) | |
| 1025 | ))) ; block next | |
| 1026 | )) ; done for all possible clash | |
| 1027 | ) ; end case of satelite | |
| 1028 | )) | |
| 1029 | 1029 | (nreverse resolvent-list) |
| 1030 | 1030 | )) |
| 1031 | ||
| 1031 | ||
| 1032 | 1032 | |
| 1033 | 1033 | ;;; BUILD-BIN-RES : Literal1 Literal2 Subst -> Clause |
| 1034 | 1034 | ;;; - construct a binary resolvent. |
| 1037 | 1037 | ;;; |
| 1038 | 1038 | (defun build-bin-res (l1 l2 subst &optional prop) |
| 1039 | 1039 | (declare (type literal l1 l2) |
| 1040 | (type list subst)) | |
| 1040 | (type list subst)) | |
| 1041 | 1041 | (let ((new-literals nil) |
| 1042 | (new-clause (new-clause *current-psys*))) | |
| 1042 | (new-clause (new-clause *current-psys*))) | |
| 1043 | 1043 | (declare (type list new-literals) |
| 1044 | (type clause new-clause)) | |
| 1044 | (type clause new-clause)) | |
| 1045 | 1045 | (flet ((make-bin-res (literal) |
| 1046 | (declare (type literal literal)) | |
| 1047 | (dolist (lit (clause-literals (literal-clause literal))) | |
| 1048 | (declare (type literal lit)) | |
| 1049 | (let ((new-literal nil)) | |
| 1050 | (declare (type (or null literal) new-literal)) | |
| 1051 | (unless (eq literal lit) | |
| 1052 | (setq new-literal (shallow-copy-literal lit new-clause)) | |
| 1053 | (setf (literal-atom new-literal) | |
| 1054 | (apply-subst subst (literal-atom lit))) | |
| 1055 | (push new-literal new-literals)))) | |
| 1056 | )) | |
| 1046 | (declare (type literal literal)) | |
| 1047 | (dolist (lit (clause-literals (literal-clause literal))) | |
| 1048 | (declare (type literal lit)) | |
| 1049 | (let ((new-literal nil)) | |
| 1050 | (declare (type (or null literal) new-literal)) | |
| 1051 | (unless (eq literal lit) | |
| 1052 | (setq new-literal (shallow-copy-literal lit new-clause)) | |
| 1053 | (setf (literal-atom new-literal) | |
| 1054 | (apply-subst subst (literal-atom lit))) | |
| 1055 | (push new-literal new-literals)))) | |
| 1056 | )) | |
| 1057 | 1057 | (make-bin-res l1) |
| 1058 | 1058 | (make-bin-res l2) |
| 1059 | 1059 | (setf (clause-literals new-clause) new-literals) |
| 1060 | 1060 | (setf (clause-parents new-clause) |
| 1061 | (list (list (if prop | |
| 1062 | :pbinary-res-rule | |
| 1063 | :binary-res-rule) | |
| 1064 | (clause-id (literal-clause l1)) | |
| 1065 | (clause-id (literal-clause l2))))) | |
| 1061 | (list (list (if prop | |
| 1062 | :pbinary-res-rule | |
| 1063 | :binary-res-rule) | |
| 1064 | (clause-id (literal-clause l1)) | |
| 1065 | (clause-id (literal-clause l2))))) | |
| 1066 | 1066 | new-clause |
| 1067 | 1067 | ))) |
| 1068 | 1068 | |
| 1071 | 1071 | ;;; |
| 1072 | 1072 | (defun binary-resolution (clause &optional prop-res?) |
| 1073 | 1073 | (declare (type clause clause) |
| 1074 | (values list)) | |
| 1074 | (values list)) | |
| 1075 | 1075 | (when (pn-flag debug-binary-res) |
| 1076 | 1076 | (with-output-msg () |
| 1077 | 1077 | (princ "Start[binary-res]:") |
| 1082 | 1082 | (dolist (lit (clause-literals clause)) |
| 1083 | 1083 | (declare (type literal lit)) |
| 1084 | 1084 | (block next |
| 1085 | (when prop-res? | |
| 1086 | (unless (propositional-literal? lit) | |
| 1087 | (return-from next nil))) | |
| 1088 | (cond ((answer-literal? lit) | |
| 1089 | ;; answer literal -- not yet | |
| 1090 | ) | |
| 1091 | (t (let ((atom (literal-atom lit)) | |
| 1092 | (db (if (positive-literal? lit) | |
| 1093 | ;; positive | |
| 1094 | *clash-neg-literals* | |
| 1095 | ;; negative | |
| 1096 | *clash-pos-literals*))) | |
| 1097 | (declare (type term atom) | |
| 1098 | (type hash-table db)) | |
| 1099 | (let (;; (clashes (get-literal-entry-from-atom db atom)) | |
| 1100 | (clashes (is-fetch-concat atom db)) | |
| 1101 | (resolvent nil) | |
| 1102 | (in-subst nil)) | |
| 1103 | (dolist (lit-data clashes) | |
| 1104 | (declare (type literal lit-data)) | |
| 1105 | (let (;; (clash-atom (literal-entry-atom lit-data)) | |
| 1106 | (clash-atom (literal-atom lit-data)) | |
| 1107 | ) | |
| 1108 | (multiple-value-bind (new-subst no-match e-equal) | |
| 1109 | (if prop-res? | |
| 1110 | (prop-unify atom clash-atom) | |
| 1111 | (unify atom clash-atom in-subst)) | |
| 1112 | (declare (ignore e-equal) | |
| 1113 | (type list new-subst)) | |
| 1114 | (unless no-match | |
| 1115 | (when (pn-flag debug-binary-res) | |
| 1116 | (with-output-simple-msg () | |
| 1117 | (format t "** binary-res:(prop-res = ~a )" | |
| 1118 | (if prop-res? t nil)) | |
| 1119 | (print-next) | |
| 1120 | (princ "atom = ") | |
| 1121 | (term-print atom) | |
| 1122 | (print-next) | |
| 1123 | (format t "clash = ") | |
| 1124 | (print-clause (literal-clause | |
| 1125 | ;; (literal-entry-literal lit-data) | |
| 1126 | lit-data | |
| 1127 | )) | |
| 1128 | (print-next) | |
| 1129 | (princ "subst = ") | |
| 1130 | (print-substitution new-subst) | |
| 1131 | )) | |
| 1132 | ;; | |
| 1133 | (setq resolvent | |
| 1134 | (build-bin-res lit | |
| 1135 | ;; (literal-entry-literal lit-data) | |
| 1136 | lit-data | |
| 1137 | new-subst | |
| 1138 | prop-res?)) | |
| 1139 | ;; (setq in-subst new-subst) | |
| 1140 | (incf (pn-stat cl-generated)) | |
| 1141 | (incf (pn-stat binary-res-gen)) | |
| 1142 | #|| NOT YET | |
| 1143 | (when (heat-is-on) | |
| 1144 | (setf (clause-heat-level resolvent) | |
| 1145 | (1+ (clause-heat-level clause)))) | |
| 1146 | ||# | |
| 1147 | (let ((pre-res nil)) | |
| 1148 | (setq pre-res (pre-process resolvent nil :sos)) | |
| 1149 | (when pre-res | |
| 1150 | (push resolvent resolvent-list))) | |
| 1151 | )))) | |
| 1152 | )))) | |
| 1153 | ) ; block next | |
| 1154 | ) ; end do | |
| 1085 | (when prop-res? | |
| 1086 | (unless (propositional-literal? lit) | |
| 1087 | (return-from next nil))) | |
| 1088 | (cond ((answer-literal? lit) | |
| 1089 | ;; answer literal -- not yet | |
| 1090 | ) | |
| 1091 | (t (let ((atom (literal-atom lit)) | |
| 1092 | (db (if (positive-literal? lit) | |
| 1093 | ;; positive | |
| 1094 | *clash-neg-literals* | |
| 1095 | ;; negative | |
| 1096 | *clash-pos-literals*))) | |
| 1097 | (declare (type term atom) | |
| 1098 | (type hash-table db)) | |
| 1099 | (let (;; (clashes (get-literal-entry-from-atom db atom)) | |
| 1100 | (clashes (is-fetch-concat atom db)) | |
| 1101 | (resolvent nil) | |
| 1102 | (in-subst nil)) | |
| 1103 | (dolist (lit-data clashes) | |
| 1104 | (declare (type literal lit-data)) | |
| 1105 | (let (;; (clash-atom (literal-entry-atom lit-data)) | |
| 1106 | (clash-atom (literal-atom lit-data)) | |
| 1107 | ) | |
| 1108 | (multiple-value-bind (new-subst no-match e-equal) | |
| 1109 | (if prop-res? | |
| 1110 | (prop-unify atom clash-atom) | |
| 1111 | (unify atom clash-atom in-subst)) | |
| 1112 | (declare (ignore e-equal) | |
| 1113 | (type list new-subst)) | |
| 1114 | (unless no-match | |
| 1115 | (when (pn-flag debug-binary-res) | |
| 1116 | (with-output-simple-msg () | |
| 1117 | (format t "** binary-res:(prop-res = ~a )" | |
| 1118 | (if prop-res? t nil)) | |
| 1119 | (print-next) | |
| 1120 | (princ "atom = ") | |
| 1121 | (term-print atom) | |
| 1122 | (print-next) | |
| 1123 | (format t "clash = ") | |
| 1124 | (print-clause (literal-clause | |
| 1125 | ;; (literal-entry-literal lit-data) | |
| 1126 | lit-data | |
| 1127 | )) | |
| 1128 | (print-next) | |
| 1129 | (princ "subst = ") | |
| 1130 | (print-substitution new-subst) | |
| 1131 | )) | |
| 1132 | ;; | |
| 1133 | (setq resolvent | |
| 1134 | (build-bin-res lit | |
| 1135 | ;; (literal-entry-literal lit-data) | |
| 1136 | lit-data | |
| 1137 | new-subst | |
| 1138 | prop-res?)) | |
| 1139 | ;; (setq in-subst new-subst) | |
| 1140 | (incf (pn-stat cl-generated)) | |
| 1141 | (incf (pn-stat binary-res-gen)) | |
| 1142 | #|| NOT YET | |
| 1143 | (when (heat-is-on) | |
| 1144 | (setf (clause-heat-level resolvent) | |
| 1145 | (1+ (clause-heat-level clause)))) | |
| 1146 | ||# | |
| 1147 | (let ((pre-res nil)) | |
| 1148 | (setq pre-res (pre-process resolvent nil :sos)) | |
| 1149 | (when pre-res | |
| 1150 | (push resolvent resolvent-list))) | |
| 1151 | )))) | |
| 1152 | )))) | |
| 1153 | ) ; block next | |
| 1154 | ) ; end do | |
| 1155 | 1155 | ;; |
| 1156 | 1156 | (when (pn-flag debug-binary-res) |
| 1157 | 1157 | (with-output-msg () |
| 1158 | (princ "End[binary-res]") | |
| 1159 | (dolist (x (reverse resolvent-list)) | |
| 1160 | (print-next) | |
| 1161 | (print-clause x)) | |
| 1162 | )) | |
| 1158 | (princ "End[binary-res]") | |
| 1159 | (dolist (x (reverse resolvent-list)) | |
| 1160 | (print-next) | |
| 1161 | (print-clause x)) | |
| 1162 | )) | |
| 1163 | 1163 | ;; |
| 1164 | 1164 | (nreverse resolvent-list))) |
| 1165 | 1165 | |
| 1177 | 1177 | (defun next-factor (f-struct) |
| 1178 | 1178 | (declare (type factor f-struct)) |
| 1179 | 1179 | (let ((factored nil) |
| 1180 | (a-factor nil) | |
| 1181 | (subst nil) | |
| 1182 | (no-match nil) | |
| 1183 | (e-eq nil)) | |
| 1180 | (a-factor nil) | |
| 1181 | (subst nil) | |
| 1182 | (no-match nil) | |
| 1183 | (e-eq nil)) | |
| 1184 | 1184 | (declare (type (or null clause) a-factor) |
| 1185 | (type list subst) | |
| 1186 | (ignore e-eq)) | |
| 1185 | (type list subst) | |
| 1186 | (ignore e-eq)) | |
| 1187 | 1187 | (setq factored |
| 1188 | 1188 | (block found |
| 1189 | (do ((l1 (car (factor-l1p f-struct)) | |
| 1190 | (car (factor-l1p f-struct)))) | |
| 1191 | ((null l1) (return-from found nil)) | |
| 1192 | (declare (type (or null literal) l1)) | |
| 1193 | (setf (factor-l2p f-struct) (cdr (factor-l2p f-struct))) | |
| 1194 | (do ((l2 (car (factor-l2p f-struct)) | |
| 1195 | (car (factor-l2p f-struct)))) | |
| 1196 | ((null l2)) | |
| 1197 | (declare (type (or null literal) l2)) | |
| 1198 | (if (eq (literal-sign l1) (literal-sign l2)) | |
| 1199 | (progn | |
| 1200 | (multiple-value-setq (subst no-match e-eq) | |
| 1201 | (unify (literal-atom l1) | |
| 1202 | (literal-atom l2) | |
| 1203 | nil)) | |
| 1204 | (if no-match | |
| 1205 | (setf (factor-l2p f-struct) | |
| 1206 | (cdr (factor-l2p f-struct))) | |
| 1207 | ;; found a factor | |
| 1208 | (return-from found t))) | |
| 1209 | (setf (factor-l2p f-struct) | |
| 1210 | (cdr (factor-l2p f-struct))))) | |
| 1211 | ;; | |
| 1212 | (setf (factor-l1p f-struct) (cdr (factor-l1p f-struct))) | |
| 1213 | (setf (factor-l2p f-struct) (factor-l1p f-struct))) | |
| 1214 | ;; failed | |
| 1215 | nil | |
| 1216 | )) | |
| 1189 | (do ((l1 (car (factor-l1p f-struct)) | |
| 1190 | (car (factor-l1p f-struct)))) | |
| 1191 | ((null l1) (return-from found nil)) | |
| 1192 | (declare (type (or null literal) l1)) | |
| 1193 | (setf (factor-l2p f-struct) (cdr (factor-l2p f-struct))) | |
| 1194 | (do ((l2 (car (factor-l2p f-struct)) | |
| 1195 | (car (factor-l2p f-struct)))) | |
| 1196 | ((null l2)) | |
| 1197 | (declare (type (or null literal) l2)) | |
| 1198 | (if (eq (literal-sign l1) (literal-sign l2)) | |
| 1199 | (progn | |
| 1200 | (multiple-value-setq (subst no-match e-eq) | |
| 1201 | (unify (literal-atom l1) | |
| 1202 | (literal-atom l2) | |
| 1203 | nil)) | |
| 1204 | (if no-match | |
| 1205 | (setf (factor-l2p f-struct) | |
| 1206 | (cdr (factor-l2p f-struct))) | |
| 1207 | ;; found a factor | |
| 1208 | (return-from found t))) | |
| 1209 | (setf (factor-l2p f-struct) | |
| 1210 | (cdr (factor-l2p f-struct))))) | |
| 1211 | ;; | |
| 1212 | (setf (factor-l1p f-struct) (cdr (factor-l1p f-struct))) | |
| 1213 | (setf (factor-l2p f-struct) (factor-l1p f-struct))) | |
| 1214 | ;; failed | |
| 1215 | nil | |
| 1216 | )) | |
| 1217 | 1217 | ;; |
| 1218 | 1218 | (when factored |
| 1219 | 1219 | (let* ((lit2 (car (factor-l2p f-struct))) ; clause to be excluded |
| 1220 | (clause (factor-clause f-struct)) | |
| 1221 | ;;(new-vars-list (make-var-mapping (clause-variables clause))) | |
| 1222 | ) | |
| 1223 | (declare (type literal lit2) | |
| 1224 | (type clause clause)) | |
| 1225 | (setq a-factor | |
| 1226 | (cl-unique-variables | |
| 1227 | (copy-clause (make-clause-shallow-copy clause (list lit2)) | |
| 1228 | *current-psys* | |
| 1229 | #'(lambda (lit) | |
| 1230 | (declare (type literal lit)) | |
| 1231 | (let ((new-lit | |
| 1232 | (copy-literal lit | |
| 1233 | nil | |
| 1234 | ;; new-vars-list | |
| 1235 | nil | |
| 1236 | subst))) | |
| 1237 | (declare (type literal new-lit)) | |
| 1238 | (when (test-bit (literal-stat-bits lit) | |
| 1239 | oriented-eq-bit) | |
| 1240 | (set-bit (literal-stat-bits new-lit) | |
| 1241 | oriented-eq-bit)) | |
| 1242 | new-lit)) | |
| 1243 | ))) | |
| 1244 | )) | |
| 1220 | (clause (factor-clause f-struct)) | |
| 1221 | ;;(new-vars-list (make-var-mapping (clause-variables clause))) | |
| 1222 | ) | |
| 1223 | (declare (type literal lit2) | |
| 1224 | (type clause clause)) | |
| 1225 | (setq a-factor | |
| 1226 | (cl-unique-variables | |
| 1227 | (copy-clause (make-clause-shallow-copy clause (list lit2)) | |
| 1228 | *current-psys* | |
| 1229 | #'(lambda (lit) | |
| 1230 | (declare (type literal lit)) | |
| 1231 | (let ((new-lit | |
| 1232 | (copy-literal lit | |
| 1233 | nil | |
| 1234 | ;; new-vars-list | |
| 1235 | nil | |
| 1236 | subst))) | |
| 1237 | (declare (type literal new-lit)) | |
| 1238 | (when (test-bit (literal-stat-bits lit) | |
| 1239 | oriented-eq-bit) | |
| 1240 | (set-bit (literal-stat-bits new-lit) | |
| 1241 | oriented-eq-bit)) | |
| 1242 | new-lit)) | |
| 1243 | ))) | |
| 1244 | )) | |
| 1245 | 1245 | ;; |
| 1246 | 1246 | (when (pn-flag debug-infer) |
| 1247 | 1247 | (when a-factor |
| 1248 | (with-output-simple-msg () | |
| 1249 | (princ "*FACTOR: ") | |
| 1250 | (print-clause a-factor)))) | |
| 1248 | (with-output-simple-msg () | |
| 1249 | (princ "*FACTOR: ") | |
| 1250 | (print-clause a-factor)))) | |
| 1251 | 1251 | ;; |
| 1252 | 1252 | a-factor)) |
| 1253 | 1253 | |
| 1259 | 1259 | (let ((factors nil)) |
| 1260 | 1260 | (declare (type list factors)) |
| 1261 | 1261 | (do* ((lits (clause-literals clause) (cdr lits)) |
| 1262 | (lit1 (car lits) (car lits))) | |
| 1263 | ((null (cdr lits))) | |
| 1262 | (lit1 (car lits) (car lits))) | |
| 1263 | ((null (cdr lits))) | |
| 1264 | 1264 | (declare (type list lits) |
| 1265 | (type literal lit1)) | |
| 1265 | (type literal lit1)) | |
| 1266 | 1266 | (dolist (lit2 (cdr lits)) |
| 1267 | (declare (type literal lit2)) | |
| 1268 | (when (eq (literal-sign lit1) (literal-sign lit2)) | |
| 1269 | (multiple-value-bind (subst no-match e-eq) | |
| 1270 | (unify (literal-atom lit1) (literal-atom lit2)) | |
| 1271 | (declare (ignore e-eq) | |
| 1272 | (type list subst)) | |
| 1273 | (unless no-match | |
| 1274 | (let ((a-factor (make-clause-shallow-copy clause | |
| 1275 | (list lit2))) | |
| 1276 | ;; (new-vars-list (make-var-mapping (clause-variables clause))) | |
| 1277 | ) | |
| 1278 | (declare (type clause a-factor)) | |
| 1279 | (setq a-factor (copy-clause | |
| 1280 | a-factor | |
| 1281 | *current-psys* | |
| 1282 | #'(lambda (lit) | |
| 1283 | (let ((new-lit (copy-literal | |
| 1284 | lit | |
| 1285 | nil | |
| 1286 | nil | |
| 1287 | subst))) | |
| 1288 | (when (test-bit (literal-stat-bits lit) | |
| 1289 | oriented-eq-bit) | |
| 1290 | (set-bit (literal-stat-bits new-lit) | |
| 1291 | oriented-eq-bit)) | |
| 1292 | new-lit)) | |
| 1293 | )) | |
| 1294 | (push (cl-unique-variables a-factor) factors))))))) | |
| 1267 | (declare (type literal lit2)) | |
| 1268 | (when (eq (literal-sign lit1) (literal-sign lit2)) | |
| 1269 | (multiple-value-bind (subst no-match e-eq) | |
| 1270 | (unify (literal-atom lit1) (literal-atom lit2)) | |
| 1271 | (declare (ignore e-eq) | |
| 1272 | (type list subst)) | |
| 1273 | (unless no-match | |
| 1274 | (let ((a-factor (make-clause-shallow-copy clause | |
| 1275 | (list lit2))) | |
| 1276 | ;; (new-vars-list (make-var-mapping (clause-variables clause))) | |
| 1277 | ) | |
| 1278 | (declare (type clause a-factor)) | |
| 1279 | (setq a-factor (copy-clause | |
| 1280 | a-factor | |
| 1281 | *current-psys* | |
| 1282 | #'(lambda (lit) | |
| 1283 | (let ((new-lit (copy-literal | |
| 1284 | lit | |
| 1285 | nil | |
| 1286 | nil | |
| 1287 | subst))) | |
| 1288 | (when (test-bit (literal-stat-bits lit) | |
| 1289 | oriented-eq-bit) | |
| 1290 | (set-bit (literal-stat-bits new-lit) | |
| 1291 | oriented-eq-bit)) | |
| 1292 | new-lit)) | |
| 1293 | )) | |
| 1294 | (push (cl-unique-variables a-factor) factors))))))) | |
| 1295 | 1295 | (nreverse factors))) |
| 1296 | 1296 | |
| 1297 | 1297 | ;;; ALL-FACTORS |
| 1299 | 1299 | ;;; |
| 1300 | 1300 | (defun all-factors (clause list) |
| 1301 | 1301 | (declare (type clause clause) |
| 1302 | (type symbol list)) | |
| 1302 | (type symbol list)) | |
| 1303 | 1303 | (let ((factors (get-factors clause))) |
| 1304 | 1304 | (declare (type list factors)) |
| 1305 | 1305 | (dolist (a-factor factors) |
| 1306 | 1306 | (declare (type clause a-factor)) |
| 1307 | 1307 | (setf (clause-parents a-factor) |
| 1308 | (list (list :factor-rule (clause-id clause)))) | |
| 1308 | (list (list :factor-rule (clause-id clause)))) | |
| 1309 | 1309 | (incf (pn-stat cl-generated)) |
| 1310 | 1310 | (incf (pn-stat factor-gen)) |
| 1311 | 1311 | (pre-process a-factor nil list)) |
| 1316 | 1316 | |
| 1317 | 1317 | (defun factor-simplify (clause) |
| 1318 | 1318 | (declare (type clause clause) |
| 1319 | (values (or null fixnum))) | |
| 1319 | (values (or null fixnum))) | |
| 1320 | 1320 | (let ((f-struct (make-factor :clause clause |
| 1321 | :l1p (clause-literals clause) | |
| 1322 | :l2p (clause-literals clause))) | |
| 1323 | (num 0) | |
| 1324 | (a-factor nil) | |
| 1325 | ) | |
| 1321 | :l1p (clause-literals clause) | |
| 1322 | :l2p (clause-literals clause))) | |
| 1323 | (num 0) | |
| 1324 | (a-factor nil) | |
| 1325 | ) | |
| 1326 | 1326 | (declare (type fixnum num) |
| 1327 | (type factor f-struct) | |
| 1328 | (type (or null clause) a-factor)) | |
| 1327 | (type factor f-struct) | |
| 1328 | (type (or null clause) a-factor)) | |
| 1329 | 1329 | (setq a-factor (next-factor f-struct)) |
| 1330 | 1330 | (loop (unless a-factor (return)) |
| 1331 | 1331 | (if (subsume? a-factor clause) |
| 1332 | (let ((f-lits (clause-literals a-factor)) | |
| 1333 | (c-lits (clause-literals clause))) | |
| 1334 | (declare (type list f-lits c-lits)) | |
| 1335 | (incf num) | |
| 1336 | ;; swap literals | |
| 1337 | (setf (clause-literals a-factor) c-lits) | |
| 1338 | (setf (clause-literals clause) f-lits) | |
| 1339 | (dolist (l (clause-literals a-factor)) | |
| 1340 | (setf (literal-clause l) a-factor)) | |
| 1341 | (dolist (l (clause-literals clause)) | |
| 1342 | (setf (literal-clause l) clause)) | |
| 1343 | #|| | |
| 1344 | (setf (clause-parents clause) | |
| 1345 | (nconc (clause-parents clause) | |
| 1346 | (list (list :factor-simp-rule (clause-id a-factor))))) | |
| 1347 | ||# | |
| 1348 | (setf (clause-parents clause) | |
| 1349 | (nconc (clause-parents clause) | |
| 1350 | (list (list :factor-simp-rule)))) | |
| 1351 | ;; | |
| 1352 | (delete-clause a-factor *current-psys*) | |
| 1353 | ;; | |
| 1354 | (setf (factor-l1p f-struct) (clause-literals clause) | |
| 1355 | (factor-l2p f-struct) (clause-literals clause)) | |
| 1356 | (setq a-factor (next-factor f-struct)) | |
| 1357 | ) | |
| 1358 | ;; cl_del_non(factor) | |
| 1359 | (progn | |
| 1360 | (delete-clause a-factor *current-psys*) | |
| 1361 | (setq a-factor (next-factor f-struct))) | |
| 1362 | )) | |
| 1332 | (let ((f-lits (clause-literals a-factor)) | |
| 1333 | (c-lits (clause-literals clause))) | |
| 1334 | (declare (type list f-lits c-lits)) | |
| 1335 | (incf num) | |
| 1336 | ;; swap literals | |
| 1337 | (setf (clause-literals a-factor) c-lits) | |
| 1338 | (setf (clause-literals clause) f-lits) | |
| 1339 | (dolist (l (clause-literals a-factor)) | |
| 1340 | (setf (literal-clause l) a-factor)) | |
| 1341 | (dolist (l (clause-literals clause)) | |
| 1342 | (setf (literal-clause l) clause)) | |
| 1343 | #|| | |
| 1344 | (setf (clause-parents clause) | |
| 1345 | (nconc (clause-parents clause) | |
| 1346 | (list (list :factor-simp-rule (clause-id a-factor))))) | |
| 1347 | ||# | |
| 1348 | (setf (clause-parents clause) | |
| 1349 | (nconc (clause-parents clause) | |
| 1350 | (list (list :factor-simp-rule)))) | |
| 1351 | ;; | |
| 1352 | (delete-clause a-factor *current-psys*) | |
| 1353 | ;; | |
| 1354 | (setf (factor-l1p f-struct) (clause-literals clause) | |
| 1355 | (factor-l2p f-struct) (clause-literals clause)) | |
| 1356 | (setq a-factor (next-factor f-struct)) | |
| 1357 | ) | |
| 1358 | ;; cl_del_non(factor) | |
| 1359 | (progn | |
| 1360 | (delete-clause a-factor *current-psys*) | |
| 1361 | (setq a-factor (next-factor f-struct))) | |
| 1362 | )) | |
| 1363 | 1363 | ;; |
| 1364 | 1364 | num )) |
| 1365 | 1365 | |
| 0 | 0 | ;;;-*-Mode:LISP; Package: CHAOS; Base:10; Syntax:Common-lisp -*- |
| 1 | 1 | ;;; |
| 2 | ;;; Copyright (c) 2000-2014, Toshimi Sawada. All rights reserved. | |
| 2 | ;;; Copyright (c) 2000-2015, Toshimi Sawada. All rights reserved. | |
| 3 | 3 | ;;; |
| 4 | 4 | ;;; Redistribution and use in source and binary forms, with or without |
| 5 | 5 | ;;; modification, are permitted provided that the following conditions |
| 28 | 28 | ;;; |
| 29 | 29 | (in-package :chaos) |
| 30 | 30 | #|============================================================================= |
| 31 | System:Chaos | |
| 32 | Module:BigPink | |
| 33 | File:sigmatch.lisp | |
| 31 | System:Chaos | |
| 32 | Module:BigPink | |
| 33 | File:sigmatch.lisp | |
| 34 | 34 | =============================================================================|# |
| 35 | 35 | #-:chaos-debug |
| 36 | 36 | (declaim (optimize (speed 3) (safety 0) #-GCL (debug 0))) |
| 38 | 38 | (declaim (optimize (speed 1) (safety 3) #-GCL (debug 3))) |
| 39 | 39 | |
| 40 | 40 | ;;; |
| 41 | ;;; SIGNATURE MATCHER | |
| 41 | ;;; SIGNATURE MATCHER | |
| 42 | 42 | ;;; NOTE: This matcher is NOT generic one. It is specialized for |
| 43 | 43 | ;;; matching between behavioural specs: |
| 44 | 44 | ;;; assumes that data types (visible sorts) are fixed |
| 68 | 68 | |
| 69 | 69 | (defun sigmatch-set-all-ops (sst) |
| 70 | 70 | (declare (type sigmatch-set sst) |
| 71 | (values list)) | |
| 71 | (values list)) | |
| 72 | 72 | (let ((ops nil)) |
| 73 | 73 | (dolist (m (sigmatch-set-methods sst)) |
| 74 | 74 | (push m ops)) |
| 82 | 82 | |
| 83 | 83 | (defun create-sigmatch-set (module) |
| 84 | 84 | (declare (type module module) |
| 85 | (values list)) | |
| 85 | (values list)) | |
| 86 | 86 | (with-in-module (module) |
| 87 | 87 | (let ((sorts (module-all-sorts module)) |
| 88 | (attributes (module-beh-attributes module)) | |
| 89 | (hidden-objects nil)) | |
| 88 | (attributes (module-beh-attributes module)) | |
| 89 | (hidden-objects nil)) | |
| 90 | 90 | (declare (type list sorts attributes hidden-objects)) |
| 91 | 91 | (dolist (s sorts) |
| 92 | (declare (type sort* s)) | |
| 93 | (when (and (sort-is-hidden s) | |
| 94 | (not (or (sort= s *huniversal-sort*) | |
| 95 | (sort= s *hbottom-sort*)))) | |
| 96 | (push (make-sigmatch-set :sort s :module module) | |
| 97 | hidden-objects))) | |
| 92 | (declare (type sort* s)) | |
| 93 | (when (and (sort-is-hidden s) | |
| 94 | (not (or (sort= s *huniversal-sort*) | |
| 95 | (sort= s *hbottom-sort*)))) | |
| 96 | (push (make-sigmatch-set :sort s :module module) | |
| 97 | hidden-objects))) | |
| 98 | 98 | ;; |
| 99 | 99 | (dolist (ho hidden-objects) |
| 100 | (let* ((hsort (sigmatch-set-sort ho)) | |
| 101 | (ms (get-all-methods-of-sort hsort module))) | |
| 102 | (declare (type sort* hsort) | |
| 103 | (type list ms)) | |
| 104 | (dolist (m ms) | |
| 105 | (declare (type method m)) | |
| 106 | (if (method-is-behavioural m) | |
| 107 | (push m (sigmatch-set-methods ho)) | |
| 108 | (if (and (method-arity m) | |
| 109 | (memq hsort (method-arity m))) | |
| 110 | (push m (sigmatch-set-ops ho)) | |
| 111 | (push m (sigmatch-set-consts ho))))) | |
| 112 | (dolist (atr attributes) | |
| 113 | (declare (type method atr)) | |
| 114 | (when (memq hsort (method-arity atr)) | |
| 115 | (push atr (sigmatch-set-attributes ho)))) | |
| 116 | )) | |
| 100 | (let* ((hsort (sigmatch-set-sort ho)) | |
| 101 | (ms (get-all-methods-of-sort hsort module))) | |
| 102 | (declare (type sort* hsort) | |
| 103 | (type list ms)) | |
| 104 | (dolist (m ms) | |
| 105 | (declare (type method m)) | |
| 106 | (if (method-is-behavioural m) | |
| 107 | (push m (sigmatch-set-methods ho)) | |
| 108 | (if (and (method-arity m) | |
| 109 | (memq hsort (method-arity m))) | |
| 110 | (push m (sigmatch-set-ops ho)) | |
| 111 | (push m (sigmatch-set-consts ho))))) | |
| 112 | (dolist (atr attributes) | |
| 113 | (declare (type method atr)) | |
| 114 | (when (memq hsort (method-arity atr)) | |
| 115 | (push atr (sigmatch-set-attributes ho)))) | |
| 116 | )) | |
| 117 | 117 | ;; |
| 118 | 118 | hidden-objects |
| 119 | 119 | ))) |
| 121 | 121 | (defun sigmatch (mod1 mod2) |
| 122 | 122 | (declare (type module mod1 mod2)) |
| 123 | 123 | (let* ((ss1 (create-sigmatch-set mod1)) |
| 124 | (ss2 (create-sigmatch-set mod2)) | |
| 125 | ;; (oal nil) | |
| 126 | (views nil)) | |
| 124 | (ss2 (create-sigmatch-set mod2)) | |
| 125 | ;; (oal nil) | |
| 126 | (views nil)) | |
| 127 | 127 | (dolist (s1 ss1) |
| 128 | 128 | (declare (type sigmatch-set s1)) |
| 129 | 129 | (dolist (s2 ss2) |
| 130 | (declare (type sigmatch-set s2)) | |
| 131 | (block next | |
| 132 | (catch 'fail | |
| 133 | (let ((sal (list (cons (sigmatch-set-sort s1) | |
| 134 | (sigmatch-set-sort s2)))) | |
| 135 | (sop1 (sigmatch-set-all-ops s1)) | |
| 136 | (sop2 (sigmatch-set-all-ops s2)) | |
| 137 | (omap nil) | |
| 138 | (ov nil)) | |
| 139 | ;; (declare (type list sal sop1 sop2 omap ov)) | |
| 140 | (when (setq omap (sigmatch-op sop1 sop2 sal)) | |
| 141 | (dolist (om omap) | |
| 142 | (when (setq ov (generate-sigmatch-view mod1 mod2 sal om)) | |
| 143 | (push ov views)))))) | |
| 144 | ))) | |
| 130 | (declare (type sigmatch-set s2)) | |
| 131 | (block next | |
| 132 | (catch 'fail | |
| 133 | (let ((sal (list (cons (sigmatch-set-sort s1) | |
| 134 | (sigmatch-set-sort s2)))) | |
| 135 | (sop1 (sigmatch-set-all-ops s1)) | |
| 136 | (sop2 (sigmatch-set-all-ops s2)) | |
| 137 | (omap nil) | |
| 138 | (ov nil)) | |
| 139 | ;; (declare (type list sal sop1 sop2 omap ov)) | |
| 140 | (when (setq omap (sigmatch-op sop1 sop2 sal)) | |
| 141 | (dolist (om omap) | |
| 142 | (when (setq ov (generate-sigmatch-view mod1 mod2 sal om)) | |
| 143 | (push ov views)))))) | |
| 144 | ))) | |
| 145 | 145 | views)) |
| 146 | 146 | |
| 147 | 147 | (defun sigmatch-op (ms1 ms2 sal) |
| 148 | 148 | (flet ((sort-arity (arity) |
| 149 | (sort arity | |
| 150 | #'(lambda (x y) | |
| 151 | (string< (string (sort-name x)) | |
| 152 | (string (sort-name y)))))) | |
| 153 | (sort-list-equal (sl1 sl2) | |
| 154 | (or (equal sl1 sl2) | |
| 155 | (do ((sl-1 sl1 (cdr sl-1)) | |
| 156 | (sl-2 sl2 (cdr sl-2))) | |
| 157 | ((or (null sl-1) (null sl-2)) | |
| 158 | (and (null sl-1) (null sl-2))) | |
| 159 | (unless (eq (sort-name (car sl-1)) | |
| 160 | (sort-name (car sl-2))) | |
| 161 | (return-from sort-list-equal nil))) | |
| 162 | )) | |
| 163 | (sort-equal (s1 s2) | |
| 164 | (or (eq s1 s2) (eq (sort-name s1) (sort-name s2)))) | |
| 165 | ) | |
| 149 | (sort arity | |
| 150 | #'(lambda (x y) | |
| 151 | (string< (string (sort-name x)) | |
| 152 | (string (sort-name y)))))) | |
| 153 | (sort-list-equal (sl1 sl2) | |
| 154 | (or (equal sl1 sl2) | |
| 155 | (do ((sl-1 sl1 (cdr sl-1)) | |
| 156 | (sl-2 sl2 (cdr sl-2))) | |
| 157 | ((or (null sl-1) (null sl-2)) | |
| 158 | (and (null sl-1) (null sl-2))) | |
| 159 | (unless (eq (sort-name (car sl-1)) | |
| 160 | (sort-name (car sl-2))) | |
| 161 | (return-from sort-list-equal nil))) | |
| 162 | )) | |
| 163 | (sort-equal (s1 s2) | |
| 164 | (or (eq s1 s2) (eq (sort-name s1) (sort-name s2)))) | |
| 165 | ) | |
| 166 | 166 | ;; |
| 167 | 167 | (let ((rm nil) |
| 168 | (om nil)) | |
| 168 | (om nil)) | |
| 169 | 169 | (dolist (m1 ms1) |
| 170 | 170 | (let ((found nil)) |
| 171 | (dolist (m2 ms2) | |
| 172 | (let ((mp nil)) | |
| 173 | (setq mp (cons m1 m2)) | |
| 174 | (unless (member mp rm :test #'equal) | |
| 175 | (let ((ar1 nil) | |
| 176 | (ar2 (sort-arity (copy-list (method-arity m2)))) | |
| 177 | (co1 (or (cdr (assq (method-coarity m1) sal)) | |
| 178 | (method-coarity m1))) | |
| 179 | (co2 (method-coarity m2)) | |
| 180 | ) | |
| 181 | (dolist (s (method-arity m1)) | |
| 182 | (push (or (cdr (assq s sal)) s) | |
| 183 | ar1)) | |
| 184 | (setq ar1 (sort-arity ar1)) | |
| 185 | #|| | |
| 186 | (with-output-msg () | |
| 187 | (print-chaos-object mp) | |
| 188 | (format t "~% ar1 = ~s" ar1) | |
| 189 | (format t "~% ar2 = ~s" ar2) | |
| 190 | (format t "~% co1 = ~s" co1) | |
| 191 | (format t "~% co2 = ~s" co2)) | |
| 192 | ||# | |
| 193 | (when (and (sort-list-equal ar1 ar2) | |
| 194 | (sort-equal co1 co2)) | |
| 195 | (setq found t) | |
| 196 | (push mp rm) | |
| 197 | (push mp om) | |
| 198 | (return nil)))))) | |
| 199 | ;; | |
| 200 | (unless found (throw 'fail :not-found)) | |
| 201 | )) | |
| 171 | (dolist (m2 ms2) | |
| 172 | (let ((mp nil)) | |
| 173 | (setq mp (cons m1 m2)) | |
| 174 | (unless (member mp rm :test #'equal) | |
| 175 | (let ((ar1 nil) | |
| 176 | (ar2 (sort-arity (copy-list (method-arity m2)))) | |
| 177 | (co1 (or (cdr (assq (method-coarity m1) sal)) | |
| 178 | (method-coarity m1))) | |
| 179 | (co2 (method-coarity m2)) | |
| 180 | ) | |
| 181 | (dolist (s (method-arity m1)) | |
| 182 | (push (or (cdr (assq s sal)) s) | |
| 183 | ar1)) | |
| 184 | (setq ar1 (sort-arity ar1)) | |
| 185 | #|| | |
| 186 | (with-output-msg () | |
| 187 | (print-chaos-object mp) | |
| 188 | (format t "~% ar1 = ~s" ar1) | |
| 189 | (format t "~% ar2 = ~s" ar2) | |
| 190 | (format t "~% co1 = ~s" co1) | |
| 191 | (format t "~% co2 = ~s" co2)) | |
| 192 | ||# | |
| 193 | (when (and (sort-list-equal ar1 ar2) | |
| 194 | (sort-equal co1 co2)) | |
| 195 | (setq found t) | |
| 196 | (push mp rm) | |
| 197 | (push mp om) | |
| 198 | (return nil)))))) | |
| 199 | ;; | |
| 200 | (unless found (throw 'fail :not-found)) | |
| 201 | )) | |
| 202 | 202 | (list om)))) |
| 203 | 203 | |
| 204 | 204 | (defun make-sigmatch-op-pat (meth mod &optional vm sal) |
| 205 | 205 | (flet ((find-match-var (sort) |
| 206 | (find-if #'(lambda (x) | |
| 207 | (let ((tsort (or (car (rassoc sort sal)) | |
| 208 | sort))) | |
| 209 | (eq (sort-name tsort) (sort-name (variable-sort x))))) | |
| 210 | vm)) | |
| 211 | ) | |
| 206 | (find-if #'(lambda (x) | |
| 207 | (let ((tsort (or (car (rassoc sort sal)) | |
| 208 | sort))) | |
| 209 | (eq (sort-name tsort) (sort-name (variable-sort x))))) | |
| 210 | vm)) | |
| 211 | ) | |
| 212 | 212 | (with-in-module (mod) |
| 213 | 213 | (let ((vars nil)) |
| 214 | (setq vars (mapcar #'(lambda (x) | |
| 215 | (let ((var (find-match-var x)) | |
| 216 | (vn nil)) | |
| 217 | (if var | |
| 218 | (if (sort= (variable-sort var) | |
| 219 | x) | |
| 220 | var | |
| 221 | (make-variable-term x | |
| 222 | (variable-name var) | |
| 223 | (variable-name var))) | |
| 224 | (progn | |
| 225 | (setq vn (gensym "_sm")) | |
| 226 | (make-variable-term x | |
| 227 | vn | |
| 228 | vn))))) | |
| 229 | (method-arity meth))) | |
| 214 | (setq vars (mapcar #'(lambda (x) | |
| 215 | (let ((var (find-match-var x)) | |
| 216 | (vn nil)) | |
| 217 | (if var | |
| 218 | (if (sort= (variable-sort var) | |
| 219 | x) | |
| 220 | var | |
| 221 | (make-variable-term x | |
| 222 | (variable-name var) | |
| 223 | (variable-name var))) | |
| 224 | (progn | |
| 225 | (setq vn (gensym "_sm")) | |
| 226 | (make-variable-term x | |
| 227 | vn | |
| 228 | vn))))) | |
| 229 | (method-arity meth))) | |
| 230 | 230 | (make-term-with-sort-check meth vars))))) |
| 231 | 231 | |
| 232 | 232 | (defun generate-sigmatch-view (mod1 mod2 sal oal) |
| 233 | 233 | (let ((smap nil) |
| 234 | (omap nil) | |
| 235 | (bomap nil) | |
| 236 | (map nil) | |
| 237 | (view nil)) | |
| 234 | (omap nil) | |
| 235 | (bomap nil) | |
| 236 | (map nil) | |
| 237 | (view nil)) | |
| 238 | 238 | (dolist (sm sal) |
| 239 | 239 | (push (list (sort-name (car sm)) (sort-name (cdr sm))) |
| 240 | smap)) | |
| 240 | smap)) | |
| 241 | 241 | (dolist (om oal) |
| 242 | 242 | (let ((m1 nil) |
| 243 | (vm1 nil) | |
| 244 | (m2 nil)) | |
| 245 | (setq m1 (make-sigmatch-op-pat (car om) mod1)) | |
| 246 | (setq vm1 (term-variables m1)) | |
| 247 | (setq m2 (make-sigmatch-op-pat (cdr om) mod2 vm1 sal)) | |
| 248 | #|| | |
| 249 | (setq m1 (method-symbol (car om))) | |
| 250 | (setq m2 (method-symbol (cdr om))) | |
| 251 | ||# | |
| 252 | (if (method-is-behavioural (car om)) | |
| 253 | (push (list m1 m2) bomap) | |
| 254 | (push (list m1 m2) omap)))) | |
| 243 | (vm1 nil) | |
| 244 | (m2 nil)) | |
| 245 | (setq m1 (make-sigmatch-op-pat (car om) mod1)) | |
| 246 | (setq vm1 (term-variables m1)) | |
| 247 | (setq m2 (make-sigmatch-op-pat (cdr om) mod2 vm1 sal)) | |
| 248 | #|| | |
| 249 | (setq m1 (method-symbol (car om))) | |
| 250 | (setq m2 (method-symbol (cdr om))) | |
| 251 | ||# | |
| 252 | (if (method-is-behavioural (car om)) | |
| 253 | (push (list m1 m2) bomap) | |
| 254 | (push (list m1 m2) omap)))) | |
| 255 | 255 | (when smap |
| 256 | 256 | (push (list '%ren-hsort smap) map)) |
| 257 | 257 | (when bomap |
| 0 | 0 | ;;;-*-Mode:LISP; Package: CHAOS; Base:10; Syntax:Common-lisp -*- |
| 1 | 1 | ;;; |
| 2 | ;;; Copyright (c) 2000-2014, Toshimi Sawada. All rights reserved. | |
| 2 | ;;; Copyright (c) 2000-2015, Toshimi Sawada. All rights reserved. | |
| 3 | 3 | ;;; |
| 4 | 4 | ;;; Redistribution and use in source and binary forms, with or without |
| 5 | 5 | ;;; modification, are permitted provided that the following conditions |
| 28 | 28 | ;;; |
| 29 | 29 | (in-package :chaos) |
| 30 | 30 | #|============================================================================= |
| 31 | System:Chaos | |
| 32 | Module:BigPink | |
| 33 | File:syntax.lisp | |
| 31 | System:Chaos | |
| 32 | Module:BigPink | |
| 33 | File:syntax.lisp | |
| 34 | 34 | =============================================================================|# |
| 35 | 35 | #-:chaos-debug |
| 36 | 36 | (declaim (optimize (speed 3) (safety 0) #-GCL (debug 0))) |
| 41 | 41 | ;;; INSTALL-FOPL-SENTENCE |
| 42 | 42 | ;;; |
| 43 | 43 | (defun install-fopl-sentence (mod-name |
| 44 | &key (sentence-sort "FoplSentence") | |
| 45 | (vardecl-sort "VarDeclList") | |
| 46 | (var-decl-list '("_" "," "_")) | |
| 47 | (forall '("\\A" "[" "_" "]" "_")) | |
| 48 | (exists '("\\E" "[" "_" "]" "_")) | |
| 49 | (and '("_" "&" "_")) | |
| 50 | (or '("_" "|" "_")) | |
| 51 | (imply '("_" "->" "_")) | |
| 52 | (iff '("_" "<->" "_")) | |
| 53 | (not '("~" "_")) | |
| 54 | (eq nil) | |
| 55 | (beq nil)) | |
| 44 | &key (sentence-sort "FoplSentence") | |
| 45 | (vardecl-sort "VarDeclList") | |
| 46 | (var-decl-list '("_" "," "_")) | |
| 47 | (forall '("\\A" "[" "_" "]" "_")) | |
| 48 | (exists '("\\E" "[" "_" "]" "_")) | |
| 49 | (and '("_" "&" "_")) | |
| 50 | (or '("_" "|" "_")) | |
| 51 | (imply '("_" "->" "_")) | |
| 52 | (iff '("_" "<->" "_")) | |
| 53 | (not '("~" "_")) | |
| 54 | (eq nil) | |
| 55 | (beq nil)) | |
| 56 | 56 | (let ((fopl-sentence-module (eval-modexp mod-name))) |
| 57 | 57 | (cond ((and fopl-sentence-module (not (modexp-is-error fopl-sentence-module))) |
| 58 | (setq *fopl-sentence-module* fopl-sentence-module) | |
| 59 | (setf (module-type *fopl-sentence-module*) :system) | |
| 60 | ;; setup sorts | |
| 61 | (let ((fopl-sentence-sort | |
| 62 | (find-sort-in fopl-sentence-module sentence-sort)) | |
| 63 | (var-decl-list-sort | |
| 64 | (find-sort-in fopl-sentence-module vardecl-sort))) | |
| 65 | (if fopl-sentence-sort | |
| 66 | (setq *fopl-sentence-sort* fopl-sentence-sort) | |
| 67 | (with-output-panic-message () | |
| 68 | (princ "could not find sort FoplSentence"))) | |
| 69 | (if var-decl-list-sort | |
| 70 | (setq *var-decl-list-sort* var-decl-list-sort) | |
| 71 | (with-output-panic-message () | |
| 72 | (princ "could not find sort VarDeclList"))) | |
| 73 | ) | |
| 74 | ;; set up operators | |
| 75 | (let ((var-decl-list (find-method-in fopl-sentence-module | |
| 76 | var-decl-list | |
| 77 | (list *cosmos* | |
| 78 | *cosmos*) | |
| 79 | *var-decl-list-sort*)) | |
| 80 | (fopl-forall (find-method-in fopl-sentence-module | |
| 81 | forall | |
| 82 | (list *cosmos* | |
| 83 | *fopl-sentence-sort*) | |
| 84 | *fopl-sentence-sort*)) | |
| 85 | (fopl-exists (find-method-in fopl-sentence-module | |
| 86 | exists | |
| 87 | (list *cosmos* | |
| 88 | *fopl-sentence-sort*) | |
| 89 | *fopl-sentence-sort*)) | |
| 90 | (fopl-and (find-method-in fopl-sentence-module | |
| 91 | and | |
| 92 | (list *fopl-sentence-sort* | |
| 93 | *fopl-sentence-sort*) | |
| 94 | *fopl-sentence-sort*)) | |
| 95 | (fopl-or (find-method-in fopl-sentence-module | |
| 96 | or | |
| 97 | (list *fopl-sentence-sort* | |
| 98 | *fopl-sentence-sort*) | |
| 99 | *fopl-sentence-sort*)) | |
| 100 | (fopl-imply (find-method-in fopl-sentence-module | |
| 101 | imply | |
| 102 | (list *fopl-sentence-sort* | |
| 103 | *fopl-sentence-sort*) | |
| 104 | *fopl-sentence-sort*)) | |
| 105 | (fopl-iff (find-method-in fopl-sentence-module | |
| 106 | iff | |
| 107 | (list *fopl-sentence-sort* | |
| 108 | *fopl-sentence-sort*) | |
| 109 | *fopl-sentence-sort*)) | |
| 110 | (fopl-neg (find-method-in fopl-sentence-module | |
| 111 | not | |
| 112 | (list *fopl-sentence-sort*) | |
| 113 | *fopl-sentence-sort*)) | |
| 114 | (fopl-eq (if eq | |
| 115 | (find-method-in fopl-sentence-module | |
| 116 | eq | |
| 117 | (list *cosmos* | |
| 118 | *cosmos*) | |
| 119 | *fopl-sentence-sort*) | |
| 120 | :none)) | |
| 121 | (fopl-beq (if beq | |
| 122 | (find-method-in fopl-sentence-module | |
| 123 | beq | |
| 124 | (list *cosmos* | |
| 125 | *cosmos*) | |
| 126 | *fopl-sentence-sort*) | |
| 127 | :none)) | |
| 128 | ) | |
| 129 | ;; | |
| 130 | (if (eq fopl-beq :none) | |
| 131 | (setq *fopl-two-equalities* nil) | |
| 132 | (setq *fopl-two-equalities* t)) | |
| 133 | ;; | |
| 134 | (if (and var-decl-list fopl-forall fopl-exists fopl-and fopl-or | |
| 135 | fopl-imply fopl-iff fopl-neg fopl-eq fopl-beq) | |
| 136 | (setq *var-decl-list* var-decl-list | |
| 137 | *fopl-forall* fopl-forall | |
| 138 | *fopl-exists* fopl-exists | |
| 139 | *fopl-and* fopl-and | |
| 140 | *fopl-or* fopl-or | |
| 141 | *fopl-imply* fopl-imply | |
| 142 | *fopl-iff* fopl-iff | |
| 143 | *fopl-neg* fopl-neg | |
| 144 | *fopl-eq* (if (not (eq fopl-eq :none)) | |
| 145 | fopl-eq | |
| 146 | nil) | |
| 147 | *fopl-beq* (if (not (eq fopl-beq :none)) | |
| 148 | fopl-beq | |
| 149 | nil)) | |
| 150 | (with-output-panic-message () | |
| 151 | (princ "could not install some operators in FoplSentence")))) | |
| 152 | ) | |
| 153 | (t (with-output-panic-message () | |
| 154 | (princ "could not find FoplSentece module"))) | |
| 155 | ))) | |
| 58 | (setq *fopl-sentence-module* fopl-sentence-module) | |
| 59 | (setf (module-type *fopl-sentence-module*) :system) | |
| 60 | ;; setup sorts | |
| 61 | (let ((fopl-sentence-sort | |
| 62 | (find-sort-in fopl-sentence-module sentence-sort)) | |
| 63 | (var-decl-list-sort | |
| 64 | (find-sort-in fopl-sentence-module vardecl-sort))) | |
| 65 | (if fopl-sentence-sort | |
| 66 | (setq *fopl-sentence-sort* fopl-sentence-sort) | |
| 67 | (with-output-panic-message () | |
| 68 | (princ "could not find sort FoplSentence"))) | |
| 69 | (if var-decl-list-sort | |
| 70 | (setq *var-decl-list-sort* var-decl-list-sort) | |
| 71 | (with-output-panic-message () | |
| 72 | (princ "could not find sort VarDeclList"))) | |
| 73 | ) | |
| 74 | ;; set up operators | |
| 75 | (let ((var-decl-list (find-method-in fopl-sentence-module | |
| 76 | var-decl-list | |
| 77 | (list *cosmos* | |
| 78 | *cosmos*) | |
| 79 | *var-decl-list-sort*)) | |
| 80 | (fopl-forall (find-method-in fopl-sentence-module | |
| 81 | forall | |
| 82 | (list *cosmos* | |
| 83 | *fopl-sentence-sort*) | |
| 84 | *fopl-sentence-sort*)) | |
| 85 | (fopl-exists (find-method-in fopl-sentence-module | |
| 86 | exists | |
| 87 | (list *cosmos* | |
| 88 | *fopl-sentence-sort*) | |
| 89 | *fopl-sentence-sort*)) | |
| 90 | (fopl-and (find-method-in fopl-sentence-module | |
| 91 | and | |
| 92 | (list *fopl-sentence-sort* | |
| 93 | *fopl-sentence-sort*) | |
| 94 | *fopl-sentence-sort*)) | |
| 95 | (fopl-or (find-method-in fopl-sentence-module | |
| 96 | or | |
| 97 | (list *fopl-sentence-sort* | |
| 98 | *fopl-sentence-sort*) | |
| 99 | *fopl-sentence-sort*)) | |
| 100 | (fopl-imply (find-method-in fopl-sentence-module | |
| 101 | imply | |
| 102 | (list *fopl-sentence-sort* | |
| 103 | *fopl-sentence-sort*) | |
| 104 | *fopl-sentence-sort*)) | |
| 105 | (fopl-iff (find-method-in fopl-sentence-module | |
| 106 | iff | |
| 107 | (list *fopl-sentence-sort* | |
| 108 | *fopl-sentence-sort*) | |
| 109 | *fopl-sentence-sort*)) | |
| 110 | (fopl-neg (find-method-in fopl-sentence-module | |
| 111 | not | |
| 112 | (list *fopl-sentence-sort*) | |
| 113 | *fopl-sentence-sort*)) | |
| 114 | (fopl-eq (if eq | |
| 115 | (find-method-in fopl-sentence-module | |
| 116 | eq | |
| 117 | (list *cosmos* | |
| 118 | *cosmos*) | |
| 119 | *fopl-sentence-sort*) | |
| 120 | :none)) | |
| 121 | (fopl-beq (if beq | |
| 122 | (find-method-in fopl-sentence-module | |
| 123 | beq | |
| 124 | (list *cosmos* | |
| 125 | *cosmos*) | |
| 126 | *fopl-sentence-sort*) | |
| 127 | :none)) | |
| 128 | ) | |
| 129 | ;; | |
| 130 | (if (eq fopl-beq :none) | |
| 131 | (setq *fopl-two-equalities* nil) | |
| 132 | (setq *fopl-two-equalities* t)) | |
| 133 | ;; | |
| 134 | (if (and var-decl-list fopl-forall fopl-exists fopl-and fopl-or | |
| 135 | fopl-imply fopl-iff fopl-neg fopl-eq fopl-beq) | |
| 136 | (setq *var-decl-list* var-decl-list | |
| 137 | *fopl-forall* fopl-forall | |
| 138 | *fopl-exists* fopl-exists | |
| 139 | *fopl-and* fopl-and | |
| 140 | *fopl-or* fopl-or | |
| 141 | *fopl-imply* fopl-imply | |
| 142 | *fopl-iff* fopl-iff | |
| 143 | *fopl-neg* fopl-neg | |
| 144 | *fopl-eq* (if (not (eq fopl-eq :none)) | |
| 145 | fopl-eq | |
| 146 | nil) | |
| 147 | *fopl-beq* (if (not (eq fopl-beq :none)) | |
| 148 | fopl-beq | |
| 149 | nil)) | |
| 150 | (with-output-panic-message () | |
| 151 | (princ "could not install some operators in FoplSentence")))) | |
| 152 | ) | |
| 153 | (t (with-output-panic-message () | |
| 154 | (princ "could not find FoplSentece module"))) | |
| 155 | ))) | |
| 156 | 156 | |
| 157 | 157 | (defun install-fopl-clause () |
| 158 | 158 | (let ((fopl-clause-module (eval-modexp "FOPL-CLAUSE"))) |
| 159 | 159 | (let ((answer-method (find-method-in fopl-clause-module |
| 160 | '("$Ans") | |
| 161 | (list *cosmos*) | |
| 162 | *bool-sort*))) | |
| 160 | '("$Ans") | |
| 161 | (list *cosmos*) | |
| 162 | *bool-sort*))) | |
| 163 | 163 | (unless answer-method |
| 164 | (with-output-panic-message () | |
| 165 | (princ "could not install $Ans."))) | |
| 164 | (with-output-panic-message () | |
| 165 | (princ "could not install $Ans."))) | |
| 166 | 166 | (setq *fopl-ans* answer-method)))) |
| 167 | 167 | |
| 168 | 168 | ;;; NOT USED |
| 169 | 169 | (defun install-fopl-clause-form () |
| 170 | 170 | (let ((fopl-clause-form-module (eval-modexp "FOPL-CLAUSE-FORM"))) |
| 171 | 171 | (cond ((and fopl-clause-form-module |
| 172 | (not (modexp-is-error fopl-clause-form-module))) | |
| 173 | (setq *fopl-clause-form-module* fopl-clause-form-module) | |
| 174 | ;; setup sorts | |
| 175 | (let ((fopl-clause-sort (find-sort-in fopl-clause-form-module | |
| 176 | "FoplClause")) | |
| 177 | (fopl-sentence-seq-sort (find-sort-in fopl-clause-form-module | |
| 178 | "FoplSentenceSeq"))) | |
| 179 | (if (and fopl-clause-sort fopl-sentence-seq-sort) | |
| 180 | (setq *fopl-clause-sort* fopl-clause-sort | |
| 181 | *fopl-sentence-seq-sort* fopl-sentence-seq-sort) | |
| 182 | (with-output-panic-message () | |
| 183 | (princ "could not install some sorts of FOPL-CLAUSE-FORM")))) | |
| 184 | ;; setup operators | |
| 185 | (let ((clause-constructor (find-method-in fopl-clause-form-module | |
| 186 | '("[" "_" "]") | |
| 187 | (list *fopl-sentence-seq-sort*) | |
| 188 | *fopl-clause-sort*)) | |
| 189 | (clause-constructor2 (find-method-in | |
| 190 | fopl-clause-form-module | |
| 191 | '("!" "[" "_" "]") | |
| 192 | (list *fopl-sentence-seq-sort*) | |
| 193 | *fopl-clause-sort*)) | |
| 194 | (fopl-sentence-seq (find-method-in | |
| 195 | fopl-clause-form-module | |
| 196 | '("_" ";" "_") | |
| 197 | (list *fopl-sentence-seq-sort* | |
| 198 | *fopl-sentence-seq-sort*) | |
| 199 | *fopl-sentence-seq-sort*)) | |
| 200 | ) | |
| 201 | (if (and clause-constructor clause-constructor2 | |
| 202 | fopl-sentence-seq) | |
| 203 | (setq *clause-constructor* clause-constructor | |
| 204 | *clause-constructor2* clause-constructor2 | |
| 205 | *fopl-sentence-seq* fopl-sentence-seq) | |
| 206 | (with-output-panic-message () | |
| 207 | (princ "could not install some operators in FOPL-CLAUSE-FORM"))) | |
| 208 | )) | |
| 209 | (t (with-output-panic-message () | |
| 210 | (princ "could not find FOPL-CLAUSE-FORM"))) | |
| 211 | ))) | |
| 172 | (not (modexp-is-error fopl-clause-form-module))) | |
| 173 | (setq *fopl-clause-form-module* fopl-clause-form-module) | |
| 174 | ;; setup sorts | |
| 175 | (let ((fopl-clause-sort (find-sort-in fopl-clause-form-module | |
| 176 | "FoplClause")) | |
| 177 | (fopl-sentence-seq-sort (find-sort-in fopl-clause-form-module | |
| 178 | "FoplSentenceSeq"))) | |
| 179 | (if (and fopl-clause-sort fopl-sentence-seq-sort) | |
| 180 | (setq *fopl-clause-sort* fopl-clause-sort | |
| 181 | *fopl-sentence-seq-sort* fopl-sentence-seq-sort) | |
| 182 | (with-output-panic-message () | |
| 183 | (princ "could not install some sorts of FOPL-CLAUSE-FORM")))) | |
| 184 | ;; setup operators | |
| 185 | (let ((clause-constructor (find-method-in fopl-clause-form-module | |
| 186 | '("[" "_" "]") | |
| 187 | (list *fopl-sentence-seq-sort*) | |
| 188 | *fopl-clause-sort*)) | |
| 189 | (clause-constructor2 (find-method-in | |
| 190 | fopl-clause-form-module | |
| 191 | '("!" "[" "_" "]") | |
| 192 | (list *fopl-sentence-seq-sort*) | |
| 193 | *fopl-clause-sort*)) | |
| 194 | (fopl-sentence-seq (find-method-in | |
| 195 | fopl-clause-form-module | |
| 196 | '("_" ";" "_") | |
| 197 | (list *fopl-sentence-seq-sort* | |
| 198 | *fopl-sentence-seq-sort*) | |
| 199 | *fopl-sentence-seq-sort*)) | |
| 200 | ) | |
| 201 | (if (and clause-constructor clause-constructor2 | |
| 202 | fopl-sentence-seq) | |
| 203 | (setq *clause-constructor* clause-constructor | |
| 204 | *clause-constructor2* clause-constructor2 | |
| 205 | *fopl-sentence-seq* fopl-sentence-seq) | |
| 206 | (with-output-panic-message () | |
| 207 | (princ "could not install some operators in FOPL-CLAUSE-FORM"))) | |
| 208 | )) | |
| 209 | (t (with-output-panic-message () | |
| 210 | (princ "could not find FOPL-CLAUSE-FORM"))) | |
| 211 | ))) | |
| 212 | 212 | |
| 213 | 213 | ;;; *************** |
| 214 | 214 | ;;; PRIMITIVE UTILS |
| 215 | 215 | ;;; *************** |
| 216 | 216 | |
| 217 | #| | |
| 218 | (defun fopl-sentence-type (sentence) | |
| 219 | (cond ((term-is-variable? sentence) | |
| 220 | :atom) | |
| 221 | ((term-is-application-form? sentence) | |
| 222 | (let ((head (term-head sentence))) | |
| 223 | (cond ((method-is-of-same-operator head *fopl-forall*) | |
| 224 | :forall) | |
| 225 | ((method-is-of-same-operator head *fopl-exists*) | |
| 226 | :exists) | |
| 227 | ((method-is-of-same-operator head *fopl-and*) | |
| 228 | :and) | |
| 229 | ((method-is-of-same-operator head *fopl-or*) | |
| 230 | :or) | |
| 231 | ((method-is-of-same-operator head *fopl-imply*) | |
| 232 | :imply) | |
| 233 | ((method-is-of-same-operator head *fopl-iff*) | |
| 234 | :iff) | |
| 235 | ((method-is-of-same-operator head *fopl-neg*) | |
| 236 | :not) | |
| 237 | ((method-is-of-same-operator head *fopl-eq*) | |
| 238 | :eq) | |
| 239 | ((method-is-of-same-operator head *fopl-beq*) | |
| 240 | :beq) | |
| 241 | (t :atom)))) | |
| 242 | (t (with-output-panic-message () | |
| 243 | (princ "sentence-type accepted a illegual sentence") | |
| 244 | (print-chaos-object sentence))) | |
| 245 | )) | |
| 246 | |# | |
| 247 | ||
| 248 | #|| | |
| 249 | 217 | (defun fopl-sentence-type (sentence) |
| 250 | 218 | (declare (type term sentence) |
| 251 | (values symbol)) | |
| 252 | (cond ((term-is-variable? sentence) :atom) | |
| 253 | ((term-is-builtin-constant? sentence) :atom) | |
| 254 | ((term-is-lisp-form? sentence) :atom) | |
| 255 | ((term-is-application-form? sentence) | |
| 256 | (let ((head (term-head sentence))) | |
| 257 | (cond ((eq head *fopl-forall*) :forall) | |
| 258 | ((eq head *fopl-exists*) :exists) | |
| 259 | ((eq head *fopl-and*) :and) | |
| 260 | ((eq head *fopl-or*) :or) | |
| 261 | ((eq head *fopl-imply*) :imply) | |
| 262 | ((eq head *fopl-iff*) :iff) | |
| 263 | ((eq head *fopl-neg*) :not) | |
| 264 | ((eq head *fopl-eq*) :eq) | |
| 265 | ((eq head *fopl-beq*) :beq) | |
| 266 | (t :atom)))) | |
| 267 | (t (with-output-panic-message () | |
| 268 | (princ "sentence-type accepted a illegual sentence") | |
| 269 | (print-chaos-object sentence))) | |
| 270 | )) | |
| 271 | ||# | |
| 272 | ||
| 273 | (defun fopl-sentence-type (sentence) | |
| 274 | (declare (type term sentence) | |
| 275 | (values symbol)) | |
| 219 | (values symbol)) | |
| 276 | 220 | (cond ((term-is-application-form? sentence) |
| 277 | (let ((head (term-head sentence))) | |
| 278 | (cond ((eq head *fopl-forall*) :forall) | |
| 279 | ((eq head *fopl-exists*) :exists) | |
| 280 | ((eq head *fopl-and*) :and) | |
| 281 | ((eq head *fopl-or*) :or) | |
| 282 | ((eq head *fopl-imply*) :imply) | |
| 283 | ((eq head *fopl-iff*) :iff) | |
| 284 | ((eq head *fopl-neg*) :not) | |
| 285 | ((eq head *fopl-eq*) :eq) | |
| 286 | ((eq head *fopl-beq*) :beq) | |
| 287 | (t :atom)))) | |
| 288 | (t :atom) | |
| 289 | )) | |
| 221 | (let ((head (term-head sentence))) | |
| 222 | (cond ((eq head *fopl-forall*) :forall) | |
| 223 | ((eq head *fopl-exists*) :exists) | |
| 224 | ((eq head *fopl-and*) :and) | |
| 225 | ((eq head *fopl-or*) :or) | |
| 226 | ((eq head *fopl-imply*) :imply) | |
| 227 | ((eq head *fopl-iff*) :iff) | |
| 228 | ((eq head *fopl-neg*) :not) | |
| 229 | ((eq head *fopl-eq*) :eq) | |
| 230 | ((eq head *fopl-beq*) :beq) | |
| 231 | (t :atom)))) | |
| 232 | (t :atom) | |
| 233 | )) | |
| 290 | 234 | |
| 291 | 235 | (declaim (inline fopl-forall? |
| 292 | fopl-exists? | |
| 293 | fopl-and? | |
| 294 | fopl-or? | |
| 295 | fopl-imply? | |
| 296 | fopl-iff? | |
| 297 | fopl-not? | |
| 298 | fopl-eq? | |
| 299 | fopl-beq? | |
| 300 | )) | |
| 236 | fopl-exists? | |
| 237 | fopl-and? | |
| 238 | fopl-or? | |
| 239 | fopl-imply? | |
| 240 | fopl-iff? | |
| 241 | fopl-not? | |
| 242 | fopl-eq? | |
| 243 | fopl-beq? | |
| 244 | )) | |
| 301 | 245 | (defun fopl-forall? (f) |
| 302 | 246 | (declare (type term f)) |
| 303 | 247 | (and (term-is-application-form? f) |
| 339 | 283 | ;;; |
| 340 | 284 | (defun is-valid-formula? (term mod) |
| 341 | 285 | (declare (type term term) |
| 342 | (type (or null module) mod)) | |
| 286 | (type (or null module) mod)) | |
| 343 | 287 | (unless mod |
| 344 | 288 | (with-output-chaos-error ('internal) |
| 345 | 289 | (princ "is-valid-formua?: called with no context module given, this should not happen."))) |
| 346 | 290 | (is-in-same-connected-component (term-sort term) |
| 347 | *fopl-sentence-sort* | |
| 348 | (module-sort-order mod))) | |
| 291 | *fopl-sentence-sort* | |
| 292 | (module-sort-order mod))) | |
| 349 | 293 | |
| 350 | 294 | ;;; |
| 351 | 295 | ;;; CHECK-FOPL-SYNTAX |
| 353 | 297 | (defun check-fopl-syntax (fopl-sentence &optional report-error) |
| 354 | 298 | (declare (type term fopl-sentence)) |
| 355 | 299 | (if (and (term? fopl-sentence) |
| 356 | (is-valid-formula? fopl-sentence *current-module*)) | |
| 300 | (is-valid-formula? fopl-sentence *current-module*)) | |
| 357 | 301 | (check-fopl-syntax-aux fopl-sentence report-error) |
| 358 | 302 | (if report-error |
| 359 | (with-output-chaos-error ('invalid-sentence) | |
| 360 | (princ "encoutered with illegal sentence: ") | |
| 361 | (print-next) | |
| 362 | (print-chaos-object fopl-sentence)) | |
| 303 | (with-output-chaos-error ('invalid-sentence) | |
| 304 | (princ "encoutered with illegal sentence: ") | |
| 305 | (print-next) | |
| 306 | (print-chaos-object fopl-sentence)) | |
| 363 | 307 | nil))) |
| 364 | 308 | |
| 365 | 309 | (defun check-fopl-syntax-aux (fopl-sentence report-error) |
| 366 | 310 | (labels ((check-var-decl (var-decl) |
| 367 | (cond ((term-is-variable? var-decl) | |
| 368 | t) | |
| 369 | ((and (term-is-application-form? var-decl) | |
| 370 | (term-subterms var-decl)) | |
| 371 | (let ((top (term-head var-decl))) | |
| 372 | (or (and (method-is-of-same-operator top | |
| 373 | *var-decl-list*) | |
| 374 | (every #'(lambda (x) (check-var-decl x)) | |
| 375 | (term-subterms var-decl))) | |
| 376 | (if report-error | |
| 377 | (with-output-chaos-error ('invalid-formula) | |
| 378 | (princ "invaid formula: ") | |
| 379 | (print-chaos-object fopl-sentence)) | |
| 380 | nil)))) | |
| 381 | (t (if report-error | |
| 382 | (with-output-chaos-error ('invalid-formula) | |
| 383 | (princ "encounterd with illegal formula") | |
| 384 | (print-chaos-object fopl-sentence)) | |
| 385 | nil))))) | |
| 311 | (cond ((term-is-variable? var-decl) | |
| 312 | t) | |
| 313 | ((and (term-is-application-form? var-decl) | |
| 314 | (term-subterms var-decl)) | |
| 315 | (let ((top (term-head var-decl))) | |
| 316 | (or (and (method-is-of-same-operator top | |
| 317 | *var-decl-list*) | |
| 318 | (every #'(lambda (x) (check-var-decl x)) | |
| 319 | (term-subterms var-decl))) | |
| 320 | (if report-error | |
| 321 | (with-output-chaos-error ('invalid-formula) | |
| 322 | (princ "invaid formula: ") | |
| 323 | (print-chaos-object fopl-sentence)) | |
| 324 | nil)))) | |
| 325 | (t (if report-error | |
| 326 | (with-output-chaos-error ('invalid-formula) | |
| 327 | (princ "encounterd with illegal formula") | |
| 328 | (print-chaos-object fopl-sentence)) | |
| 329 | nil))))) | |
| 386 | 330 | ;; |
| 387 | 331 | (if (term-is-application-form? fopl-sentence) |
| 388 | (let ((type (fopl-sentence-type fopl-sentence))) | |
| 389 | (case type | |
| 390 | (:atom t) | |
| 391 | ((:forall :exists) | |
| 392 | (and (check-var-decl (term-arg-1 fopl-sentence)) | |
| 393 | (check-fopl-syntax-aux (term-arg-2 fopl-sentence) | |
| 394 | report-error))) | |
| 395 | (:not | |
| 396 | (check-fopl-syntax-aux (term-arg-1 fopl-sentence) | |
| 397 | report-error)) | |
| 398 | (otherwise | |
| 399 | (and (check-fopl-syntax-aux (term-arg-1 fopl-sentence) | |
| 400 | report-error) | |
| 401 | (check-fopl-syntax-aux (term-arg-2 fopl-sentence) | |
| 402 | report-error))))) | |
| 332 | (let ((type (fopl-sentence-type fopl-sentence))) | |
| 333 | (case type | |
| 334 | (:atom t) | |
| 335 | ((:forall :exists) | |
| 336 | (and (check-var-decl (term-arg-1 fopl-sentence)) | |
| 337 | (check-fopl-syntax-aux (term-arg-2 fopl-sentence) | |
| 338 | report-error))) | |
| 339 | (:not | |
| 340 | (check-fopl-syntax-aux (term-arg-1 fopl-sentence) | |
| 341 | report-error)) | |
| 342 | (otherwise | |
| 343 | (and (check-fopl-syntax-aux (term-arg-1 fopl-sentence) | |
| 344 | report-error) | |
| 345 | (check-fopl-syntax-aux (term-arg-2 fopl-sentence) | |
| 346 | report-error))))) | |
| 403 | 347 | t) |
| 404 | 348 | )) |
| 405 | 349 | |
| 0 | 0 | ;;;-*-Mode:LISP; Package: CHAOS; Base:10; Syntax:Common-lisp -*- |
| 1 | 1 | ;;; |
| 2 | ;;; Copyright (c) 2000-2014, Toshimi Sawada. All rights reserved. | |
| 2 | ;;; Copyright (c) 2000-2015, Toshimi Sawada. All rights reserved. | |
| 3 | 3 | ;;; |
| 4 | 4 | ;;; Redistribution and use in source and binary forms, with or without |
| 5 | 5 | ;;; modification, are permitted provided that the following conditions |
| 28 | 28 | ;;; |
| 29 | 29 | (in-package :chaos) |
| 30 | 30 | #|============================================================================= |
| 31 | System:Chaos | |
| 32 | Module:BigPink | |
| 33 | File:types.lisp | |
| 31 | System:Chaos | |
| 32 | Module:BigPink | |
| 33 | File:types.lisp | |
| 34 | 34 | =============================================================================|# |
| 35 | 35 | #-:chaos-debug |
| 36 | 36 | (declaim (optimize (speed 3) (safety 0) #-GCL (debug 0))) |
| 38 | 38 | (declaim (optimize (speed 1) (safety 3) #-GCL (debug 3))) |
| 39 | 39 | |
| 40 | 40 | ;;; ********************* |
| 41 | ;;; BASIC Data Structures | |
| 41 | ;;; BASIC Data Structures | |
| 42 | 42 | ;;; ********************* |
| 43 | 43 | |
| 44 | 44 | #-(or draft-ansi-cl-2 ansi-cl :clisp) |
| 61 | 61 | |
| 62 | 62 | (defun list->queue (list) |
| 63 | 63 | (cons list |
| 64 | (last list))) | |
| 64 | (last list))) | |
| 65 | 65 | |
| 66 | 66 | (defmacro queue-front-ptr (q) |
| 67 | 67 | `(car ,q)) |
| 86 | 86 | (defun queue-insert (q item) |
| 87 | 87 | (let ((new-pair (cons item nil))) |
| 88 | 88 | (cond ((empty-queue? q) |
| 89 | (queue-set-front-ptr q new-pair) | |
| 90 | (queue-set-rear-ptr q new-pair) | |
| 91 | q) | |
| 92 | (t | |
| 93 | (setf (cdr (queue-rear-ptr q)) new-pair) | |
| 94 | (queue-set-rear-ptr q new-pair) | |
| 95 | q)))) | |
| 89 | (queue-set-front-ptr q new-pair) | |
| 90 | (queue-set-rear-ptr q new-pair) | |
| 91 | q) | |
| 92 | (t | |
| 93 | (setf (cdr (queue-rear-ptr q)) new-pair) | |
| 94 | (queue-set-rear-ptr q new-pair) | |
| 95 | q)))) | |
| 96 | 96 | |
| 97 | 97 | (defun delete-queue (q) |
| 98 | 98 | (cond ((empty-queue? q) nil) |
| 99 | (t (queue-set-front-ptr q | |
| 100 | (cdr (queue-front-ptr q)))))) | |
| 99 | (t (queue-set-front-ptr q | |
| 100 | (cdr (queue-front-ptr q)))))) | |
| 101 | 101 | |
| 102 | 102 | ;;; ======= |
| 103 | 103 | ;;; LITERAL |
| 104 | 104 | ;;; ======= |
| 105 | 105 | (defstruct (literal (:print-function pr-literal) (:copier nil)) |
| 106 | (clause nil :type (or null clause)) ; containing clause | |
| 107 | (atom nil :type (or null term)) ; the body -- term | |
| 108 | (sign t :type symbol) ; nil if negation | |
| 109 | (type nil :type symbol) ; :pos-eq, :neg-eq, :evaluable | |
| 110 | ; :conditional-demod | |
| 111 | ; :normal-atom | |
| 112 | (stat-bits 0 :type fixnum) ; various bit flags | |
| 106 | (clause nil :type (or null clause)) ; containing clause | |
| 107 | (atom nil :type (or null term)) ; the body -- term | |
| 108 | (sign t :type symbol) ; nil if negation | |
| 109 | (type nil :type symbol) ; :pos-eq, :neg-eq, :evaluable | |
| 110 | ; :conditional-demod | |
| 111 | ; :normal-atom | |
| 112 | (stat-bits 0 :type fixnum) ; various bit flags | |
| 113 | 113 | ) |
| 114 | 114 | |
| 115 | 115 | ;;; STAT-BITS |
| 167 | 167 | (defmacro eq-literal? (literal) |
| 168 | 168 | (once-only (literal) |
| 169 | 169 | `(or (positive-eq-literal? ,literal) |
| 170 | (negative-eq-literal? ,literal)))) | |
| 170 | (negative-eq-literal? ,literal)))) | |
| 171 | 171 | |
| 172 | 172 | ;;; PROPOSITIONAL-LITERAL? |
| 173 | 173 | ;;; |
| 182 | 182 | #|| |
| 183 | 183 | (defun pr-literal (lit stream &rest ignore) |
| 184 | 184 | (declare (type literal lit) |
| 185 | (type stream stream) | |
| 186 | (ignore ignore)) | |
| 185 | (type stream stream) | |
| 186 | (ignore ignore)) | |
| 187 | 187 | (let ((.printed-vars-so-far. .printed-vars-so-far.)) |
| 188 | 188 | (unless (literal-sign lit) |
| 189 | 189 | (princ "~(" stream) |
| 190 | 190 | (setq .file-col. (1+ .file-col.))) |
| 191 | (with-in-module ((or *current-module* *last-module*)) | |
| 191 | (with-in-module ((get-context-module)) | |
| 192 | 192 | (cond ((eq-literal? lit) |
| 193 | (let* ((lhs (term-arg-1 (literal-atom lit))) | |
| 194 | (rhs (term-arg-2 (literal-atom lit))) | |
| 195 | (*print-indent* *print-indent*)) | |
| 196 | (setq *print-indent* (max *print-indent* | |
| 197 | .file-col.)) | |
| 198 | (setq .printed-vars-so-far. | |
| 199 | (append .printed-vars-so-far. | |
| 200 | (term-print lhs stream))) | |
| 201 | (setq .file-col. (file-column stream)) | |
| 202 | (princ " = ") | |
| 203 | #|| | |
| 204 | (if (print-check 0 30) ; 30? | |
| 205 | (princ "= ") | |
| 206 | (princ " = ")) | |
| 207 | ||# | |
| 208 | (setq *print-indent* | |
| 209 | (max *print-indent* | |
| 210 | (setq .file-col. (file-column stream)))) | |
| 211 | (setq .printed-vars-so-far. | |
| 212 | (append .printed-vars-so-far. | |
| 213 | (term-print rhs stream))) | |
| 214 | )) | |
| 215 | (t (setq .printed-vars-so-far. | |
| 216 | (append .printed-vars-so-far. | |
| 217 | (term-print (literal-atom lit) stream)))) | |
| 218 | ) | |
| 193 | (let* ((lhs (term-arg-1 (literal-atom lit))) | |
| 194 | (rhs (term-arg-2 (literal-atom lit))) | |
| 195 | (*print-indent* *print-indent*)) | |
| 196 | (setq *print-indent* (max *print-indent* | |
| 197 | .file-col.)) | |
| 198 | (setq .printed-vars-so-far. | |
| 199 | (append .printed-vars-so-far. | |
| 200 | (term-print lhs stream))) | |
| 201 | (setq .file-col. (file-column stream)) | |
| 202 | (princ " = ") | |
| 203 | #|| | |
| 204 | (if (print-check 0 30) ; 30? | |
| 205 | (princ "= ") | |
| 206 | (princ " = ")) | |
| 207 | ||# | |
| 208 | (setq *print-indent* | |
| 209 | (max *print-indent* | |
| 210 | (setq .file-col. (file-column stream)))) | |
| 211 | (setq .printed-vars-so-far. | |
| 212 | (append .printed-vars-so-far. | |
| 213 | (term-print rhs stream))) | |
| 214 | )) | |
| 215 | (t (setq .printed-vars-so-far. | |
| 216 | (append .printed-vars-so-far. | |
| 217 | (term-print (literal-atom lit) stream)))) | |
| 218 | ) | |
| 219 | 219 | ) |
| 220 | 220 | (unless (literal-sign lit) |
| 221 | 221 | (princ ")" stream)) |
| 225 | 225 | |
| 226 | 226 | (defun pr-literal (lit stream &rest ignore) |
| 227 | 227 | (declare (type literal lit) |
| 228 | (type stream stream) | |
| 229 | (ignore ignore)) | |
| 228 | (type stream stream) | |
| 229 | (ignore ignore)) | |
| 230 | 230 | (let ((.printed-vars-so-far. .printed-vars-so-far.)) |
| 231 | 231 | (unless (literal-sign lit) |
| 232 | 232 | (princ "~(" stream) |
| 233 | 233 | (setq .file-col. (1+ .file-col.))) |
| 234 | (with-in-module ((or *current-module* *last-module*)) | |
| 234 | (with-in-module ((get-context-module)) | |
| 235 | 235 | (setq .printed-vars-so-far. |
| 236 | (append .printed-vars-so-far. | |
| 237 | (term-print (literal-atom lit) stream)))) | |
| 236 | (append .printed-vars-so-far. | |
| 237 | (term-print (literal-atom lit) stream)))) | |
| 238 | 238 | (unless (literal-sign lit) |
| 239 | 239 | (princ ")" stream)) |
| 240 | .printed-vars-so-far.) | |
| 241 | ) | |
| 240 | .printed-vars-so-far.)) | |
| 242 | 241 | |
| 243 | 242 | ;;; |
| 244 | 243 | ;;; some gobal flags |
| 283 | 282 | ;;; ====== |
| 284 | 283 | |
| 285 | 284 | (defstruct (clause (:print-function print-clause) |
| 286 | ;; copier is defined in `clause.lisp' | |
| 287 | (:copier nil)) | |
| 288 | (parents nil :type list) ; parents produces this clause | |
| 289 | (literals nil :type list) ; list of literal | |
| 285 | ;; copier is defined in `clause.lisp' | |
| 286 | (:copier nil)) | |
| 287 | (parents nil :type list) ; parents produces this clause | |
| 288 | (literals nil :type list) ; list of literal | |
| 290 | 289 | (id -1 :type fixnum) |
| 291 | 290 | (pick-weight -1 :type fixnum) |
| 292 | 291 | (attributes nil :type list) |
| 293 | 292 | (type nil :type symbol) |
| 294 | 293 | (bits 0 :type fixnum) |
| 295 | 294 | (heat-level 0 :type fixnum) |
| 296 | (formula nil :type (or null term)) ; original formula | |
| 297 | (axiom nil :type (or null axiom)) ; derived axiom if any. | |
| 298 | (container nil :type symbol) ; containing list, one of | |
| 299 | ; :sos, :usable, :other... | |
| 295 | (formula nil :type (or null term)) ; original formula | |
| 296 | (axiom nil :type (or null axiom)) ; derived axiom if any. | |
| 297 | (container nil :type symbol) ; containing list, one of | |
| 298 | ; :sos, :usable, :other... | |
| 300 | 299 | ) |
| 301 | 300 | |
| 302 | 301 | ;;; GET-CLAUSE : id -> Clause |
| 336 | 335 | |
| 337 | 336 | (defun print-clause (cl &optional (stream *standard-output*) &rest ignore) |
| 338 | 337 | (declare (type clause cl) |
| 339 | (type stream stream) | |
| 340 | (ignore ignore)) | |
| 338 | (type stream stream) | |
| 339 | (ignore ignore)) | |
| 341 | 340 | (let ((*print-pretty* nil) |
| 342 | (.printed-vars-so-far. nil) | |
| 343 | (*print-xmode* :fancy) | |
| 344 | (*standard-output* stream) | |
| 345 | (fcol-1 0)) | |
| 341 | (.printed-vars-so-far. nil) | |
| 342 | (*print-xmode* :fancy) | |
| 343 | (*standard-output* stream) | |
| 344 | (fcol-1 0)) | |
| 346 | 345 | #|| |
| 347 | 346 | (when (symbolp cl) |
| 348 | 347 | (format stream "~a" cl) |
| 351 | 350 | (let ((flg nil)) |
| 352 | 351 | (declare (type symbol flg)) |
| 353 | 352 | (when (<= 0 (clause-id cl)) |
| 354 | (format stream "~d:" (clause-id cl))) | |
| 353 | (format stream "~d:" (clause-id cl))) | |
| 355 | 354 | (setq fcol-1 (file-column stream)) |
| 356 | 355 | ;; (when (< 0 (clause-heat-level cl)) |
| 357 | 356 | ;; (format t "(heat=~D) " (clause-heat-level cl))) |
| 358 | 357 | (princ "[" stream) |
| 359 | 358 | (dolist (ips (clause-parents cl)) |
| 360 | (declare (type list ips)) | |
| 361 | (dolist (ip ips) | |
| 362 | (declare (type (or symbol fixnum list) ip)) | |
| 363 | (if (eq flg :colon) | |
| 364 | (princ ":" stream) | |
| 365 | (if (eq flg :comma) | |
| 366 | (princ "," stream))) | |
| 367 | (cond ((symbolp ip) | |
| 368 | (setq flg :colon) | |
| 369 | (case ip | |
| 370 | (:binary-res-rule (princ "binary" stream)) | |
| 371 | (:pbinary-res-rule (princ "prop-res" stream)) | |
| 372 | (:hyper-res-rule (princ "hyper" stream)) | |
| 373 | (:neg-hyper-res-rule (princ "neg-hyper" stream)) | |
| 374 | (:ur-res-rule (princ "ur" stream)) | |
| 375 | (:para-into-rule (princ "para-into" stream)) | |
| 376 | (:para-from-rule (princ "para-from" stream)) | |
| 377 | (:factor-rule (princ "factor" stream)) | |
| 378 | ;; (:factor-simp-rule (princ "factor-simp" stream)) | |
| 379 | (:factor-simp-rule (princ "fsimp" stream)) | |
| 380 | (:distinct-constants (princ "dconst" stream)) | |
| 381 | (:new-demod-rule (princ "new-demod" stream)) | |
| 382 | (:back-demod-rule (princ "back-demod" stream)) | |
| 383 | (:demod-rule (princ "demod" stream)) | |
| 384 | (:unit-del-rule (princ "unit-del" stream)) | |
| 385 | (:eval-rule (princ "eval" stream)) | |
| 386 | (:copy-rule (princ "copy" stream)) | |
| 387 | (:flip-eq-rule (princ "flip" stream)) | |
| 388 | (:back-unit-del-rule (princ "back-unit-del" stream)) | |
| 389 | (otherwise (princ ip stream)))) | |
| 390 | ((atom ip) | |
| 391 | (setq flg :comma) | |
| 392 | (princ ip stream)) | |
| 393 | ;; list | |
| 394 | (t (setq flg :comma) | |
| 395 | (format stream "~a.~a" (car ip) (cdr ip))))))) | |
| 359 | (declare (type list ips)) | |
| 360 | (dolist (ip ips) | |
| 361 | (declare (type (or symbol fixnum list) ip)) | |
| 362 | (if (eq flg :colon) | |
| 363 | (princ ":" stream) | |
| 364 | (if (eq flg :comma) | |
| 365 | (princ "," stream))) | |
| 366 | (cond ((symbolp ip) | |
| 367 | (setq flg :colon) | |
| 368 | (case ip | |
| 369 | (:binary-res-rule (princ "binary" stream)) | |
| 370 | (:pbinary-res-rule (princ "prop-res" stream)) | |
| 371 | (:hyper-res-rule (princ "hyper" stream)) | |
| 372 | (:neg-hyper-res-rule (princ "neg-hyper" stream)) | |
| 373 | (:ur-res-rule (princ "ur" stream)) | |
| 374 | (:para-into-rule (princ "para-into" stream)) | |
| 375 | (:para-from-rule (princ "para-from" stream)) | |
| 376 | (:factor-rule (princ "factor" stream)) | |
| 377 | ;; (:factor-simp-rule (princ "factor-simp" stream)) | |
| 378 | (:factor-simp-rule (princ "fsimp" stream)) | |
| 379 | (:distinct-constants (princ "dconst" stream)) | |
| 380 | (:new-demod-rule (princ "new-demod" stream)) | |
| 381 | (:back-demod-rule (princ "back-demod" stream)) | |
| 382 | (:demod-rule (princ "demod" stream)) | |
| 383 | (:unit-del-rule (princ "unit-del" stream)) | |
| 384 | (:eval-rule (princ "eval" stream)) | |
| 385 | (:copy-rule (princ "copy" stream)) | |
| 386 | (:flip-eq-rule (princ "flip" stream)) | |
| 387 | (:back-unit-del-rule (princ "back-unit-del" stream)) | |
| 388 | (otherwise (princ ip stream)))) | |
| 389 | ((atom ip) | |
| 390 | (setq flg :comma) | |
| 391 | (princ ip stream)) | |
| 392 | ;; list | |
| 393 | (t (setq flg :comma) | |
| 394 | (format stream "~a.~a" (car ip) (cdr ip))))))) | |
| 396 | 395 | ;; |
| 397 | 396 | (princ "] " stream) |
| 398 | 397 | (let* ((.file-col. (file-column stream)) |
| 399 | (flg nil) | |
| 400 | (*print-indent* *print-indent*) | |
| 401 | (ind-check 0)) | |
| 398 | (flg nil) | |
| 399 | (*print-indent* *print-indent*) | |
| 400 | (ind-check 0)) | |
| 402 | 401 | (declare (type symbol flg)) |
| 403 | 402 | (setq *print-indent* fcol-1) |
| 404 | 403 | (if (print-check fcol-1 cl-print-mergine stream) |
| 405 | (setq ind-check fcol-1) | |
| 406 | (setq ind-check .file-col.)) | |
| 404 | (setq ind-check fcol-1) | |
| 405 | (setq ind-check .file-col.)) | |
| 407 | 406 | (setq *print-indent* ind-check) |
| 408 | 407 | (dolist (lit (clause-literals cl)) |
| 409 | (setq .file-col. (file-column stream)) | |
| 410 | (if flg | |
| 411 | (progn | |
| 412 | (princ " | " stream) | |
| 413 | (setq .file-col. (+ 3 .file-col.)) | |
| 414 | (if (print-check ind-check 20 stream) | |
| 415 | (setq .file-col. (file-column stream)) | |
| 416 | ) | |
| 417 | ) | |
| 418 | (setq flg t)) | |
| 419 | (setq .printed-vars-so-far. | |
| 420 | (append .printed-vars-so-far. | |
| 421 | (pr-literal lit stream)))) | |
| 408 | (setq .file-col. (file-column stream)) | |
| 409 | (if flg | |
| 410 | (progn | |
| 411 | (princ " | " stream) | |
| 412 | (setq .file-col. (+ 3 .file-col.)) | |
| 413 | (if (print-check ind-check 20 stream) | |
| 414 | (setq .file-col. (file-column stream)) | |
| 415 | ) | |
| 416 | ) | |
| 417 | (setq flg t)) | |
| 418 | (setq .printed-vars-so-far. | |
| 419 | (append .printed-vars-so-far. | |
| 420 | (pr-literal lit stream)))) | |
| 422 | 421 | ))) |
| 423 | 422 | |
| 424 | 423 | #|| |
| 425 | 424 | (defun print-clause (cl &optional (stream *standard-output*) &rest ignore) |
| 426 | 425 | (declare (type clause cl) |
| 427 | (type stream stream) | |
| 428 | (ignore ignore)) | |
| 426 | (type stream stream) | |
| 427 | (ignore ignore)) | |
| 429 | 428 | (let ((*print-pretty* nil) |
| 430 | (.printed-vars-so-far. nil) | |
| 431 | (*standard-output* stream) | |
| 432 | (fcol-1 0)) | |
| 429 | (.printed-vars-so-far. nil) | |
| 430 | (*standard-output* stream) | |
| 431 | (fcol-1 0)) | |
| 433 | 432 | (declare (special *print-pretty*)) |
| 434 | 433 | (let ((flg nil)) |
| 435 | 434 | (declare (type symbol flg)) |
| 439 | 438 | ;; (format t "(heat=~D) " (clause-heat-level cl))) |
| 440 | 439 | (princ "[" stream) |
| 441 | 440 | (dolist (ips (clause-parents cl)) |
| 442 | (declare (type list ips)) | |
| 443 | (dolist (ip ips) | |
| 444 | (declare (type (or symbol fixnum list) ip)) | |
| 445 | (if (eq flg :colon) | |
| 446 | (princ ":" stream) | |
| 447 | (if (eq flg :comma) | |
| 448 | (princ "," stream))) | |
| 449 | (cond ((symbolp ip) | |
| 450 | (setq flg :colon) | |
| 451 | (case ip | |
| 452 | (:binary-res-rule (princ "binary" stream)) | |
| 453 | (:pbinary-res-rule (princ "prop-res" stream)) | |
| 454 | (:hyper-res-rule (princ "hyper" stream)) | |
| 455 | (:neg-hyper-res-rule (princ "neg-hyper" stream)) | |
| 456 | (:ur-res-rule (princ "ur" stream)) | |
| 457 | (:para-into-rule (princ "para-into" stream)) | |
| 458 | (:para-from-rule (princ "para-from" stream)) | |
| 459 | (:factor-rule (princ "factor" stream)) | |
| 460 | ;; (:factor-simp-rule (princ "factor-simp" stream)) | |
| 461 | (:factor-simp-rule (princ "fsimp" stream)) | |
| 462 | (:distinct-constants (princ "dconst" stream)) | |
| 463 | (:new-demod-rule (princ "new-demod" stream)) | |
| 464 | (:back-demod-rule (princ "back-demod" stream)) | |
| 465 | (:demod-rule (princ "demod" stream)) | |
| 466 | (:unit-del-rule (princ "unit-del" stream)) | |
| 467 | (:eval-rule (princ "eval" stream)) | |
| 468 | (:copy-rule (princ "copy" stream)) | |
| 469 | (:flip-eq-rule (princ "flip" stream)) | |
| 470 | (:back-unit-del-rule (princ "back-unit-del" stream)) | |
| 471 | (otherwise (princ ip stream)))) | |
| 472 | ((atom ip) | |
| 473 | (setq flg :comma) | |
| 474 | (princ ip stream)) | |
| 475 | ;; list | |
| 476 | (t (setq flg :comma) | |
| 477 | (format stream "~a.~a" (car ip) (cdr ip))) | |
| 478 | )) | |
| 479 | )) | |
| 441 | (declare (type list ips)) | |
| 442 | (dolist (ip ips) | |
| 443 | (declare (type (or symbol fixnum list) ip)) | |
| 444 | (if (eq flg :colon) | |
| 445 | (princ ":" stream) | |
| 446 | (if (eq flg :comma) | |
| 447 | (princ "," stream))) | |
| 448 | (cond ((symbolp ip) | |
| 449 | (setq flg :colon) | |
| 450 | (case ip | |
| 451 | (:binary-res-rule (princ "binary" stream)) | |
| 452 | (:pbinary-res-rule (princ "prop-res" stream)) | |
| 453 | (:hyper-res-rule (princ "hyper" stream)) | |
| 454 | (:neg-hyper-res-rule (princ "neg-hyper" stream)) | |
| 455 | (:ur-res-rule (princ "ur" stream)) | |
| 456 | (:para-into-rule (princ "para-into" stream)) | |
| 457 | (:para-from-rule (princ "para-from" stream)) | |
| 458 | (:factor-rule (princ "factor" stream)) | |
| 459 | ;; (:factor-simp-rule (princ "factor-simp" stream)) | |
| 460 | (:factor-simp-rule (princ "fsimp" stream)) | |
| 461 | (:distinct-constants (princ "dconst" stream)) | |
| 462 | (:new-demod-rule (princ "new-demod" stream)) | |
| 463 | (:back-demod-rule (princ "back-demod" stream)) | |
| 464 | (:demod-rule (princ "demod" stream)) | |
| 465 | (:unit-del-rule (princ "unit-del" stream)) | |
| 466 | (:eval-rule (princ "eval" stream)) | |
| 467 | (:copy-rule (princ "copy" stream)) | |
| 468 | (:flip-eq-rule (princ "flip" stream)) | |
| 469 | (:back-unit-del-rule (princ "back-unit-del" stream)) | |
| 470 | (otherwise (princ ip stream)))) | |
| 471 | ((atom ip) | |
| 472 | (setq flg :comma) | |
| 473 | (princ ip stream)) | |
| 474 | ;; list | |
| 475 | (t (setq flg :comma) | |
| 476 | (format stream "~a.~a" (car ip) (cdr ip))) | |
| 477 | )) | |
| 478 | )) | |
| 480 | 479 | ;; |
| 481 | 480 | (princ "] " stream) |
| 482 | 481 | )) |
| 484 | 483 | |
| 485 | 484 | (defun pr-clause-list (cl &optional (detail nil)) |
| 486 | 485 | (declare (ignore detail) |
| 487 | (type list cl)) | |
| 486 | (type list cl)) | |
| 488 | 487 | (dolist (c cl) |
| 489 | 488 | (print-next) |
| 490 | 489 | (print-clause c) |
| 499 | 498 | ;;; |
| 500 | 499 | (defun literals-to-term (lit-list) |
| 501 | 500 | (declare (type list lit-list) |
| 502 | (values term)) | |
| 501 | (values term)) | |
| 503 | 502 | (if (null lit-list) |
| 504 | 503 | *bool-false* |
| 505 | 504 | (let ((res nil)) |
| 506 | 505 | (declare (type (or null term) res)) |
| 507 | 506 | (do* ((lits lit-list (cdr lits)) |
| 508 | (l (car lits) (car lits))) | |
| 509 | ((null lits)) | |
| 510 | (declare (type literal l)) | |
| 511 | (if (literal-sign l) | |
| 512 | (push (make-term-with-sort-check | |
| 513 | *fopl-neg* | |
| 514 | (list (literal-atom l))) | |
| 515 | res) | |
| 516 | (push (literal-atom l) res))) | |
| 507 | (l (car lits) (car lits))) | |
| 508 | ((null lits)) | |
| 509 | (declare (type literal l)) | |
| 510 | (if (literal-sign l) | |
| 511 | (push (make-term-with-sort-check | |
| 512 | *fopl-neg* | |
| 513 | (list (literal-atom l))) | |
| 514 | res) | |
| 515 | (push (literal-atom l) res))) | |
| 517 | 516 | (if (cdr res) |
| 518 | (setq res (make-right-assoc-normal-form-with-sort-check | |
| 519 | *fopl-or* | |
| 520 | (nreverse res))) | |
| 521 | (setq res (car res))) | |
| 517 | (setq res (make-right-assoc-normal-form-with-sort-check | |
| 518 | *fopl-or* | |
| 519 | (nreverse res))) | |
| 520 | (setq res (car res))) | |
| 522 | 521 | ;; |
| 523 | 522 | res))) |
| 524 | 523 | |
| 525 | 524 | (defun clause-to-term (cl) |
| 526 | 525 | (declare (type clause cl) |
| 527 | (values term)) | |
| 526 | (values term)) | |
| 528 | 527 | (literals-to-term (clause-literals cl))) |
| 529 | 528 | |
| 530 | 529 | ;;; LITERAL COPIER |
| 531 | 530 | ;;; |
| 532 | 531 | (defun copy-literal (lit &optional variables clause subst) |
| 533 | 532 | (declare (type literal lit) |
| 534 | (type list variables subst) | |
| 535 | (type (or null clause) clause) | |
| 536 | (values literal)) | |
| 533 | (type list variables subst) | |
| 534 | (type (or null clause) clause) | |
| 535 | (values literal)) | |
| 537 | 536 | (let ((atom (literal-atom lit))) |
| 538 | 537 | (declare (type term atom)) |
| 539 | 538 | (when subst |
| 540 | 539 | (setq atom (apply-subst subst atom))) |
| 541 | 540 | (make-literal :clause (if clause |
| 542 | clause | |
| 543 | (literal-clause lit)) | |
| 544 | :atom (if variables | |
| 545 | (copy-term-using-variable atom | |
| 546 | variables) | |
| 547 | (copy-term-reusing-variables atom | |
| 548 | (term-variables atom))) | |
| 549 | :sign (literal-sign lit) | |
| 550 | :type (literal-type lit))) | |
| 541 | clause | |
| 542 | (literal-clause lit)) | |
| 543 | :atom (if variables | |
| 544 | (copy-term-using-variable atom | |
| 545 | variables) | |
| 546 | (copy-term-reusing-variables atom | |
| 547 | (term-variables atom))) | |
| 548 | :sign (literal-sign lit) | |
| 549 | :type (literal-type lit))) | |
| 551 | 550 | ) |
| 552 | 551 | |
| 553 | 552 | (defun shallow-copy-literal (lit &optional clause) |
| 554 | 553 | (declare (type literal lit) |
| 555 | (type (or null clause) clause) | |
| 556 | (values literal)) | |
| 554 | (type (or null clause) clause) | |
| 555 | (values literal)) | |
| 557 | 556 | (make-literal :clause (if clause |
| 558 | clause | |
| 559 | (literal-clause lit)) | |
| 560 | :atom (literal-atom lit) | |
| 561 | :sign (literal-sign lit) | |
| 562 | :type (literal-type lit))) | |
| 557 | clause | |
| 558 | (literal-clause lit)) | |
| 559 | :atom (literal-atom lit) | |
| 560 | :sign (literal-sign lit) | |
| 561 | :type (literal-type lit))) | |
| 563 | 562 | |
| 564 | 563 | |
| 565 | 564 | ;;; CLAUSE-VARIABLES : Clause -> List[Variable] |
| 566 | 565 | ;;; |
| 567 | 566 | (defun clause-variables (clause) |
| 568 | 567 | (declare (type clause clause) |
| 569 | (values list)) | |
| 568 | (values list)) | |
| 570 | 569 | (let ((vars nil)) |
| 571 | 570 | (declare (type list vars)) |
| 572 | 571 | (dolist (lit (clause-literals clause)) |
| 573 | 572 | (declare (type literal lit)) |
| 574 | 573 | (setq vars (nunion vars (term-variables (literal-atom lit)) |
| 575 | :test #'!term-eq))) | |
| 574 | :test #'!term-eq))) | |
| 576 | 575 | vars)) |
| 577 | 576 | |
| 578 | 577 | ;;; CLAUSE-DISTINCT-VARIABLES (clause) |
| 580 | 579 | |
| 581 | 580 | (defun clause-distinct-variables (clause) |
| 582 | 581 | (declare (type clause clause) |
| 583 | (values fixnum)) | |
| 582 | (values fixnum)) | |
| 584 | 583 | (length (clause-variables clause))) |
| 585 | 584 | |
| 586 | 585 | ;;; GROUND-CLAUSE? : Clause -> Bool |
| 587 | 586 | ;;; |
| 588 | 587 | (declaim (inline ground-clause?)) |
| 589 | ||
| 588 | ||
| 590 | 589 | (defun ground-clause? (clause) |
| 591 | 590 | (declare (type clause clause)) |
| 592 | 591 | (null (clause-variables clause))) |
| 597 | 596 | |
| 598 | 597 | (defun num-literals (clause) |
| 599 | 598 | (declare (type clause clause) |
| 600 | (values fixnum)) | |
| 599 | (values fixnum)) | |
| 601 | 600 | (let ((num 0)) |
| 602 | 601 | (declare (type fixnum num)) |
| 603 | 602 | (dolist (lit (clause-literals clause)) |
| 604 | 603 | (declare (type literal lit)) |
| 605 | 604 | (unless (answer-literal? lit) |
| 606 | (incf num))) | |
| 605 | (incf num))) | |
| 607 | 606 | num)) |
| 608 | 607 | |
| 609 | 608 | ;;; NUM-ANSWERS : Clause -> Nat |
| 612 | 611 | |
| 613 | 612 | (defun num-answers (clause) |
| 614 | 613 | (declare (type clause clause) |
| 615 | (values fixnum)) | |
| 614 | (values fixnum)) | |
| 616 | 615 | (let ((i 0)) |
| 617 | 616 | (declare (type fixnum i)) |
| 618 | 617 | (dolist (lit (clause-literals clause)) |
| 619 | 618 | (declare (type literal lit)) |
| 620 | 619 | (when (answer-literal? lit) |
| 621 | (incf i))) | |
| 620 | (incf i))) | |
| 622 | 621 | i)) |
| 623 | 622 | |
| 624 | 623 | ;;; NUM-LITERALS-ALL : Clause -> Nat |
| 627 | 626 | |
| 628 | 627 | (defun num-literals-all (clause) |
| 629 | 628 | (declare (type clause clause) |
| 630 | (values fixnum)) | |
| 629 | (values fixnum)) | |
| 631 | 630 | (the fixnum (length (clause-literals clause)))) |
| 632 | 631 | |
| 633 | 632 | ;;; UNIT-CLAUSE? : Clause -> Bool |
| 648 | 647 | (defun positive-clause? (clause) |
| 649 | 648 | (declare (type clause clause)) |
| 650 | 649 | (every #'(lambda (lit) |
| 651 | (declare (type literal lit)) | |
| 652 | (or (positive-literal? lit) | |
| 653 | (answer-literal? lit))) | |
| 654 | (clause-literals clause))) | |
| 650 | (declare (type literal lit)) | |
| 651 | (or (positive-literal? lit) | |
| 652 | (answer-literal? lit))) | |
| 653 | (clause-literals clause))) | |
| 655 | 654 | |
| 656 | 655 | ;;; NEGATIVE-CLAUSE? : Clause -> Bool |
| 657 | 656 | ;;; |
| 660 | 659 | (defun negative-clause? (clause) |
| 661 | 660 | (declare (type clause clause)) |
| 662 | 661 | (every #'(lambda (lit) |
| 663 | (declare (type literal lit)) | |
| 664 | (or (negative-literal? lit) | |
| 665 | (answer-literal? lit))) | |
| 666 | (clause-literals clause))) | |
| 662 | (declare (type literal lit)) | |
| 663 | (or (negative-literal? lit) | |
| 664 | (answer-literal? lit))) | |
| 665 | (clause-literals clause))) | |
| 667 | 666 | |
| 668 | 667 | ;;; PROPOSITIONAL-CLAUSE? : Clause -> Bool |
| 669 | 668 | ;;; |
| 672 | 671 | (defun propositional-clause? (clause) |
| 673 | 672 | (declare (type clause clause)) |
| 674 | 673 | (every #'(lambda (lit) |
| 675 | (declare (type literal lit)) | |
| 676 | (let ((atom (literal-atom lit))) | |
| 677 | (and (not (term-is-variable? atom)) | |
| 678 | (term-is-constant? atom)))) | |
| 679 | (clause-literals clause))) | |
| 674 | (declare (type literal lit)) | |
| 675 | (let ((atom (literal-atom lit))) | |
| 676 | (and (not (term-is-variable? atom)) | |
| 677 | (term-is-constant? atom)))) | |
| 678 | (clause-literals clause))) | |
| 680 | 679 | |
| 681 | 680 | ;;; HORN-CLAUSE? : Clause -> Bool |
| 682 | 681 | ;;; t if clause is a Horn Clause (at most one positive literal). |
| 691 | 690 | (dolist (lit (clause-literals clause)) |
| 692 | 691 | (declare (type literal lit)) |
| 693 | 692 | (when (and (positive-literal? lit) |
| 694 | (not (answer-literal? lit))) | |
| 695 | (incf i))) | |
| 693 | (not (answer-literal? lit))) | |
| 694 | (incf i))) | |
| 696 | 695 | (<= i 1))) |
| 697 | 696 | |
| 698 | 697 | ;;; EQUALITY-CLAUSE? : Clause -> Bool |
| 705 | 704 | (dolist (lit (clause-literals clause)) |
| 706 | 705 | (declare (type literal lit)) |
| 707 | 706 | (if (or (positive-eq-literal? lit) |
| 708 | (negative-eq-literal? lit)) | |
| 709 | (return-from equality-clause? t))) | |
| 707 | (negative-eq-literal? lit)) | |
| 708 | (return-from equality-clause? t))) | |
| 710 | 709 | nil) |
| 711 | 710 | |
| 712 | 711 | ;;; SYMMETRY-CLAUSE? : Clause -> Bool |
| 719 | 718 | (unless (= 2 (num-literals clause)) |
| 720 | 719 | (return-from symmetry-clause? nil)) |
| 721 | 720 | (let ((l1 (first lits)) |
| 722 | (l2 (second lits))) | |
| 721 | (l2 (second lits))) | |
| 723 | 722 | (declare (type literal l1 l2)) |
| 724 | 723 | (when (eq (literal-sign l1) |
| 725 | (literal-sign l2)) | |
| 726 | (return-from symmetry-clause? nil)) | |
| 724 | (literal-sign l2)) | |
| 725 | (return-from symmetry-clause? nil)) | |
| 727 | 726 | (and (eq-literal? l1) |
| 728 | (eq-literal? l2) | |
| 729 | (let ((t1 (literal-atom l1)) | |
| 730 | (t2 (literal-atom l2))) | |
| 731 | (and (term-is-variable? (term-arg-1 t1)) | |
| 732 | (variable-eq (term-arg-1 t1) | |
| 733 | (term-arg-2 t2)) | |
| 734 | (term-is-variable? (term-arg-2 t1)) | |
| 735 | (variable-eq (term-arg-2 t1) | |
| 736 | (term-arg-1 t2)))))))) | |
| 737 | ||
| 727 | (eq-literal? l2) | |
| 728 | (let ((t1 (literal-atom l1)) | |
| 729 | (t2 (literal-atom l2))) | |
| 730 | (and (term-is-variable? (term-arg-1 t1)) | |
| 731 | (variable-eq (term-arg-1 t1) | |
| 732 | (term-arg-2 t2)) | |
| 733 | (term-is-variable? (term-arg-2 t1)) | |
| 734 | (variable-eq (term-arg-2 t1) | |
| 735 | (term-arg-1 t2)))))))) | |
| 736 | ||
| 738 | 737 | ;;; XX-RESOLVABLE : Clause -> Bool |
| 739 | 738 | ;;; t if the non unit clause have a literal that can |
| 740 | 739 | ;;; resolve with x = x. |
| 745 | 744 | (declare (type literal lit)) |
| 746 | 745 | (when (negative-eq-literal? lit) |
| 747 | 746 | (let* ((atom (literal-atom lit)) |
| 748 | (a1 (term-arg-1 atom)) | |
| 749 | (a2 (term-arg-2 atom))) | |
| 750 | (if (and (term-is-variable? a1) | |
| 751 | (not (occurs-in a1 a2))) | |
| 752 | (return-from xx-resolvable t) | |
| 753 | (if (and (term-is-variable? a2) | |
| 754 | (not (occurs-in a2 a1))) | |
| 755 | (return-from xx-resolvable t)))))) | |
| 747 | (a1 (term-arg-1 atom)) | |
| 748 | (a2 (term-arg-2 atom))) | |
| 749 | (if (and (term-is-variable? a1) | |
| 750 | (not (occurs-in a1 a2))) | |
| 751 | (return-from xx-resolvable t) | |
| 752 | (if (and (term-is-variable? a2) | |
| 753 | (not (occurs-in a2 a1))) | |
| 754 | (return-from xx-resolvable t)))))) | |
| 756 | 755 | nil) |
| 757 | 756 | |
| 758 | 757 | |
| 760 | 759 | ;;; proof system |
| 761 | 760 | ;;; ============ |
| 762 | 761 | (defstruct psystem |
| 763 | (module nil) ; context module | |
| 764 | (sos nil) ; list of sos clause | |
| 765 | (usable nil) ; list of usable clause | |
| 766 | (passive nil) ; list of passive clause | |
| 767 | (axioms nil) ; list of axioms in clause form | |
| 768 | (demods nil) ; list of demod clauses | |
| 769 | (bi-demods nil) ; list of builtin demod clauses | |
| 770 | (clause-hash nil) ; hash table of clauses | |
| 771 | (demodulators nil) ; (make-hash-table :test #'eq)) | |
| 772 | ; demodulator hash table | |
| 773 | (clause-counter 1) ; clause identifier counter | |
| 762 | (module nil) ; context module | |
| 763 | (sos nil) ; list of sos clause | |
| 764 | (usable nil) ; list of usable clause | |
| 765 | (passive nil) ; list of passive clause | |
| 766 | (axioms nil) ; list of axioms in clause form | |
| 767 | (demods nil) ; list of demod clauses | |
| 768 | (bi-demods nil) ; list of builtin demod clauses | |
| 769 | (clause-hash nil) ; hash table of clauses | |
| 770 | (demodulators nil) ; (make-hash-table :test #'eq)) | |
| 771 | ; demodulator hash table | |
| 772 | (clause-counter 1) ; clause identifier counter | |
| 774 | 773 | ) |
| 775 | 774 | |
| 776 | 775 | (defun initialize-psystem (psys mod) |
| 777 | 776 | (declare (type psystem psys) |
| 778 | (type module mod) | |
| 779 | (values psystem)) | |
| 777 | (type module mod) | |
| 778 | (values psystem)) | |
| 780 | 779 | (setf (psystem-module psys) mod |
| 781 | (psystem-sos psys) nil | |
| 782 | (psystem-usable psys) nil | |
| 783 | (psystem-axioms psys) nil | |
| 784 | (psystem-clause-counter psys) 1) | |
| 780 | (psystem-sos psys) nil | |
| 781 | (psystem-usable psys) nil | |
| 782 | (psystem-axioms psys) nil | |
| 783 | (psystem-clause-counter psys) 1) | |
| 785 | 784 | (clrhash (psystem-clause-hash psys)) |
| 786 | 785 | (clrhash (psystem-demodulators psys)) |
| 787 | 786 | psys) |
| 791 | 790 | ;;; allocated one for each clashable literal of nucleus. |
| 792 | 791 | ;;; |
| 793 | 792 | (defstruct (clash (:print-function print-clash)) |
| 794 | (literal nil :type (or null literal)) ; literal from nucleus | |
| 795 | (db nil :type (or null hash-table)) ; indexed table to use for | |
| 796 | ; finding satellites | |
| 797 | (subst nil :type list) ; unifying substitution | |
| 793 | (literal nil :type (or null literal)) ; literal from nucleus | |
| 794 | (db nil :type (or null hash-table)) ; indexed table to use for | |
| 795 | ; finding satellites | |
| 796 | (subst nil :type list) ; unifying substitution | |
| 798 | 797 | (clashables nil :type list) |
| 799 | 798 | (found-lit nil :type (or null literal)) ; unifying literal |
| 800 | (evaluable nil) ; bi-demod | |
| 801 | (evaluation nil) ; ditto | |
| 802 | (already-evaluated nil) ; ditto | |
| 803 | (prev nil :type (or null clash)) ; links | |
| 799 | (evaluable nil) ; bi-demod | |
| 800 | (evaluation nil) ; ditto | |
| 801 | (already-evaluated nil) ; ditto | |
| 802 | (prev nil :type (or null clash)) ; links | |
| 804 | 803 | (next nil :type (or null clash)) |
| 805 | 804 | ) |
| 806 | 805 | |
| 807 | 806 | (defun print-clash (obj &optional (stream *standard-output*) |
| 808 | &rest ignore) | |
| 807 | &rest ignore) | |
| 809 | 808 | (declare (ignore ignore)) |
| 810 | 809 | (let* ((*standard-output* stream) |
| 811 | (fcol (file-column stream)) | |
| 812 | (*print-indent* (if (not (= 0 fcol)) | |
| 813 | fcol | |
| 814 | (+ *print-indent* 4)))) | |
| 810 | (fcol (file-column stream)) | |
| 811 | (*print-indent* (if (not (= 0 fcol)) | |
| 812 | fcol | |
| 813 | (+ *print-indent* 4)))) | |
| 815 | 814 | ;; |
| 816 | 815 | (declare (type fixnum fcol *print-indent*)) |
| 817 | 816 | (do ((clash obj (clash-next clash)) |
| 818 | (num 0 (1+ num))) | |
| 819 | ((null clash)) | |
| 817 | (num 0 (1+ num))) | |
| 818 | ((null clash)) | |
| 820 | 819 | (declare (type fixnum num)) |
| 821 | 820 | (format t "#~d<clash: lit = " num) |
| 822 | 821 | (prin1 (clash-literal clash)) |
| 823 | 822 | (print-next) |
| 824 | 823 | (format t "clause-id = ~d" (clause-id (literal-clause |
| 825 | (clash-literal clash)))) | |
| 824 | (clash-literal clash)))) | |
| 826 | 825 | (print-next) |
| 827 | 826 | (princ "subst = ") (print-substitution (clash-subst clash)) |
| 828 | 827 | (print-next) |
| 829 | 828 | (princ "found-lit = ") (prin1 (clash-found-lit clash)) |
| 830 | 829 | (print-next) |
| 831 | 830 | (when (clash-found-lit clash) |
| 832 | (format t "found clause-id = ~d" | |
| 833 | (clause-id (literal-clause (clash-found-lit clash))))) | |
| 831 | (format t "found clause-id = ~d" | |
| 832 | (clause-id (literal-clause (clash-found-lit clash))))) | |
| 834 | 833 | (when (clash-evaluable clash) |
| 835 | (format t "evaluable: value = ~a" (clash-evaluation clash)) | |
| 836 | (print-next) | |
| 837 | (format t "already evaled? = ~a" (clash-already-evaluated clash))) | |
| 834 | (format t "evaluable: value = ~a" (clash-evaluation clash)) | |
| 835 | (print-next) | |
| 836 | (format t "already evaled? = ~a" (clash-already-evaluated clash))) | |
| 838 | 837 | (princ ">") |
| 839 | 838 | (print-next) |
| 840 | 839 | ))) |
| 861 | 860 | ;;; DEMODULATOR |
| 862 | 861 | ;;; |
| 863 | 862 | (defstruct (demod |
| 864 | (:copier nil) | |
| 865 | (:constructor make-demod) | |
| 866 | (:print-function print-demodulator)) | |
| 863 | (:copier nil) | |
| 864 | (:constructor make-demod) | |
| 865 | (:print-function print-demodulator)) | |
| 867 | 866 | (axiom nil :type (or null axiom)) |
| 868 | 867 | (order :normal :type symbol) |
| 869 | 868 | (clause nil) |
| 886 | 885 | (defun print-demod-object (obj &optional (stream *standard-output*) &rest ignore) |
| 887 | 886 | (declare (ignore ignore)) |
| 888 | 887 | (format stream "#<demodulator (~a) ~a: ~x>" |
| 889 | (clause-id (demod-clause obj)) | |
| 890 | (demod-order obj) (addr-of obj))) | |
| 888 | (clause-id (demod-clause obj)) | |
| 889 | (demod-order obj) (addr-of obj))) | |
| 891 | 890 | ||# |
| 892 | 891 | |
| 893 | 892 | (defun print-demodulator (demod &optional (stream *standard-output*) &rest ignore) |
| 894 | 893 | (declare (ignore ignore)) |
| 895 | 894 | (let* ((lhs (demod-lhs demod)) |
| 896 | (rhs (demod-rhs demod)) | |
| 897 | (clause (demod-clause demod)) | |
| 898 | (clause-id (if (not (clause-p clause)) | |
| 899 | :* | |
| 900 | (clause-id clause))) | |
| 901 | (.printed-vars-so-far. nil)) | |
| 895 | (rhs (demod-rhs demod)) | |
| 896 | (clause (demod-clause demod)) | |
| 897 | (clause-id (if (not (clause-p clause)) | |
| 898 | :* | |
| 899 | (clause-id clause))) | |
| 900 | (.printed-vars-so-far. nil)) | |
| 902 | 901 | (let ((*standard-output* stream) |
| 903 | (.file-col. .file-col.) | |
| 904 | (indent 0)) | |
| 902 | (.file-col. .file-col.) | |
| 903 | (indent 0)) | |
| 905 | 904 | (format t "(~a) " clause-id) |
| 906 | 905 | (setq indent (file-column stream)) |
| 907 | 906 | (setq .printed-vars-so-far. |
| 908 | (term-print lhs)) | |
| 907 | (term-print lhs)) | |
| 909 | 908 | (setq .file-col. (file-column stream)) |
| 910 | 909 | (print-check indent .file-col.) |
| 911 | 910 | (princ " --> ") |
| 0 | 0 | ;;;-*-Mode:LISP; Package: CHAOS; Base:10; Syntax:Common-lisp -*- |
| 1 | 1 | ;;; |
| 2 | ;;; Copyright (c) 2000-2014, Toshimi Sawada. All rights reserved. | |
| 2 | ;;; Copyright (c) 2000-2015, Toshimi Sawada. All rights reserved. | |
| 3 | 3 | ;;; |
| 4 | 4 | ;;; Redistribution and use in source and binary forms, with or without |
| 5 | 5 | ;;; modification, are permitted provided that the following conditions |
| 28 | 28 | ;;; |
| 29 | 29 | (in-package :chaos) |
| 30 | 30 | #|============================================================================= |
| 31 | System:Chaos | |
| 32 | Module:BigPink | |
| 33 | File:unify.lisp | |
| 31 | System:Chaos | |
| 32 | Module:BigPink | |
| 33 | File:unify.lisp | |
| 34 | 34 | =============================================================================|# |
| 35 | 35 | #-:chaos-debug |
| 36 | 36 | (declaim (optimize (speed 3) (safety 0) #-GCL (debug 0))) |
| 44 | 44 | (defun compose-subst (s1 s2) |
| 45 | 45 | (declare (type list s1 s2)) |
| 46 | 46 | (labels ((add-new (s newsl) |
| 47 | (declare (type list s newsl)) | |
| 48 | (cond ((null s) newsl) | |
| 49 | ((variable-image newsl (caar s)) | |
| 50 | (add-new (cdr s) newsl)) | |
| 51 | (t (cons (car s) (add-new (cdr s) newsl))))) | |
| 52 | (composel (s1 s2) | |
| 53 | (declare (type list s1 s2)) | |
| 54 | (cond ((null s1) nil) | |
| 55 | (t (cons (cons (caar s1) | |
| 56 | (apply-subst s2 (cdar s1))) | |
| 57 | (composel (cdr s1) s2)))))) | |
| 47 | (declare (type list s newsl)) | |
| 48 | (cond ((null s) newsl) | |
| 49 | ((variable-image newsl (caar s)) | |
| 50 | (add-new (cdr s) newsl)) | |
| 51 | (t (cons (car s) (add-new (cdr s) newsl))))) | |
| 52 | (composel (s1 s2) | |
| 53 | (declare (type list s1 s2)) | |
| 54 | (cond ((null s1) nil) | |
| 55 | (t (cons (cons (caar s1) | |
| 56 | (apply-subst s2 (cdar s1))) | |
| 57 | (composel (cdr s1) s2)))))) | |
| 58 | 58 | ;; |
| 59 | 59 | (if (car s2) |
| 60 | (add-new s2 (composel s1 s2)) | |
| 60 | (add-new s2 (composel s1 s2)) | |
| 61 | 61 | s1))) |
| 62 | 62 | |
| 63 | 63 | #|| |
| 64 | 64 | (defun pn-decompose-terms-unify (t1 t2 ans) |
| 65 | 65 | (macrolet ((add-bind-to-sub (v1 t1 sub) |
| 66 | `(let* ((pair (cons ,v1 ,t1)) | |
| 67 | (new-sub (normal-form-sub (list pair) ,sub))) | |
| 68 | (unless new-sub | |
| 69 | (return-from pn-decompose-terms-unify :fail)) | |
| 70 | new-sub))) | |
| 66 | `(let* ((pair (cons ,v1 ,t1)) | |
| 67 | (new-sub (normal-form-sub (list pair) ,sub))) | |
| 68 | (unless new-sub | |
| 69 | (return-from pn-decompose-terms-unify :fail)) | |
| 70 | new-sub))) | |
| 71 | 71 | (cond ((term-is-variable? t1) |
| 72 | (when (variable-eq t1 t2) | |
| 73 | (return-from pn-decompose-terms-unify ans)) | |
| 74 | (when (occurs-in t1 t2) | |
| 75 | (return-from pn-decompose-terms-unify :fail)) | |
| 76 | (let ((cval (variable-image ans t1))) | |
| 77 | (if cval | |
| 78 | (pn-decompose-terms-unify cval t2 ans) | |
| 79 | (let ((s1 (term-sort t1)) | |
| 80 | (s2 (term-sort t2))) | |
| 81 | (if (sort<= s2 s1 *current-sort-order*) | |
| 82 | (add-bind-to-sub t1 t2 ans) | |
| 83 | (if (term-is-variable? t2) | |
| 84 | (if (sort<= s1 s2 *current-sort-order*) | |
| 85 | (add-bind-to-sub t2 t1 ans) | |
| 86 | :fail) | |
| 87 | :fail))))) | |
| 88 | ) | |
| 89 | ;; | |
| 90 | ((term-is-variable? t2) | |
| 91 | (pn-decompose-terms-unify t2 t1 ans)) | |
| 92 | ;; | |
| 93 | ((term-is-builtin-constant? t1) | |
| 94 | (if (term-builtin-equal t1 t2) | |
| 95 | ans | |
| 96 | :fail)) | |
| 97 | ((term-is-builtin-constant? t2) | |
| 98 | :fail) | |
| 99 | ;; | |
| 100 | ((term-is-application-form? t1) | |
| 101 | (let ((t1-top (term-head t1)) | |
| 102 | (t2-top (term-head t2))) | |
| 103 | (if (method-is-of-same-operator t1-top t2-top) | |
| 104 | (let ((t1-subterms (term-subterms t1)) | |
| 105 | (t2-subterms (term-subterms t2))) | |
| 106 | (loop | |
| 107 | (unless t1-subterms (return)) | |
| 108 | (setq ans (pn-decompose-terms-unify (car t1-subterms) | |
| 109 | (car t2-subterms) | |
| 110 | ans)) | |
| 111 | (when (eq ans :fail) (return)) | |
| 112 | (setq t1-subterms (cdr t1-subterms)) | |
| 113 | (setq t2-subterms (cdr t2-subterms))) | |
| 114 | ans) | |
| 115 | :fail))) | |
| 116 | ;; | |
| 117 | (t ;(term-is-builtin-constant? t2) | |
| 118 | :fail | |
| 119 | )))) | |
| 72 | (when (variable-eq t1 t2) | |
| 73 | (return-from pn-decompose-terms-unify ans)) | |
| 74 | (when (occurs-in t1 t2) | |
| 75 | (return-from pn-decompose-terms-unify :fail)) | |
| 76 | (let ((cval (variable-image ans t1))) | |
| 77 | (if cval | |
| 78 | (pn-decompose-terms-unify cval t2 ans) | |
| 79 | (let ((s1 (term-sort t1)) | |
| 80 | (s2 (term-sort t2))) | |
| 81 | (if (sort<= s2 s1 *current-sort-order*) | |
| 82 | (add-bind-to-sub t1 t2 ans) | |
| 83 | (if (term-is-variable? t2) | |
| 84 | (if (sort<= s1 s2 *current-sort-order*) | |
| 85 | (add-bind-to-sub t2 t1 ans) | |
| 86 | :fail) | |
| 87 | :fail))))) | |
| 88 | ) | |
| 89 | ;; | |
| 90 | ((term-is-variable? t2) | |
| 91 | (pn-decompose-terms-unify t2 t1 ans)) | |
| 92 | ;; | |
| 93 | ((term-is-builtin-constant? t1) | |
| 94 | (if (term-builtin-equal t1 t2) | |
| 95 | ans | |
| 96 | :fail)) | |
| 97 | ((term-is-builtin-constant? t2) | |
| 98 | :fail) | |
| 99 | ;; | |
| 100 | ((term-is-application-form? t1) | |
| 101 | (let ((t1-top (term-head t1)) | |
| 102 | (t2-top (term-head t2))) | |
| 103 | (if (method-is-of-same-operator t1-top t2-top) | |
| 104 | (let ((t1-subterms (term-subterms t1)) | |
| 105 | (t2-subterms (term-subterms t2))) | |
| 106 | (loop | |
| 107 | (unless t1-subterms (return)) | |
| 108 | (setq ans (pn-decompose-terms-unify (car t1-subterms) | |
| 109 | (car t2-subterms) | |
| 110 | ans)) | |
| 111 | (when (eq ans :fail) (return)) | |
| 112 | (setq t1-subterms (cdr t1-subterms)) | |
| 113 | (setq t2-subterms (cdr t2-subterms))) | |
| 114 | ans) | |
| 115 | :fail))) | |
| 116 | ;; | |
| 117 | (t ;(term-is-builtin-constant? t2) | |
| 118 | :fail | |
| 119 | )))) | |
| 120 | 120 | ||# |
| 121 | 121 | |
| 122 | 122 | (declaim (special .do-occur-check.)) |
| 124 | 124 | |
| 125 | 125 | (defun pn-decompose-terms-unify (t1 t2 ans) |
| 126 | 126 | (declare (type term t1 t2) |
| 127 | (type (or symbol list) ans) | |
| 128 | ;; (values (or (member :fail) list)) | |
| 129 | (values (or symbol list))) | |
| 127 | (type (or symbol list) ans) | |
| 128 | ;; (values (or (member :fail) list)) | |
| 129 | (values (or symbol list))) | |
| 130 | 130 | (macrolet ((add-binding (v1 t1 sub) |
| 131 | `(cons (cons ,v1 ,t1) ,sub))) | |
| 131 | `(cons (cons ,v1 ,t1) ,sub))) | |
| 132 | 132 | ;; |
| 133 | 133 | (labels ((occurs-check (var x bindings) |
| 134 | (declare (type term var x) | |
| 135 | (list bindings)) | |
| 136 | (cond ((term-is-variable? x) | |
| 137 | (or (term-eq var x) | |
| 138 | (let ((cval (variable-image bindings x))) | |
| 139 | (declare (type (or null term) cval)) | |
| 140 | (and cval | |
| 141 | (occurs-check var cval bindings))))) | |
| 142 | ((term-is-application-form? x) | |
| 143 | (dolist (sub (term-subterms x)) | |
| 144 | (when (occurs-check var sub bindings) | |
| 145 | (return-from occurs-check t))) | |
| 146 | nil) | |
| 147 | (t nil))) | |
| 148 | (var-unify (var x bindings) | |
| 149 | (declare (type term var x) | |
| 150 | (type list bindings)) | |
| 151 | (let ((cval (variable-image bindings var)) | |
| 152 | ;; (x-is-var nil) | |
| 153 | ) | |
| 154 | (declare (type (or null term) cval)) | |
| 155 | (when cval | |
| 156 | (return-from var-unify | |
| 157 | (pn-decompose-terms-unify cval x bindings))) | |
| 158 | (when (term-is-variable? x) | |
| 159 | ;; (setq x-is-var t) | |
| 160 | (let ((cval2 (variable-image bindings x))) | |
| 161 | (declare (type (or null term) cval2)) | |
| 162 | (when cval2 | |
| 163 | (return-from var-unify | |
| 164 | (pn-decompose-terms-unify var cval2 bindings))))) | |
| 165 | (when (and .do-occur-check. | |
| 166 | (occurs-check var x bindings)) | |
| 167 | (return-from var-unify :fail)) | |
| 168 | ;; | |
| 169 | (let ((s1 (term-sort var)) | |
| 170 | (s2 (term-sort x))) | |
| 171 | (declare (type sort* s1 s2)) | |
| 172 | (if (sort<= s2 s1 *current-sort-order*) | |
| 173 | (add-binding var x bindings) | |
| 174 | #|| | |
| 175 | (if x-is-var | |
| 176 | (if (sort<= s1 s2 *current-sort-order*) | |
| 177 | (add-binding x var bindings) | |
| 178 | :fail) | |
| 179 | :fail) | |
| 180 | ||# | |
| 181 | :fail )))) | |
| 182 | ) | |
| 134 | (declare (type term var x) | |
| 135 | (list bindings)) | |
| 136 | (cond ((term-is-variable? x) | |
| 137 | (or (term-eq var x) | |
| 138 | (let ((cval (variable-image bindings x))) | |
| 139 | (declare (type (or null term) cval)) | |
| 140 | (and cval | |
| 141 | (occurs-check var cval bindings))))) | |
| 142 | ((term-is-application-form? x) | |
| 143 | (dolist (sub (term-subterms x)) | |
| 144 | (when (occurs-check var sub bindings) | |
| 145 | (return-from occurs-check t))) | |
| 146 | nil) | |
| 147 | (t nil))) | |
| 148 | (var-unify (var x bindings) | |
| 149 | (declare (type term var x) | |
| 150 | (type list bindings)) | |
| 151 | (let ((cval (variable-image bindings var)) | |
| 152 | ;; (x-is-var nil) | |
| 153 | ) | |
| 154 | (declare (type (or null term) cval)) | |
| 155 | (when cval | |
| 156 | (return-from var-unify | |
| 157 | (pn-decompose-terms-unify cval x bindings))) | |
| 158 | (when (term-is-variable? x) | |
| 159 | ;; (setq x-is-var t) | |
| 160 | (let ((cval2 (variable-image bindings x))) | |
| 161 | (declare (type (or null term) cval2)) | |
| 162 | (when cval2 | |
| 163 | (return-from var-unify | |
| 164 | (pn-decompose-terms-unify var cval2 bindings))))) | |
| 165 | (when (and .do-occur-check. | |
| 166 | (occurs-check var x bindings)) | |
| 167 | (return-from var-unify :fail)) | |
| 168 | ;; | |
| 169 | (let ((s1 (term-sort var)) | |
| 170 | (s2 (term-sort x))) | |
| 171 | (declare (type sort* s1 s2)) | |
| 172 | (if (sort<= s2 s1 *current-sort-order*) | |
| 173 | (add-binding var x bindings) | |
| 174 | #|| | |
| 175 | (if x-is-var | |
| 176 | (if (sort<= s1 s2 *current-sort-order*) | |
| 177 | (add-binding x var bindings) | |
| 178 | :fail) | |
| 179 | :fail) | |
| 180 | ||# | |
| 181 | :fail )))) | |
| 182 | ) | |
| 183 | 183 | ;; |
| 184 | 184 | (cond ((term-eq t1 t2) |
| 185 | (return-from pn-decompose-terms-unify ans)) | |
| 186 | ((term-is-variable? t1) | |
| 187 | (var-unify t1 t2 ans)) | |
| 188 | ((term-is-variable? t2) | |
| 189 | (var-unify t2 t1 ans)) | |
| 190 | ;; | |
| 191 | ((term-is-builtin-constant? t1) | |
| 192 | (if (term-builtin-equal t1 t2) | |
| 193 | ans | |
| 194 | :fail)) | |
| 195 | ((term-is-builtin-constant? t2) | |
| 196 | :fail) | |
| 197 | ;; | |
| 198 | ((term-is-application-form? t1) | |
| 199 | (let ((t1-top (term-head t1)) | |
| 200 | (t2-top (term-head t2))) | |
| 201 | (declare (type method t1-top t2-top)) | |
| 202 | (if (method-is-of-same-operator t1-top t2-top) | |
| 203 | (let ((t1-subterms (term-subterms t1)) | |
| 204 | (t2-subterms (term-subterms t2))) | |
| 205 | (loop | |
| 206 | (unless t1-subterms (return)) | |
| 207 | (setq ans (pn-decompose-terms-unify (car t1-subterms) | |
| 208 | (car t2-subterms) | |
| 209 | ans)) | |
| 210 | (when (eq ans :fail) (return)) | |
| 211 | (setq t1-subterms (cdr t1-subterms)) | |
| 212 | (setq t2-subterms (cdr t2-subterms))) | |
| 213 | ans) | |
| 214 | :fail))) | |
| 215 | ;; | |
| 216 | (t ;(term-is-builtin-constant? t2) | |
| 217 | :fail | |
| 218 | ))))) | |
| 185 | (return-from pn-decompose-terms-unify ans)) | |
| 186 | ((term-is-variable? t1) | |
| 187 | (var-unify t1 t2 ans)) | |
| 188 | ((term-is-variable? t2) | |
| 189 | (var-unify t2 t1 ans)) | |
| 190 | ;; | |
| 191 | ((term-is-builtin-constant? t1) | |
| 192 | (if (term-builtin-equal t1 t2) | |
| 193 | ans | |
| 194 | :fail)) | |
| 195 | ((term-is-builtin-constant? t2) | |
| 196 | :fail) | |
| 197 | ;; | |
| 198 | ((term-is-application-form? t1) | |
| 199 | (let ((t1-top (term-head t1)) | |
| 200 | (t2-top (term-head t2))) | |
| 201 | (declare (type method t1-top t2-top)) | |
| 202 | (if (method-is-of-same-operator t1-top t2-top) | |
| 203 | (let ((t1-subterms (term-subterms t1)) | |
| 204 | (t2-subterms (term-subterms t2))) | |
| 205 | (loop | |
| 206 | (unless t1-subterms (return)) | |
| 207 | (setq ans (pn-decompose-terms-unify (car t1-subterms) | |
| 208 | (car t2-subterms) | |
| 209 | ans)) | |
| 210 | (when (eq ans :fail) (return)) | |
| 211 | (setq t1-subterms (cdr t1-subterms)) | |
| 212 | (setq t2-subterms (cdr t2-subterms))) | |
| 213 | ans) | |
| 214 | :fail))) | |
| 215 | ;; | |
| 216 | (t ;(term-is-builtin-constant? t2) | |
| 217 | :fail | |
| 218 | ))))) | |
| 219 | 219 | |
| 220 | 220 | (defun pn-decompose-terms-match (t1 t2 ans) |
| 221 | 221 | (declare (type term t1 t2) |
| 222 | (type (or (member :fail) list) ans) | |
| 223 | (values (or (member :fail) list))) | |
| 222 | (type (or (member :fail) list) ans) | |
| 223 | (values (or (member :fail) list))) | |
| 224 | 224 | (macrolet ((add-bind-to-sub (v1 t1 sub) |
| 225 | `(cons (cons ,v1 ,t1) ,sub))) | |
| 225 | `(cons (cons ,v1 ,t1) ,sub))) | |
| 226 | 226 | (cond ((term-is-variable? t1) |
| 227 | (let ((cval (variable-image ans t1))) | |
| 228 | (declare (type (or null term) cval)) | |
| 229 | (if cval | |
| 230 | (if (term-is-identical cval t2) | |
| 231 | ans | |
| 232 | :fail) | |
| 233 | (if (sort<= (term-sort t2) (term-sort t1) | |
| 234 | *current-sort-order*) | |
| 235 | (add-bind-to-sub t1 t2 ans) | |
| 236 | :fail) | |
| 237 | ))) | |
| 238 | ;; | |
| 239 | ((term-is-variable? t2) :fail) | |
| 240 | ;; | |
| 241 | ((term-is-builtin-constant? t1) | |
| 242 | (if (term-builtin-equal t1 t2) | |
| 243 | ans | |
| 244 | :fail)) | |
| 245 | ((term-is-builtin-constant? t2) :fail) | |
| 246 | ;; | |
| 247 | ((term-is-application-form? t1) | |
| 248 | (let ((t1-top (term-head t1)) | |
| 249 | (t2-top (term-head t2))) | |
| 250 | (declare (type method t1-top t2-top)) | |
| 251 | (if (method-is-of-same-operator t1-top t2-top) | |
| 252 | (let ((t1-subterms (term-subterms t1)) | |
| 253 | (t2-subterms (term-subterms t2))) | |
| 254 | (loop | |
| 255 | (unless t1-subterms (return)) | |
| 256 | (setq ans (pn-decompose-terms-match (car t1-subterms) | |
| 257 | (car t2-subterms) | |
| 258 | ans)) | |
| 259 | (when (eq ans :fail) (return)) | |
| 260 | (setq t1-subterms (cdr t1-subterms)) | |
| 261 | (setq t2-subterms (cdr t2-subterms))) | |
| 262 | ans) | |
| 263 | :fail))) | |
| 264 | ;; | |
| 265 | (t ;(term-is-builtin-constant? t2) | |
| 266 | :fail | |
| 267 | )))) | |
| 227 | (let ((cval (variable-image ans t1))) | |
| 228 | (declare (type (or null term) cval)) | |
| 229 | (if cval | |
| 230 | (if (term-is-identical cval t2) | |
| 231 | ans | |
| 232 | :fail) | |
| 233 | (if (sort<= (term-sort t2) (term-sort t1) | |
| 234 | *current-sort-order*) | |
| 235 | (add-bind-to-sub t1 t2 ans) | |
| 236 | :fail) | |
| 237 | ))) | |
| 238 | ;; | |
| 239 | ((term-is-variable? t2) :fail) | |
| 240 | ;; | |
| 241 | ((term-is-builtin-constant? t1) | |
| 242 | (if (term-builtin-equal t1 t2) | |
| 243 | ans | |
| 244 | :fail)) | |
| 245 | ((term-is-builtin-constant? t2) :fail) | |
| 246 | ;; | |
| 247 | ((term-is-application-form? t1) | |
| 248 | (let ((t1-top (term-head t1)) | |
| 249 | (t2-top (term-head t2))) | |
| 250 | (declare (type method t1-top t2-top)) | |
| 251 | (if (method-is-of-same-operator t1-top t2-top) | |
| 252 | (let ((t1-subterms (term-subterms t1)) | |
| 253 | (t2-subterms (term-subterms t2))) | |
| 254 | (loop | |
| 255 | (unless t1-subterms (return)) | |
| 256 | (setq ans (pn-decompose-terms-match (car t1-subterms) | |
| 257 | (car t2-subterms) | |
| 258 | ans)) | |
| 259 | (when (eq ans :fail) (return)) | |
| 260 | (setq t1-subterms (cdr t1-subterms)) | |
| 261 | (setq t2-subterms (cdr t2-subterms))) | |
| 262 | ans) | |
| 263 | :fail))) | |
| 264 | ;; | |
| 265 | (t ;(term-is-builtin-constant? t2) | |
| 266 | :fail | |
| 267 | )))) | |
| 268 | 268 | |
| 269 | 269 | ;;; UNIFY : TERM1 TERM2 SUBST -> {SUBST, NO-MATCH, E-MATCH} |
| 270 | 270 | ;;; |
| 271 | 271 | (defun unify (t1 t2 &optional subst) |
| 272 | 272 | (declare (type term t1 t2) |
| 273 | (list subst)) | |
| 273 | (list subst)) | |
| 274 | 274 | (if (pn-flag unify-heavy) |
| 275 | 275 | (let ((*do-unify* t)) |
| 276 | (multiple-value-bind (gst new-subst no-match e-eq) | |
| 277 | (first-match t1 t2 subst) | |
| 278 | (declare (ignore gst) | |
| 279 | (type list new-subst)) | |
| 280 | (when no-match | |
| 281 | (return-from unify (values nil t nil))) | |
| 282 | (when e-eq | |
| 283 | (return-from unify (values subst nil t))) | |
| 284 | (setq subst | |
| 285 | (compose-subst subst new-subst)) | |
| 286 | (values subst nil nil)) | |
| 287 | ) | |
| 276 | (multiple-value-bind (gst new-subst no-match e-eq) | |
| 277 | (first-match t1 t2 subst) | |
| 278 | (declare (ignore gst) | |
| 279 | (type list new-subst)) | |
| 280 | (when no-match | |
| 281 | (return-from unify (values nil t nil))) | |
| 282 | (when e-eq | |
| 283 | (return-from unify (values subst nil t))) | |
| 284 | (setq subst | |
| 285 | (compose-subst subst new-subst)) | |
| 286 | (values subst nil nil)) | |
| 287 | ) | |
| 288 | 288 | ;; simple nonE-theory unification. |
| 289 | 289 | (let ((ans (pn-decompose-terms-unify t1 t2 subst))) |
| 290 | 290 | #|| |
| 291 | 291 | (when *match-debug* |
| 292 | (with-output-simple-msg () | |
| 293 | (princ "*** UNIFY") | |
| 294 | (print-next) | |
| 295 | (princ "t1 = ")(term-print t1) | |
| 296 | (print-next) | |
| 297 | (princ "t2 = ")(term-print t2)) | |
| 298 | ) | |
| 292 | (with-output-simple-msg () | |
| 293 | (princ "*** UNIFY") | |
| 294 | (print-next) | |
| 295 | (princ "t1 = ")(term-print t1) | |
| 296 | (print-next) | |
| 297 | (princ "t2 = ")(term-print t2)) | |
| 298 | ) | |
| 299 | 299 | ||# |
| 300 | 300 | (if (eq ans :fail) |
| 301 | (values nil t nil) | |
| 302 | (if ans | |
| 303 | (let ((sub (normal-form-sub ans nil)) | |
| 304 | ;; (sub ans) | |
| 305 | ) | |
| 306 | #|| | |
| 307 | (when *match-debug* | |
| 308 | (with-output-simple-msg () | |
| 309 | (princ "- UNIFY: subst = ") | |
| 310 | (print-substitution sub))) | |
| 311 | ||# | |
| 312 | (values sub nil nil) | |
| 313 | ) | |
| 314 | (progn | |
| 315 | #|| | |
| 316 | (when *match-debug* | |
| 317 | (with-output-simple-msg () | |
| 318 | (princ "- UNIFY: e-equal"))) | |
| 319 | ||# | |
| 320 | (values subst nil t)))) | |
| 301 | (values nil t nil) | |
| 302 | (if ans | |
| 303 | (let ((sub (normal-form-sub ans nil)) | |
| 304 | ;; (sub ans) | |
| 305 | ) | |
| 306 | #|| | |
| 307 | (when *match-debug* | |
| 308 | (with-output-simple-msg () | |
| 309 | (princ "- UNIFY: subst = ") | |
| 310 | (print-substitution sub))) | |
| 311 | ||# | |
| 312 | (values sub nil nil) | |
| 313 | ) | |
| 314 | (progn | |
| 315 | #|| | |
| 316 | (when *match-debug* | |
| 317 | (with-output-simple-msg () | |
| 318 | (princ "- UNIFY: e-equal"))) | |
| 319 | ||# | |
| 320 | (values subst nil t)))) | |
| 321 | 321 | ))) |
| 322 | 322 | |
| 323 | 323 | (declaim (inline prop-unify)) |
| 330 | 330 | |
| 331 | 331 | (defun first-unify (t1 t2 &optional subst) |
| 332 | 332 | (declare (type term t1 t2) |
| 333 | (type list subst)) | |
| 333 | (type list subst)) | |
| 334 | 334 | (let ((*do-unify* t)) |
| 335 | 335 | (multiple-value-bind (gst new-subst no-match e-eq) |
| 336 | (first-match t1 t2 subst) | |
| 336 | (first-match t1 t2 subst) | |
| 337 | 337 | (when no-match |
| 338 | (return-from first-unify (values nil nil t nil))) | |
| 338 | (return-from first-unify (values nil nil t nil))) | |
| 339 | 339 | (when e-eq |
| 340 | (return-from first-unify (values gst subst nil t))) | |
| 340 | (return-from first-unify (values gst subst nil t))) | |
| 341 | 341 | (setq subst |
| 342 | (compose-subst subst new-subst)) | |
| 342 | (compose-subst subst new-subst)) | |
| 343 | 343 | (values gst subst nil nil)) |
| 344 | 344 | )) |
| 345 | 345 | |
| 352 | 352 | ;;; ======= |
| 353 | 353 | (defun pn-match (t1 t2 &optional subst one-way-match) |
| 354 | 354 | (declare (type term t1 t2) |
| 355 | (type list subst)) | |
| 355 | (type list subst)) | |
| 356 | 356 | #|| |
| 357 | 357 | (when *match-debug* |
| 358 | 358 | (with-output-msg () |
| 362 | 362 | (print-next) |
| 363 | 363 | (princ "t2 = ") (term-print t2) |
| 364 | 364 | (when subst |
| 365 | (print-next) | |
| 366 | (princ "subst = ") (print-substitution subst)))) | |
| 365 | (print-next) | |
| 366 | (princ "subst = ") (print-substitution subst)))) | |
| 367 | 367 | ||# |
| 368 | 368 | (if (pn-flag unify-heavy) |
| 369 | 369 | (let ((*do-unify* nil) |
| 370 | (*one-way-match* one-way-match)) | |
| 371 | (multiple-value-bind (gst new-subst no-match e-eq) | |
| 372 | (first-match t1 t2 subst) | |
| 373 | (declare (ignore gst) | |
| 374 | (type list new-subst)) | |
| 375 | (when no-match | |
| 376 | (return-from pn-match (values nil t nil))) | |
| 377 | (when e-eq | |
| 378 | (return-from pn-match (values subst nil t))) | |
| 379 | (setq subst | |
| 380 | (compose-subst subst new-subst)) | |
| 381 | (return-from pn-match (values subst nil nil)))) | |
| 370 | (*one-way-match* one-way-match)) | |
| 371 | (multiple-value-bind (gst new-subst no-match e-eq) | |
| 372 | (first-match t1 t2 subst) | |
| 373 | (declare (ignore gst) | |
| 374 | (type list new-subst)) | |
| 375 | (when no-match | |
| 376 | (return-from pn-match (values nil t nil))) | |
| 377 | (when e-eq | |
| 378 | (return-from pn-match (values subst nil t))) | |
| 379 | (setq subst | |
| 380 | (compose-subst subst new-subst)) | |
| 381 | (return-from pn-match (values subst nil nil)))) | |
| 382 | 382 | ;; simple nonE-theory match |
| 383 | 383 | (let* ((*one-way-match* one-way-match) |
| 384 | (ans (pn-decompose-terms-match t1 t2 subst))) | |
| 384 | (ans (pn-decompose-terms-match t1 t2 subst))) | |
| 385 | 385 | (if (eq ans :fail) |
| 386 | (values nil t nil) | |
| 387 | (if ans | |
| 388 | (values ans nil nil) | |
| 389 | (values subst nil t)) | |
| 390 | )))) | |
| 386 | (values nil t nil) | |
| 387 | (if ans | |
| 388 | (values ans nil nil) | |
| 389 | (values subst nil t)) | |
| 390 | )))) | |
| 391 | 391 | |
| 392 | 392 | #|| |
| 393 | 393 | (defun pn-match-2 (t1 t2 &optional subst) |
| 394 | 394 | (let ((*do-unify* nil) |
| 395 | (*one-way-match* t)) | |
| 395 | (*one-way-match* t)) | |
| 396 | 396 | (multiple-value-bind (gst new-subst no-match e-eq) |
| 397 | (first-match t1 t2 subst) | |
| 397 | (first-match t1 t2 subst) | |
| 398 | 398 | (declare (ignore gst)) |
| 399 | 399 | (when no-match |
| 400 | (return-from pn-match-2 (values nil t nil))) | |
| 400 | (return-from pn-match-2 (values nil t nil))) | |
| 401 | 401 | (when e-eq |
| 402 | (return-from pn-match-2 (values subst nil t))) | |
| 402 | (return-from pn-match-2 (values subst nil t))) | |
| 403 | 403 | (setq subst |
| 404 | (compose-subst subst new-subst)) | |
| 404 | (compose-subst subst new-subst)) | |
| 405 | 405 | (return-from pn-match-2 (values subst nil nil))) |
| 406 | 406 | )) |
| 407 | 407 | ||# |
| 0 | 0 | ;;;-*-Mode:LISP; Package: CHAOS; Base:10; Syntax:Common-lisp -*- |
| 1 | 1 | ;;; |
| 2 | ;;; Copyright (c) 2000-2014, Toshimi Sawada. All rights reserved. | |
| 2 | ;;; Copyright (c) 2000-2015, Toshimi Sawada. All rights reserved. | |
| 3 | 3 | ;;; |
| 4 | 4 | ;;; Redistribution and use in source and binary forms, with or without |
| 5 | 5 | ;;; modification, are permitted provided that the following conditions |
| 28 | 28 | ;;; |
| 29 | 29 | (in-package :chaos) |
| 30 | 30 | #|============================================================================= |
| 31 | System:Chaos | |
| 32 | Module:BigPink | |
| 33 | File:weight.lisp | |
| 31 | System:Chaos | |
| 32 | Module:BigPink | |
| 33 | File:weight.lisp | |
| 34 | 34 | =============================================================================|# |
| 35 | 35 | #-:chaos-debug |
| 36 | 36 | (declaim (optimize (speed 3) (safety 0) #-GCL (debug 0))) |
| 72 | 72 | |
| 73 | 73 | (defun op-lex< (op1 op2 &optional (order .op-lex-relation-table.)) |
| 74 | 74 | (declare (type method op1 op2) |
| 75 | (type hash-table .op-lex-relation-table.)) | |
| 75 | (type hash-table .op-lex-relation-table.)) | |
| 76 | 76 | (memq op2 (superops op1 order))) |
| 77 | 77 | |
| 78 | 78 | (defun dump-op-lex-relation-table () |
| 79 | 79 | (maphash #'(lambda (op rel) |
| 80 | (with-output-msg () | |
| 81 | (format t "operator ~a " op) | |
| 82 | (print-method op) | |
| 83 | (print-next) | |
| 84 | (format t "subs: ~{~a~}" | |
| 85 | (_subops rel)) | |
| 86 | (print-next) | |
| 87 | (format t "supers: ~{~a~}" | |
| 88 | (_superops rel)) | |
| 89 | (print-next))) | |
| 90 | .op-lex-relation-table.)) | |
| 80 | (with-output-msg () | |
| 81 | (format t "operator ~a " op) | |
| 82 | (print-method op) | |
| 83 | (print-next) | |
| 84 | (format t "subs: ~{~a~}" | |
| 85 | (_subops rel)) | |
| 86 | (print-next) | |
| 87 | (format t "supers: ~{~a~}" | |
| 88 | (_superops rel)) | |
| 89 | (print-next))) | |
| 90 | .op-lex-relation-table.)) | |
| 91 | 91 | |
| 92 | 92 | (defun term-sub-operators (term) |
| 93 | 93 | (declare (type term) |
| 94 | (values list)) | |
| 94 | (values list)) | |
| 95 | 95 | (let ((res nil)) |
| 96 | 96 | (declare (type list res)) |
| 97 | 97 | (when (term-is-application-form? term) |
| 98 | 98 | (dolist (sub (term-subterms term)) |
| 99 | (when (term-is-application-form? sub) | |
| 100 | (pushnew (term-head sub) res :test #'eq)))) | |
| 99 | (when (term-is-application-form? sub) | |
| 100 | (pushnew (term-head sub) res :test #'eq)))) | |
| 101 | 101 | res)) |
| 102 | 102 | |
| 103 | 103 | ;;; ADD-OP-TO-ORDER |
| 104 | 104 | |
| 105 | 105 | (defun add-op-to-order (op &optional (order .op-lex-relation-table.)) |
| 106 | 106 | (declare (type method op) |
| 107 | (type hash-table .op-lex-relation-table.)) | |
| 107 | (type hash-table .op-lex-relation-table.)) | |
| 108 | 108 | (let ((ent (get-op-relation op order))) |
| 109 | 109 | (unless ent |
| 110 | 110 | (add-op-relation-to-order (make-op-relation op nil nil) order)))) |
| 113 | 113 | ;;; adds the op-relation to operator-relation-table |
| 114 | 114 | ;;; |
| 115 | 115 | (defun gather-op-relations-from-order (relation |
| 116 | &optional | |
| 117 | (order .op-lex-relation-table.)) | |
| 116 | &optional | |
| 117 | (order .op-lex-relation-table.)) | |
| 118 | 118 | (declare (type list relation) |
| 119 | (type hash-table .op-lex-relation-table.) | |
| 120 | (values list)) | |
| 119 | (type hash-table .op-lex-relation-table.) | |
| 120 | (values list)) | |
| 121 | 121 | (macrolet ((pushnew-relation (__?rel __?res) |
| 122 | ` (pushnew ,__?rel ,__?res :test #'eq))) | |
| 122 | ` (pushnew ,__?rel ,__?res :test #'eq))) | |
| 123 | 123 | (let ((res nil) |
| 124 | (op (op-relation-op relation)) | |
| 125 | (subs (_subops relation)) | |
| 126 | (sups (_superops relation))) | |
| 124 | (op (op-relation-op relation)) | |
| 125 | (subs (_subops relation)) | |
| 126 | (sups (_superops relation))) | |
| 127 | 127 | (pushnew-relation (get-op-relation op order) res) |
| 128 | 128 | (dolist (lops subs) |
| 129 | (pushnew-relation (get-op-relation lops order) res)) | |
| 129 | (pushnew-relation (get-op-relation lops order) res)) | |
| 130 | 130 | (dolist (gops sups) |
| 131 | (pushnew-relation (get-op-relation gops order) res)) | |
| 131 | (pushnew-relation (get-op-relation gops order) res)) | |
| 132 | 132 | res))) |
| 133 | 133 | |
| 134 | 134 | (defun add-op-relation-to-order (op-relation |
| 135 | &optional (order .op-lex-relation-table.)) | |
| 135 | &optional (order .op-lex-relation-table.)) | |
| 136 | 136 | (let* ((op (op-relation-op op-relation)) |
| 137 | (subs (_subops op-relation)) | |
| 138 | (supers (_superops op-relation))) | |
| 137 | (subs (_subops op-relation)) | |
| 138 | (supers (_superops op-relation))) | |
| 139 | 139 | (macrolet ((ls-union (_s _ls) |
| 140 | ` (let ((..sl (get-op-relation ,_s order))) | |
| 141 | (pushnew ,_ls (_subops ..sl) :test #'eq))) | |
| 142 | (gs-union (_s _gs) | |
| 143 | ` (let ((..sl (get-op-relation ,_s order))) | |
| 144 | (pushnew ,_gs (_superops ..sl) :test #'eq)))) | |
| 140 | ` (let ((..sl (get-op-relation ,_s order))) | |
| 141 | (pushnew ,_ls (_subops ..sl) :test #'eq))) | |
| 142 | (gs-union (_s _gs) | |
| 143 | ` (let ((..sl (get-op-relation ,_s order))) | |
| 144 | (pushnew ,_gs (_superops ..sl) :test #'eq)))) | |
| 145 | 145 | ;; merge new realtion |
| 146 | 146 | (let ((o-op-rel (get-op-relation op order))) |
| 147 | (if o-op-rel | |
| 148 | (progn | |
| 149 | (setf (_subops o-op-rel) | |
| 150 | (union subs (_subops o-op-rel) :test #'eq)) | |
| 151 | (setf (_superops o-op-rel) | |
| 152 | (union supers (_superops o-op-rel) :test #'eq))) | |
| 153 | (progn | |
| 154 | (setf (get-op-relation op order) op-relation) | |
| 155 | (setf o-op-rel op-relation | |
| 156 | subs (_subops op-relation) | |
| 157 | supers (_superops op-relation))))) | |
| 147 | (if o-op-rel | |
| 148 | (progn | |
| 149 | (setf (_subops o-op-rel) | |
| 150 | (union subs (_subops o-op-rel) :test #'eq)) | |
| 151 | (setf (_superops o-op-rel) | |
| 152 | (union supers (_superops o-op-rel) :test #'eq))) | |
| 153 | (progn | |
| 154 | (setf (get-op-relation op order) op-relation) | |
| 155 | (setf o-op-rel op-relation | |
| 156 | subs (_subops op-relation) | |
| 157 | supers (_superops op-relation))))) | |
| 158 | 158 | ;; we must gather relations which can be affected by new relation, |
| 159 | 159 | ;; then compute transitive relations among them. |
| 160 | 160 | (let ((rels (gather-op-relations-from-order op-relation order))) |
| 161 | (declare (type list rels)) | |
| 162 | (dolist (sl rels) | |
| 163 | (let ((nsubs (_subops sl)) | |
| 164 | (nsups (_superops sl))) | |
| 165 | (declare (type list nsubs nsups)) | |
| 166 | (dolist (s1 nsubs) | |
| 167 | (dolist (s2 nsups) | |
| 168 | (ls-union s2 s1) | |
| 169 | (gs-union s1 s2)))))) | |
| 161 | (declare (type list rels)) | |
| 162 | (dolist (sl rels) | |
| 163 | (let ((nsubs (_subops sl)) | |
| 164 | (nsups (_superops sl))) | |
| 165 | (declare (type list nsubs nsups)) | |
| 166 | (dolist (s1 nsubs) | |
| 167 | (dolist (s2 nsups) | |
| 168 | (ls-union s2 s1) | |
| 169 | (gs-union s1 s2)))))) | |
| 170 | 170 | order))) |
| 171 | 171 | |
| 172 | 172 | ;;; MAKE-OP-REC-RELATIONS |
| 175 | 175 | (declare (type module module)) |
| 176 | 176 | (clrhash .op-lex-relation-table.) |
| 177 | 177 | (let ((axs (module-all-equations module)) |
| 178 | (opinfos (module-all-operators module)) | |
| 179 | ;; (ordered nil) | |
| 180 | (num-ops 0) | |
| 181 | ) | |
| 178 | (opinfos (module-all-operators module)) | |
| 179 | ;; (ordered nil) | |
| 180 | (num-ops 0) | |
| 181 | ) | |
| 182 | 182 | (declare (type fixnum num-ops)) |
| 183 | 183 | (dolist (opinfo opinfos) |
| 184 | 184 | (dolist (m (opinfo-methods opinfo)) |
| 185 | (add-op-to-order m) | |
| 186 | (incf num-ops))) | |
| 185 | (add-op-to-order m) | |
| 186 | (incf num-ops))) | |
| 187 | 187 | (dolist (ax axs) |
| 188 | 188 | (block next |
| 189 | (let ((lhs (axiom-lhs ax)) | |
| 190 | (rhs (axiom-rhs ax)) | |
| 191 | (cond (axiom-condition ax))) | |
| 192 | ;; | |
| 193 | (unless (and (is-true? cond) | |
| 194 | (term-is-application-form? rhs) | |
| 195 | (not (rule-is-builtin ax))) | |
| 196 | (return-from next nil)) | |
| 197 | ;; | |
| 198 | (let ((meth1 (term-head lhs)) | |
| 199 | ;; (meth2 (term-head rhs)) | |
| 200 | ;; (rhs-methods (term-sub-operators rhs)) | |
| 201 | (rhs-methods (term-operators rhs))) | |
| 202 | ;; | |
| 203 | (setq rhs-methods (delete meth1 rhs-methods)) | |
| 204 | ;; | |
| 205 | (let ((rel1 (make-op-relation meth1 rhs-methods))) | |
| 206 | (add-op-relation-to-order rel1)) | |
| 207 | (dolist (lower rhs-methods) | |
| 208 | (let ((rel2 (make-op-relation lower nil (list meth1)))) | |
| 209 | (add-op-relation-to-order rel2))) | |
| 210 | )))) | |
| 189 | (let ((lhs (axiom-lhs ax)) | |
| 190 | (rhs (axiom-rhs ax)) | |
| 191 | (cond (axiom-condition ax))) | |
| 192 | ;; | |
| 193 | (unless (and (is-true? cond) | |
| 194 | (term-is-application-form? rhs) | |
| 195 | (not (rule-is-builtin ax))) | |
| 196 | (return-from next nil)) | |
| 197 | ;; | |
| 198 | (let ((meth1 (term-head lhs)) | |
| 199 | ;; (meth2 (term-head rhs)) | |
| 200 | ;; (rhs-methods (term-sub-operators rhs)) | |
| 201 | (rhs-methods (term-operators rhs))) | |
| 202 | ;; | |
| 203 | (setq rhs-methods (delete meth1 rhs-methods)) | |
| 204 | ;; | |
| 205 | (let ((rel1 (make-op-relation meth1 rhs-methods))) | |
| 206 | (add-op-relation-to-order rel1)) | |
| 207 | (dolist (lower rhs-methods) | |
| 208 | (let ((rel2 (make-op-relation lower nil (list meth1)))) | |
| 209 | (add-op-relation-to-order rel2))) | |
| 210 | )))) | |
| 211 | 211 | ;; check cyclicity |
| 212 | 212 | (let ((err-p nil)) |
| 213 | 213 | (maphash #'(lambda (op op-relation) |
| 214 | (when (memq op (_subops op-relation)) | |
| 215 | (with-output-chaos-warning () | |
| 216 | (princ "cycle in operator lexical ordering: ") | |
| 217 | (princ (method-name op))) | |
| 218 | (setq err-p t))) | |
| 219 | .op-lex-relation-table.) | |
| 214 | (when (memq op (_subops op-relation)) | |
| 215 | (with-output-chaos-warning () | |
| 216 | (princ "cycle in operator lexical ordering: ") | |
| 217 | (princ (method-name op))) | |
| 218 | (setq err-p t))) | |
| 219 | .op-lex-relation-table.) | |
| 220 | 220 | (when err-p |
| 221 | (with-output-chaos-warning () | |
| 222 | (princ "failed to construct operator lexical orderings.")))) | |
| 221 | (with-output-chaos-warning () | |
| 222 | (princ "failed to construct operator lexical orderings.")))) | |
| 223 | 223 | ;; |
| 224 | 224 | (when *debug-op-relation* |
| 225 | 225 | (dump-op-lex-relation-table)) |
| 235 | 235 | (defun dump-op-lex-table () |
| 236 | 236 | (let ((entries nil)) |
| 237 | 237 | (maphash #'(lambda (x y) |
| 238 | (push (cons x y) entries)) | |
| 239 | .op-lex-prec-table.) | |
| 238 | (push (cons x y) entries)) | |
| 239 | .op-lex-prec-table.) | |
| 240 | 240 | (setq entries (sort entries |
| 241 | #'(lambda (x y) | |
| 242 | (< (cdr x) (cdr y))))) | |
| 241 | #'(lambda (x y) | |
| 242 | (< (cdr x) (cdr y))))) | |
| 243 | 243 | (dolist (e entries) |
| 244 | 244 | (format t "~%meth ~s, prec = ~s" (car e) (cdr e))) |
| 245 | 245 | )) |
| 246 | 246 | |
| 247 | 247 | (defun op-lex-compare (m1 m2) |
| 248 | 248 | (declare (type method m1 m2) |
| 249 | (values symbol)) | |
| 249 | (values symbol)) | |
| 250 | 250 | (flet ((compare-lex (name1 name2) |
| 251 | (declare (type list name1 name2)) | |
| 252 | (let ((n1 (reduce #'(lambda (x y) | |
| 253 | (concatenate 'string x y)) | |
| 254 | name1)) | |
| 255 | (n2 (reduce #'(lambda (x y) | |
| 256 | (concatenate 'string x y)) | |
| 257 | name2))) | |
| 258 | (declare (type simple-string n1 n2)) | |
| 259 | (if (string< n1 n2) | |
| 260 | :less | |
| 261 | (if (string= n1 n2) | |
| 262 | :same | |
| 263 | :greater))))) | |
| 251 | (declare (type list name1 name2)) | |
| 252 | (let ((n1 (reduce #'(lambda (x y) | |
| 253 | (concatenate 'string x y)) | |
| 254 | name1)) | |
| 255 | (n2 (reduce #'(lambda (x y) | |
| 256 | (concatenate 'string x y)) | |
| 257 | name2))) | |
| 258 | (declare (type simple-string n1 n2)) | |
| 259 | (if (string< n1 n2) | |
| 260 | :less | |
| 261 | (if (string= n1 n2) | |
| 262 | :same | |
| 263 | :greater))))) | |
| 264 | 264 | ;; |
| 265 | 265 | (if (op-lex< m1 m2) |
| 266 | :less | |
| 266 | :less | |
| 267 | 267 | (if (op-lex< m2 m1) |
| 268 | :greater | |
| 269 | ;; | |
| 270 | (let* ((l1 (method-name m1)) | |
| 271 | (l2 (method-name m2)) | |
| 272 | (ar1 (cdr l1)) | |
| 273 | (ar2 (cdr l2))) | |
| 274 | (declare (type fixnum ar1 ar2) | |
| 275 | (type list l1 l2)) | |
| 276 | (if (< ar1 ar2) | |
| 277 | (if (= 0 ar1) | |
| 278 | :less ; m1 is constant | |
| 279 | (compare-lex (car l1) (car l2))) | |
| 280 | (if (= ar1 ar2) | |
| 281 | (compare-lex (car l1) (car l2)) | |
| 282 | ;; ar1 > ar2 | |
| 283 | (if (= 0 ar2) ; m2 is constant | |
| 284 | :greater | |
| 285 | (compare-lex (car l1) (car l2)))))) | |
| 286 | )))) | |
| 268 | :greater | |
| 269 | ;; | |
| 270 | (let* ((l1 (method-name m1)) | |
| 271 | (l2 (method-name m2)) | |
| 272 | (ar1 (cdr l1)) | |
| 273 | (ar2 (cdr l2))) | |
| 274 | (declare (type fixnum ar1 ar2) | |
| 275 | (type list l1 l2)) | |
| 276 | (if (< ar1 ar2) | |
| 277 | (if (= 0 ar1) | |
| 278 | :less ; m1 is constant | |
| 279 | (compare-lex (car l1) (car l2))) | |
| 280 | (if (= ar1 ar2) | |
| 281 | (compare-lex (car l1) (car l2)) | |
| 282 | ;; ar1 > ar2 | |
| 283 | (if (= 0 ar2) ; m2 is constant | |
| 284 | :greater | |
| 285 | (compare-lex (car l1) (car l2)))))) | |
| 286 | )))) | |
| 287 | 287 | |
| 288 | 288 | ;;; METHOD-LEX-PREC |
| 289 | 289 | ;;; |
| 305 | 305 | (defun order-lex-op (m1 m2) |
| 306 | 306 | (declare (type method m1 m2)) |
| 307 | 307 | (labels ((compare-lex (name1 name2) |
| 308 | (declare (type list name1 name2)) | |
| 309 | (let ((n1 (reduce #'(lambda (x y) | |
| 310 | (concatenate 'string x y)) | |
| 311 | name1)) | |
| 312 | (n2 (reduce #'(lambda (x y) | |
| 313 | (concatenate 'string x y)) | |
| 314 | name2))) | |
| 315 | (declare (type simple-string n1 n2)) | |
| 316 | (if (string< n1 n2) | |
| 317 | :less | |
| 318 | (if (string= n1 n2) | |
| 319 | :same | |
| 320 | :greater)))) | |
| 321 | (order-op () | |
| 322 | (let* ((l1 (method-name m1)) | |
| 323 | (l2 (method-name m2)) | |
| 324 | (ar1 (cdr l1)) | |
| 325 | (ar2 (cdr l2))) | |
| 326 | (declare (type fixnum ar1 ar2) | |
| 327 | (type list l1 l2)) | |
| 328 | (if (< ar1 ar2) | |
| 329 | (if (= 0 ar1) | |
| 330 | :less ; m1 is constant | |
| 331 | (compare-lex (car l1) (car l2))) | |
| 332 | (if (= ar1 ar2) | |
| 333 | (compare-lex (car l1) (car l2)) | |
| 334 | ;; ar1 > ar2 | |
| 335 | (if (= 0 ar2) ; m2 is constant | |
| 336 | :greater | |
| 337 | (compare-lex (car l1) (car l2)))))) | |
| 338 | )) | |
| 308 | (declare (type list name1 name2)) | |
| 309 | (let ((n1 (reduce #'(lambda (x y) | |
| 310 | (concatenate 'string x y)) | |
| 311 | name1)) | |
| 312 | (n2 (reduce #'(lambda (x y) | |
| 313 | (concatenate 'string x y)) | |
| 314 | name2))) | |
| 315 | (declare (type simple-string n1 n2)) | |
| 316 | (if (string< n1 n2) | |
| 317 | :less | |
| 318 | (if (string= n1 n2) | |
| 319 | :same | |
| 320 | :greater)))) | |
| 321 | (order-op () | |
| 322 | (let* ((l1 (method-name m1)) | |
| 323 | (l2 (method-name m2)) | |
| 324 | (ar1 (cdr l1)) | |
| 325 | (ar2 (cdr l2))) | |
| 326 | (declare (type fixnum ar1 ar2) | |
| 327 | (type list l1 l2)) | |
| 328 | (if (< ar1 ar2) | |
| 329 | (if (= 0 ar1) | |
| 330 | :less ; m1 is constant | |
| 331 | (compare-lex (car l1) (car l2))) | |
| 332 | (if (= ar1 ar2) | |
| 333 | (compare-lex (car l1) (car l2)) | |
| 334 | ;; ar1 > ar2 | |
| 335 | (if (= 0 ar2) ; m2 is constant | |
| 336 | :greater | |
| 337 | (compare-lex (car l1) (car l2)))))) | |
| 338 | )) | |
| 339 | 339 | ;; |
| 340 | 340 | (let ((cmp (order-op))) |
| 341 | 341 | (declare (type symbol cmp)) |
| 342 | 342 | (if (eq cmp :less) |
| 343 | t | |
| 344 | (if (eq cmp :greater) | |
| 345 | nil | |
| 346 | (sort< (method-coarity m1) (method-coarity m2) | |
| 347 | *current-sort-order*))))) | |
| 343 | t | |
| 344 | (if (eq cmp :greater) | |
| 345 | nil | |
| 346 | (sort< (method-coarity m1) (method-coarity m2) | |
| 347 | *current-sort-order*))))) | |
| 348 | 348 | ) |
| 349 | 349 | |
| 350 | 350 | (defun make-lexical-prec-table (module &optional (pre-ordered nil)) |
| 351 | 351 | (declare (type module module) |
| 352 | (type list pre-ordered)) | |
| 352 | (type list pre-ordered)) | |
| 353 | 353 | (clrhash .op-lex-prec-table.) |
| 354 | 354 | (let ((opinfos (module-all-operators module)) |
| 355 | (mlist nil)) | |
| 355 | (mlist nil)) | |
| 356 | 356 | (with-in-module (module) |
| 357 | 357 | (unless pre-ordered |
| 358 | (setq pre-ordered '(:* :skolem))) | |
| 358 | (setq pre-ordered '(:* :skolem))) | |
| 359 | 359 | (dolist (opinfo opinfos) |
| 360 | (dolist (m (opinfo-methods opinfo)) | |
| 361 | (push m mlist))) | |
| 360 | (dolist (m (opinfo-methods opinfo)) | |
| 361 | (push m mlist))) | |
| 362 | 362 | (setq mlist (sort mlist #'order-lex-op)) |
| 363 | 363 | ;; |
| 364 | 364 | (do* ((i 1) |
| 365 | (ml pre-ordered (cdr ml)) | |
| 366 | (meth (car ml) (car ml))) | |
| 367 | ((endp ml)) | |
| 368 | (declare (type fixnum i)) | |
| 369 | (cond ((eq meth :*) | |
| 370 | (do ((ml mlist (cdr ml))) | |
| 371 | ((null ml)) | |
| 372 | (unless (method-lex-prec (car ml)) | |
| 373 | (setf (method-lex-prec (car ml)) (the fixnum (* 2 i))) | |
| 374 | (incf i)))) | |
| 375 | (t (setf (method-lex-prec meth) | |
| 376 | (the fixnum (* 2 i))) | |
| 377 | (incf i))) | |
| 378 | )) | |
| 365 | (ml pre-ordered (cdr ml)) | |
| 366 | (meth (car ml) (car ml))) | |
| 367 | ((endp ml)) | |
| 368 | (declare (type fixnum i)) | |
| 369 | (cond ((eq meth :*) | |
| 370 | (do ((ml mlist (cdr ml))) | |
| 371 | ((null ml)) | |
| 372 | (unless (method-lex-prec (car ml)) | |
| 373 | (setf (method-lex-prec (car ml)) (the fixnum (* 2 i))) | |
| 374 | (incf i)))) | |
| 375 | (t (setf (method-lex-prec meth) | |
| 376 | (the fixnum (* 2 i))) | |
| 377 | (incf i))) | |
| 378 | )) | |
| 379 | 379 | ;; |
| 380 | 380 | (when *debug-op-relation* |
| 381 | 381 | (dump-op-lex-table)) |
| 396 | 396 | #|| |
| 397 | 397 | (defun op-lex-precedence (meth1 meth2) |
| 398 | 398 | (declare (type method meth1 meth2) |
| 399 | (values symbol)) | |
| 399 | (values symbol)) | |
| 400 | 400 | (when (method-w= meth1 meth2) |
| 401 | 401 | (return-from op-lex-precedence :same)) |
| 402 | 402 | (if (and (method-is-constructor? meth1) |
| 403 | (not (method-is-constructor? meth2))) | |
| 403 | (not (method-is-constructor? meth2))) | |
| 404 | 404 | :less |
| 405 | 405 | (if (and (not (method-is-constructor? meth1)) |
| 406 | (method-is-constructor? meth2)) | |
| 407 | :greater | |
| 406 | (method-is-constructor? meth2)) | |
| 407 | :greater | |
| 408 | 408 | (if (op-lex-compare meth1 meth2) |
| 409 | :less | |
| 410 | (if (op-lex-compare meth2 meth1) | |
| 411 | :greater | |
| 412 | (let ((p1 (method-lex-prec meth1)) | |
| 413 | (p2 (method-lex-prec meth2))) | |
| 414 | (declare (type fixnum p1 p2)) | |
| 415 | (if (> p1 p2) | |
| 416 | :greater | |
| 417 | (if (< p1 p2) | |
| 418 | :less | |
| 419 | :same))))))) | |
| 409 | :less | |
| 410 | (if (op-lex-compare meth2 meth1) | |
| 411 | :greater | |
| 412 | (let ((p1 (method-lex-prec meth1)) | |
| 413 | (p2 (method-lex-prec meth2))) | |
| 414 | (declare (type fixnum p1 p2)) | |
| 415 | (if (> p1 p2) | |
| 416 | :greater | |
| 417 | (if (< p1 p2) | |
| 418 | :less | |
| 419 | :same))))))) | |
| 420 | 420 | ) |
| 421 | 421 | ||# |
| 422 | 422 | |
| 423 | 423 | (defun op-lex-precedence (meth1 meth2) |
| 424 | 424 | (declare (type method meth1 meth2) |
| 425 | (values symbol)) | |
| 425 | (values symbol)) | |
| 426 | 426 | (when (method-w= meth1 meth2) |
| 427 | 427 | (return-from op-lex-precedence :same)) |
| 428 | 428 | (if (and (method-is-constructor? meth1) |
| 429 | (not (method-is-constructor? meth2))) | |
| 429 | (not (method-is-constructor? meth2))) | |
| 430 | 430 | :less |
| 431 | 431 | (if (and (not (method-is-constructor? meth1)) |
| 432 | (method-is-constructor? meth2)) | |
| 433 | :greater | |
| 432 | (method-is-constructor? meth2)) | |
| 433 | :greater | |
| 434 | 434 | (op-lex-compare meth1 meth2)))) |
| 435 | 435 | |
| 436 | 436 | ;;; TERM-WEIGHT |
| 437 | 437 | ;;; |
| 438 | 438 | (defun term-weight (term) |
| 439 | 439 | (declare (type term term) |
| 440 | (values fixnum)) | |
| 440 | (values fixnum)) | |
| 441 | 441 | ;; must check answer also : TODO |
| 442 | 442 | (cond ((term-is-variable? term) 1) |
| 443 | ((term-is-lisp-form? term) 1) | |
| 444 | ((term-is-builtin-constant? term) 1) | |
| 445 | ((and (term-is-atom? term) | |
| 446 | (null (term-subterms term))) | |
| 447 | 1) | |
| 448 | (t (let ( | |
| 449 | #|| | |
| 450 | (max (if (term-is-atom? term) | |
| 451 | (pn-flag atom-wt-max-args) | |
| 452 | (pn-flag term-wt-max-args))) | |
| 453 | ||# | |
| 454 | (wt 0)) | |
| 455 | (declare (type fixnum wt)) | |
| 456 | (dolist (sub (term-subterms term)) | |
| 457 | (let ((w1 (term-weight sub))) | |
| 458 | (declare (type fixnum w1)) | |
| 459 | #|| | |
| 460 | (if max | |
| 461 | (when (> w1 wt) | |
| 462 | (setq wt w1)) | |
| 463 | (incf wt w1)) | |
| 464 | ||# | |
| 465 | (incf wt w1) | |
| 466 | )) | |
| 467 | (1+ wt))))) | |
| 443 | ((term-is-lisp-form? term) 1) | |
| 444 | ((term-is-builtin-constant? term) 1) | |
| 445 | ((and (term-is-atom? term) | |
| 446 | (null (term-subterms term))) | |
| 447 | 1) | |
| 448 | (t (let ( | |
| 449 | #|| | |
| 450 | (max (if (term-is-atom? term) | |
| 451 | (pn-flag atom-wt-max-args) | |
| 452 | (pn-flag term-wt-max-args))) | |
| 453 | ||# | |
| 454 | (wt 0)) | |
| 455 | (declare (type fixnum wt)) | |
| 456 | (dolist (sub (term-subterms term)) | |
| 457 | (let ((w1 (term-weight sub))) | |
| 458 | (declare (type fixnum w1)) | |
| 459 | #|| | |
| 460 | (if max | |
| 461 | (when (> w1 wt) | |
| 462 | (setq wt w1)) | |
| 463 | (incf wt w1)) | |
| 464 | ||# | |
| 465 | (incf wt w1) | |
| 466 | )) | |
| 467 | (1+ wt))))) | |
| 468 | 468 | |
| 469 | 469 | ;;; WEIGHT-LEX-ORDER : TERM1 TERM2 -> {:greater, :less, nil} |
| 470 | 470 | ;;; |
| 471 | 471 | (defun weight-lex-order (t1 t2) |
| 472 | 472 | (declare (type term t1 t2)) |
| 473 | 473 | (let ((i1 (term-weight t1)) |
| 474 | (i2 (term-weight t2))) | |
| 474 | (i2 (term-weight t2))) | |
| 475 | 475 | (declare (type fixnum i1 i2)) |
| 476 | 476 | (if (> i1 i2) |
| 477 | :greater | |
| 477 | :greater | |
| 478 | 478 | (if (< i1 i2) |
| 479 | :less | |
| 480 | (term-lex-order t1 t2))))) | |
| 479 | :less | |
| 480 | (term-lex-order t1 t2))))) | |
| 481 | 481 | |
| 482 | 482 | ;;; TERM-LEX-ORDER : TERM1 TERM2 -> {:greater, :less, nil} |
| 483 | 483 | ;;; |
| 491 | 491 | ;; same sort |
| 492 | 492 | ;; |
| 493 | 493 | (cond ((term-is-variable? t1) |
| 494 | (if (term-is-variable? t2) | |
| 495 | (if (variable-eq t1 t2) | |
| 496 | :same | |
| 497 | nil) ; incomparable | |
| 498 | (if (occurs-in t1 t2) | |
| 499 | :less | |
| 500 | nil))) | |
| 501 | ((term-is-variable? t2) | |
| 502 | (if (occurs-in t2 t1) | |
| 503 | :greater | |
| 504 | nil)) | |
| 505 | ;; | |
| 506 | ((term-is-application-form? t1) | |
| 507 | (if (term-is-application-form? t2) | |
| 508 | (if (method-is-of-same-operator (term-head t1) | |
| 509 | (term-head t2)) | |
| 510 | ;; same op | |
| 511 | (let ((ret-code :same)) | |
| 512 | (do ((t1-sub (term-subterms t1) (cdr t1-sub)) | |
| 513 | (t2-sub (term-subterms t2) (cdr t2-sub))) | |
| 514 | ((or (null t1-sub) | |
| 515 | (not (eq ret-code :same))) | |
| 516 | ret-code) | |
| 517 | (setq ret-code | |
| 518 | (term-lex-order (car t1-sub) (car t2-sub))))) | |
| 519 | ;; different op | |
| 520 | (op-lex-precedence (term-head t1) (term-head t2))) | |
| 521 | )) | |
| 522 | ((term-is-application-form? t2) | |
| 523 | :less) | |
| 524 | (t :greater) | |
| 525 | )) | |
| 494 | (if (term-is-variable? t2) | |
| 495 | (if (variable-eq t1 t2) | |
| 496 | :same | |
| 497 | nil) ; incomparable | |
| 498 | (if (occurs-in t1 t2) | |
| 499 | :less | |
| 500 | nil))) | |
| 501 | ((term-is-variable? t2) | |
| 502 | (if (occurs-in t2 t1) | |
| 503 | :greater | |
| 504 | nil)) | |
| 505 | ;; | |
| 506 | ((term-is-application-form? t1) | |
| 507 | (if (term-is-application-form? t2) | |
| 508 | (if (method-is-of-same-operator (term-head t1) | |
| 509 | (term-head t2)) | |
| 510 | ;; same op | |
| 511 | (let ((ret-code :same)) | |
| 512 | (do ((t1-sub (term-subterms t1) (cdr t1-sub)) | |
| 513 | (t2-sub (term-subterms t2) (cdr t2-sub))) | |
| 514 | ((or (null t1-sub) | |
| 515 | (not (eq ret-code :same))) | |
| 516 | ret-code) | |
| 517 | (setq ret-code | |
| 518 | (term-lex-order (car t1-sub) (car t2-sub))))) | |
| 519 | ;; different op | |
| 520 | (op-lex-precedence (term-head t1) (term-head t2))) | |
| 521 | )) | |
| 522 | ((term-is-application-form? t2) | |
| 523 | :less) | |
| 524 | (t :greater) | |
| 525 | )) | |
| 526 | 526 | |
| 527 | 527 | (defun term-lex-order-vars (t1 t2) |
| 528 | 528 | (declare (type term t1 t2)) |
| 533 | 533 | ;; same sort |
| 534 | 534 | (if (term-is-variable? t1) |
| 535 | 535 | (if (term-is-variable? t2) |
| 536 | (if (variable-eq t1 t2) | |
| 537 | :same | |
| 538 | ;; NOTE*!! | |
| 539 | (let ((vn1 (variable-name t1)) | |
| 540 | (vn2 (variable-name t2))) | |
| 541 | (if (< vn2 vn1) | |
| 542 | :greater | |
| 543 | :less))) | |
| 544 | :less) | |
| 536 | (if (variable-eq t1 t2) | |
| 537 | :same | |
| 538 | ;; NOTE*!! | |
| 539 | (let ((vn1 (variable-name t1)) | |
| 540 | (vn2 (variable-name t2))) | |
| 541 | (if (< vn2 vn1) | |
| 542 | :greater | |
| 543 | :less))) | |
| 544 | :less) | |
| 545 | 545 | (if (term-is-variable? t2) |
| 546 | :greater | |
| 546 | :greater | |
| 547 | 547 | (if (term-is-application-form? t1) |
| 548 | (if (term-is-application-form? t2) | |
| 549 | (if (method-is-of-same-operator (term-head t1) | |
| 550 | (term-head t2)) | |
| 551 | ;; same op | |
| 552 | (let ((ret-code :same)) | |
| 553 | (do ((t1-sub (term-subterms t1) (cdr t1-sub)) | |
| 554 | (t2-sub (term-subterms t2) (cdr t2-sub))) | |
| 555 | ((or (null t1-sub) | |
| 556 | (not (eq ret-code :same))) | |
| 557 | ret-code) | |
| 558 | (setq ret-code | |
| 559 | (term-lex-order-vars (car t1-sub) (car t2-sub))) | |
| 560 | )) | |
| 561 | ;; different op | |
| 562 | (op-lex-precedence (term-head t1) (term-head t2))) | |
| 563 | :greater) | |
| 564 | :less)))) | |
| 548 | (if (term-is-application-form? t2) | |
| 549 | (if (method-is-of-same-operator (term-head t1) | |
| 550 | (term-head t2)) | |
| 551 | ;; same op | |
| 552 | (let ((ret-code :same)) | |
| 553 | (do ((t1-sub (term-subterms t1) (cdr t1-sub)) | |
| 554 | (t2-sub (term-subterms t2) (cdr t2-sub))) | |
| 555 | ((or (null t1-sub) | |
| 556 | (not (eq ret-code :same))) | |
| 557 | ret-code) | |
| 558 | (setq ret-code | |
| 559 | (term-lex-order-vars (car t1-sub) (car t2-sub))) | |
| 560 | )) | |
| 561 | ;; different op | |
| 562 | (op-lex-precedence (term-head t1) (term-head t2))) | |
| 563 | :greater) | |
| 564 | :less)))) | |
| 565 | 565 | |
| 566 | 566 | |
| 567 | 567 | ;;; LEX-CHECK : t1 t2 -> Bool |
| 568 | 568 | ;;; |
| 569 | 569 | (defun lex-check (term1 term2) |
| 570 | 570 | (declare (type term term1 term2) |
| 571 | (inline term-lex-order-vars) | |
| 572 | (inline term-lex-order)) | |
| 571 | (inline term-lex-order-vars) | |
| 572 | (inline term-lex-order)) | |
| 573 | 573 | (if (pn-flag lex-order-vars) |
| 574 | 574 | (term-lex-order-vars term1 term2) |
| 575 | 575 | (term-lex-order term1 term2))) |
| 582 | 582 | ;;; |
| 583 | 583 | (defun order-literal (lit input?) |
| 584 | 584 | (let* ((eq (literal-atom lit)) |
| 585 | (alpha (term-arg-1 eq)) | |
| 586 | (beta (term-arg-2 eq))) | |
| 585 | (alpha (term-arg-1 eq)) | |
| 586 | (beta (term-arg-2 eq))) | |
| 587 | 587 | (declare (type term eq alpha beta)) |
| 588 | 588 | (and (not (term-is-identical alpha beta)) |
| 589 | (let ((alpha-bigger nil) | |
| 590 | (beta-bigger nil)) | |
| 591 | #|| | |
| 592 | (if (and (pn-flag symbol-elim) | |
| 593 | (sym-elim alpha beta)) | |
| 594 | (setq alpha-bigger t) | |
| 595 | (if (and (pn-flag symbol-elim) | |
| 596 | (sym-elim beta alpha)) | |
| 597 | (setq beta-bigger t) | |
| 598 | (if (term-occurs-in beta alpha) | |
| 599 | (setq alpha-bigger t) | |
| 600 | (if (term-occurs-in alpha beta) | |
| 601 | (setq beta-bigger t) | |
| 602 | (let ((rc (weight-lex-order alpha beta))) | |
| 603 | (if (eq rc :greater) | |
| 604 | (setq alpha-bigger t) | |
| 605 | (if (eq rc :less) | |
| 606 | (setq beta-bigger t)))))))) | |
| 607 | ||# | |
| 608 | (if (or input? (term-occurs-in beta alpha)) | |
| 609 | (setq alpha-bigger t) | |
| 610 | (if (term-occurs-in alpha beta) | |
| 611 | (setq beta-bigger t) | |
| 612 | (let ((rc (weight-lex-order alpha beta))) | |
| 613 | (if (eq rc :greater) | |
| 614 | (setq alpha-bigger t) | |
| 615 | (if (eq rc :less) | |
| 616 | (setq beta-bigger t)))))) | |
| 617 | ;; | |
| 618 | (when (or alpha-bigger beta-bigger) | |
| 619 | (when beta-bigger | |
| 620 | (let ((new-atom | |
| 621 | (make-term-with-sort-check *fopl-eq* | |
| 622 | (list beta alpha)))) | |
| 623 | (declare (type term new-atom)) | |
| 624 | (setf (literal-atom lit) new-atom) | |
| 625 | (set-bit (literal-stat-bits lit) | |
| 626 | scratch-bit))) | |
| 627 | (set-bit (literal-stat-bits lit) | |
| 628 | oriented-eq-bit)) | |
| 629 | )))) | |
| 589 | (let ((alpha-bigger nil) | |
| 590 | (beta-bigger nil)) | |
| 591 | #|| | |
| 592 | (if (and (pn-flag symbol-elim) | |
| 593 | (sym-elim alpha beta)) | |
| 594 | (setq alpha-bigger t) | |
| 595 | (if (and (pn-flag symbol-elim) | |
| 596 | (sym-elim beta alpha)) | |
| 597 | (setq beta-bigger t) | |
| 598 | (if (term-occurs-in beta alpha) | |
| 599 | (setq alpha-bigger t) | |
| 600 | (if (term-occurs-in alpha beta) | |
| 601 | (setq beta-bigger t) | |
| 602 | (let ((rc (weight-lex-order alpha beta))) | |
| 603 | (if (eq rc :greater) | |
| 604 | (setq alpha-bigger t) | |
| 605 | (if (eq rc :less) | |
| 606 | (setq beta-bigger t)))))))) | |
| 607 | ||# | |
| 608 | (if (or input? (term-occurs-in beta alpha)) | |
| 609 | (setq alpha-bigger t) | |
| 610 | (if (term-occurs-in alpha beta) | |
| 611 | (setq beta-bigger t) | |
| 612 | (let ((rc (weight-lex-order alpha beta))) | |
| 613 | (if (eq rc :greater) | |
| 614 | (setq alpha-bigger t) | |
| 615 | (if (eq rc :less) | |
| 616 | (setq beta-bigger t)))))) | |
| 617 | ;; | |
| 618 | (when (or alpha-bigger beta-bigger) | |
| 619 | (when beta-bigger | |
| 620 | (let ((new-atom | |
| 621 | (make-term-with-sort-check *fopl-eq* | |
| 622 | (list beta alpha)))) | |
| 623 | (declare (type term new-atom)) | |
| 624 | (setf (literal-atom lit) new-atom) | |
| 625 | (set-bit (literal-stat-bits lit) | |
| 626 | scratch-bit))) | |
| 627 | (set-bit (literal-stat-bits lit) | |
| 628 | oriented-eq-bit)) | |
| 629 | )))) | |
| 630 | 630 | |
| 631 | 631 | (defun order-equalities (clause &optional input) |
| 632 | 632 | (declare (type clause clause) |
| 633 | (inline order-literal)) | |
| 633 | (inline order-literal)) | |
| 634 | 634 | (dolist (lit (clause-literals clause)) |
| 635 | 635 | (when (eq-literal? lit) |
| 636 | 636 | (order-literal lit input)))) |
| 643 | 643 | (defun sym-elim (alpha beta) |
| 644 | 644 | (declare (type term alpha beta)) |
| 645 | 645 | (cond ((or (term-is-variable? alpha) |
| 646 | (term-is-builtin-constant? alpha) | |
| 647 | (term-is-lisp-form? alpha)) | |
| 648 | (return-from sym-elim nil)) | |
| 649 | (t (return-from sym-elim | |
| 650 | (and (operator-occurs-in (term-head alpha) | |
| 651 | beta) | |
| 652 | (var-subset beta alpha)))))) | |
| 646 | (term-is-builtin-constant? alpha) | |
| 647 | (term-is-lisp-form? alpha)) | |
| 648 | (return-from sym-elim nil)) | |
| 649 | (t (return-from sym-elim | |
| 650 | (and (operator-occurs-in (term-head alpha) | |
| 651 | beta) | |
| 652 | (var-subset beta alpha)))))) | |
| 653 | 653 | |
| 654 | 654 | ;;; VAR-SUBSET : TERM1 TERM2 -> Bool |
| 655 | 655 | ;;; t iff vars(t1) is a subset of vars(t2). |
| 657 | 657 | (defun var-subset (t1 t2) |
| 658 | 658 | (declare (type term t1 t2)) |
| 659 | 659 | (let ((v1 (term-variables t1)) |
| 660 | (v2 (term-variables t2))) | |
| 660 | (v2 (term-variables t2))) | |
| 661 | 661 | (declare (type list v1 v2)) |
| 662 | 662 | (subsetp v1 v2))) |
| 663 | 663 | |
| 667 | 667 | (declare (type term t1 t2)) |
| 668 | 668 | (or (term-eq t1 t2) |
| 669 | 669 | (and (term-type-eq t1 t2) |
| 670 | (cond ((term-is-variable? t1) t) | |
| 671 | ((term-is-application-form? t1) | |
| 672 | (if (method-w= (term-head t1) (term-head t2)) | |
| 673 | (let ((subs1 (term-subterms t1)) | |
| 674 | (subs2 (term-subterms t2))) | |
| 675 | (loop | |
| 676 | (when (null subs1) (return t)) | |
| 677 | (unless (term-ident-x-vars (car subs1) | |
| 678 | (car subs2)) | |
| 679 | (return nil)) | |
| 680 | (setq subs1 (cdr subs1) | |
| 681 | subs2 (cdr subs2)))) | |
| 682 | nil)) | |
| 683 | ((term-is-builtin-constant? t1) | |
| 684 | (term-builtin-equal t1 t2)) | |
| 685 | ((term-is-lisp-form? t1) | |
| 686 | (and (term-is-lisp-form? t2) | |
| 687 | (equal (lisp-form-original-form t1) | |
| 688 | (lisp-form-original-form t2)))) | |
| 689 | (t nil))))) | |
| 670 | (cond ((term-is-variable? t1) t) | |
| 671 | ((term-is-application-form? t1) | |
| 672 | (if (method-w= (term-head t1) (term-head t2)) | |
| 673 | (let ((subs1 (term-subterms t1)) | |
| 674 | (subs2 (term-subterms t2))) | |
| 675 | (loop | |
| 676 | (when (null subs1) (return t)) | |
| 677 | (unless (term-ident-x-vars (car subs1) | |
| 678 | (car subs2)) | |
| 679 | (return nil)) | |
| 680 | (setq subs1 (cdr subs1) | |
| 681 | subs2 (cdr subs2)))) | |
| 682 | nil)) | |
| 683 | ((term-is-builtin-constant? t1) | |
| 684 | (term-builtin-equal t1 t2)) | |
| 685 | ((term-is-lisp-form? t1) | |
| 686 | (and (term-is-lisp-form? t2) | |
| 687 | (equal (lisp-form-original-form t1) | |
| 688 | (lisp-form-original-form t2)))) | |
| 689 | (t nil))))) | |
| 690 | 690 | |
| 691 | 691 | ;;; EOF |
| 6 | 6 | (This is the simplified BSD 2-clause license, |
| 7 | 7 | http://opensource.org/licenses/BSD-2-Clause) |
| 8 | 8 | |
| 9 | Copyright (c) 2000-2014, Toshimi Sawada and contrbutors. All rights reserved. | |
| 9 | Copyright (c) 2000-2015, Toshimi Sawada and contrbutors. All rights reserved. | |
| 10 | 10 | |
| 11 | 11 | Redistribution and use in source and binary forms, with or without |
| 12 | 12 | modification, are permitted provided that the following conditions are met: |
| 0 | 0 | # |
| 1 | # Copyright (c) 2000-2014, Toshimi Sawada. All rights reserved. | |
| 2 | # Copyright (c) 2014, Norbert Preining. All rights reserved. | |
| 1 | # Copyright (c) 2000-2015, Toshimi Sawada. All rights reserved. | |
| 2 | # Copyright (c) 2014-2015, Norbert Preining. All rights reserved. | |
| 3 | 3 | # |
| 4 | 4 | # Redistribution and use in source and binary forms, with or without |
| 5 | 5 | # modification, are permitted provided that the following conditions |
| 179 | 179 | doc/manual/manual.pdf \ |
| 180 | 180 | doc/RefCard/interp.pdf \ |
| 181 | 181 | doc/RefCard/syntax.pdf \ |
| 182 | doc/PigNose/pnguide.pdf | |
| 182 | doc/PigNose/pnguide.pdf \ | |
| 183 | doc/citp-manual/citp.pdf | |
| 183 | 184 | endif |
| 184 | 185 | |
| 185 | 186 | # |
| 275 | 276 | doc/RefCard/interp.pdf \ |
| 276 | 277 | doc/RefCard/syntax.pdf \ |
| 277 | 278 | doc/refman/reference-manual.pdf \ |
| 279 | doc/citp-manual/citp.pdf \ | |
| 278 | 280 | doc/etc/cafe-citp.txt \ |
| 279 | 281 | elisp/cafeobj-mode.el \ |
| 280 | 282 | lib/icons/cafeobj-logo.png \ |
| 295 | 297 | $(MAKE) -C doc/RefCard interp.pdf |
| 296 | 298 | doc/RefCard/syntax.pdf: |
| 297 | 299 | $(MAKE) -C doc/RefCard syntax.pdf |
| 300 | doc/citp-manual/citp.pdf: | |
| 301 | $(MAKE) -C doc/citp-manual citp.pdf | |
| 298 | 302 | |
| 299 | 303 | |
| 300 | 304 | |
| 303 | 307 | -test -f doc/manual/Makefile && $(MAKE) -C doc/manual clean |
| 304 | 308 | -test -f doc/PigNose/Makefile && $(MAKE) -C doc/PigNose clean |
| 305 | 309 | -test -f doc/RefCard/Makefile && $(MAKE) -C doc/RefCard clean |
| 310 | -test -f doc/citp-manual/Makefile && $(MAKE) -C doc/citp-manual clean | |
| 306 | 311 | rm -rf dumps |
| 307 | 312 | rm -f stamp-windows-prepare stamp-windows-build |
| 308 | 313 | rm -f build-stamp |
| 0 | * CafeOBJ 1.5.4 (DEV) | |
| 1 | =============== | |
| 2 | ||
| 3 | - CITP changes | |
| 4 | . new commands :ctf- and :csp- | |
| 5 | . new command :def(ine) to turn :ctf(-) and :csp(-) into proper | |
| 6 | tactics for :apply | |
| 7 | ||
| 0 | 8 | * CafeOBJ 1.5.3 |
| 1 | 9 | =============== |
| 2 | 10 |
| 0 | 0 | CafeOBJ Interpreter |
| 1 | 1 | =================== |
| 2 | *Version 1.5.2* | |
| 3 | 2014-10-08 | |
| 2 | *Version 1.5.3* | |
| 3 | 2015-2-26 | |
| 4 | 4 | |
| 5 | 5 | CafeOBJ is a new generation algebraic specification and programming language. |
| 6 | 6 | As a direct successor of OBJ, it inherits all its features (flexible mix-fix |
| 0 | 20150324 tswd | |
| 1 | ||
| 2 | refactor, over 20 years old codes | |
| 3 | even 20 years a go, the style was already old fashioned. | |
| 4 | (1) many globals to be eliminated | |
| 5 | *memoized-module* ? | |
| 6 | (2) clean up and reorganize modules | |
| 7 | profiler -- new | |
| 8 | context | |
| 9 | (3) many dumplicated/similar code fragments | |
| 10 | much codes have been added in ad hoc manner | |
| 11 | ||
| 12 | 20150317 np | |
| 13 | ||
| 14 | update manual.tex for current interpreter, add/remove options | |
| 15 | ||
| 16 | ship parametrized modules in lib/para/ like | |
| 17 | para/list.cafe | |
| 18 | para/queue.cafe | |
| 19 | para/set.cafe | |
| 20 | so that one can use | |
| 21 | require para/list.cafe | |
| 22 | pr(PARA_LIST(NAT)) | |
| 23 | pr(PARA_SET(NAT)) | |
| 24 | ... | |
| 25 | ||
| 0 | 26 | 20150225 np |
| 1 | 27 | |
| 2 | 28 | we should add a check that a key is not define'd more than once |
| 22 | 48 | --end-toplevel-options <args-to-cafeobj>* |
| 23 | 49 | (Please refer to 3.2.3 Saving Core Image and 3.3 Command Line Options |
| 24 | 50 | of the manual. ) |
| 51 | ||
| 52 | ||
| 0 | 0 | ;;; |
| 1 | ;;; Copyright (c) 2000-2014, Toshimi Sawada. All rights reserved. | |
| 1 | ;;; Copyright (c) 2000-2015, Toshimi Sawada. All rights reserved. | |
| 2 | 2 | ;;; |
| 3 | 3 | ;;; Redistribution and use in source and binary forms, with or without |
| 4 | 4 | ;;; modification, are permitted provided that the following conditions |
| 0 | 0 | ;;;-*- Mode:LISP; Package:CHAOS; Base:10; Syntax:Common-lisp -*- |
| 1 | 1 | ;;; |
| 2 | ;;; Copyright (c) 2000-2014, Toshimi Sawada. All rights reserved. | |
| 2 | ;;; Copyright (c) 2000-2015, Toshimi Sawada. All rights reserved. | |
| 3 | 3 | ;;; |
| 4 | 4 | ;;; Redistribution and use in source and binary forms, with or without |
| 5 | 5 | ;;; modification, are permitted provided that the following conditions |
| 0 | 0 | ;;;-*- Mode:LISP; Package:CHAOS; Base:10; Syntax:Common-lisp -*- |
| 1 | 1 | ;;; |
| 2 | ;;; Copyright (c) 2000-2014, Toshimi Sawada. All rights reserved. | |
| 2 | ;;; Copyright (c) 2000-2015, Toshimi Sawada. All rights reserved. | |
| 3 | 3 | ;;; |
| 4 | 4 | ;;; Redistribution and use in source and binary forms, with or without |
| 5 | 5 | ;;; modification, are permitted provided that the following conditions |
| 50 | 50 | (setq -cafeobj-load-time- (chaos::get-time-string))) |
| 51 | 51 | |
| 52 | 52 | (defun cafeobj-greeting () |
| 53 | ;; (declare (values t)) | |
| 54 | 53 | (unless (or *cafeobj-batch* *cafeobj-no-banner*) |
| 55 | 54 | (let ((*print-pretty* nil)) |
| 56 | ;;(declare (special *print-pretty*)) | |
| 57 | 55 | (fresh-line) |
| 58 | 56 | (terpri) |
| 59 | 57 | (print-centering g_line_1) |
| 90 | 88 | (print-centering "-- Containing PigNose Extensions --") |
| 91 | 89 | (fresh-line) |
| 92 | 90 | ) |
| 93 | (unless *cafeobj-batch* | |
| 91 | (unless (or *cafeobj-batch* *cafeobj-no-banner*) | |
| 94 | 92 | (print-centering "---") |
| 95 | 93 | (fresh-line) |
| 96 | 94 | (print-centering (concatenate |
| 138 | 136 | (with-chaos-top-error () |
| 139 | 137 | (with-chaos-error () |
| 140 | 138 | (cafeobj-init-files))))) |
| 141 | (with-simple-restart (nil "Exit CafeOBJ.") | |
| 142 | (loop | |
| 143 | (with-simple-restart (abort "Return to CafeOBJ Top level.") | |
| 144 | (catch *top-level-tag* | |
| 145 | (process-cafeobj-input) | |
| 146 | (setq quit-flag t)) | |
| 147 | (when quit-flag (return :ok-exit)))))) | |
| 139 | (with-simple-restart (nil "Exit CafeOBJ.") | |
| 140 | (loop | |
| 141 | (with-simple-restart (abort "Return to CafeOBJ Top level.") | |
| 142 | (catch *top-level-tag* | |
| 143 | (process-cafeobj-input) | |
| 144 | (setq quit-flag t)) | |
| 145 | (when quit-flag (return :ok-exit)))))) | |
| 148 | 146 | (format t "[Leaving CafeOBJ]~%"))) |
| 149 | 147 | (finish-output)) |
| 150 | 148 | |
| 184 | 182 | (with-chaos-top-error () |
| 185 | 183 | (with-chaos-error () |
| 186 | 184 | (cafeobj-init-files))))) |
| 187 | (with-simple-restart (nil "Exit CafeOBJ.") | |
| 188 | (loop | |
| 189 | (with-simple-restart (abort "Return to CafeOBJ Top level.") | |
| 190 | (catch *top-level-tag* | |
| 191 | (process-cafeobj-input) | |
| 192 | (setq quit-flag t)) | |
| 193 | (when quit-flag (return :ok-exit)))))) | |
| 194 | (format t "[Leaving CafeOBJ]~%"))) | |
| 185 | (with-simple-restart (nil "Exit CafeOBJ.") | |
| 186 | (loop | |
| 187 | (with-simple-restart (abort "Return to CafeOBJ Top level.") | |
| 188 | (catch *top-level-tag* | |
| 189 | (process-cafeobj-input) | |
| 190 | (setq quit-flag t)) | |
| 191 | (when quit-flag (return :ok-exit)))))) | |
| 192 | (format t "[Leaving CafeOBJ]~%"))) | |
| 195 | 193 | (finish-output) )) |
| 196 | 194 | |
| 197 | 195 | ;;;============================================================================= |
| 276 | 274 | ;; |
| 277 | 275 | (let ((res (catch *top-level-tag* (cafeobj) 'ok-exit))) |
| 278 | 276 | (if (eq res 'ok-exit) |
| 279 | (bye-bye-bye) | |
| 277 | (bye-bye-bye) | |
| 280 | 278 | (progn |
| 281 | (princ "** ERROR") | |
| 282 | (terpri))))) | |
| 279 | (princ "** ERROR") | |
| 280 | (terpri))))) | |
| 283 | 281 | |
| 284 | 282 | #+EXCL |
| 285 | 283 | (eval-when (:execute :load-toplevel) |
| 0 | 0 | ;;;-*- Mode:LISP; Package:CHAOS; Base:10; Syntax:Common-lisp -*- |
| 1 | 1 | ;;; |
| 2 | ;;; Copyright (c) 2000-2014, Toshimi Sawada. All rights reserved. | |
| 2 | ;;; Copyright (c) 2000-2015, Toshimi Sawada. All rights reserved. | |
| 3 | 3 | ;;; |
| 4 | 4 | ;;; Redistribution and use in source and binary forms, with or without |
| 5 | 5 | ;;; modification, are permitted provided that the following conditions |
| 4 | 4 | File: command-top.lisp |
| 5 | 5 | ==============================================================================|# |
| 6 | 6 | ;;; |
| 7 | ;;; Copyright (c) 2000-2014, Toshimi Sawada. All rights reserved. | |
| 7 | ;;; Copyright (c) 2000-2015, Toshimi Sawada. All rights reserved. | |
| 8 | 8 | ;;; |
| 9 | 9 | ;;; Redistribution and use in source and binary forms, with or without |
| 10 | 10 | ;;; modification, are permitted provided that the following conditions |
| 88 | 88 | (setq *cafeobj-initial-prelude-file* nil) |
| 89 | 89 | (let* ((args (get-arg-string)) |
| 90 | 90 | (argc (length args))) |
| 91 | (declare (type list args)) | |
| 91 | (declare (type list args)) | |
| 92 | 92 | (when (< 0 argc) |
| 93 | 93 | (let ((i 0)) |
| 94 | 94 | (while (> argc i) |
| 111 | 111 | (setq *match-debug* t)) |
| 112 | 112 | (("-view-debug") |
| 113 | 113 | (setq *on-view-debug* t)) |
| 114 | (("-h" "-help") | |
| 114 | (("-h" "-help" "--help") | |
| 115 | 115 | (cafeobj-interpreter-help) |
| 116 | 116 | (bye-bye-bye)) |
| 117 | 117 | (("-q") |
| 193 | 193 | (if *cafeobj-initial-prelude-file* |
| 194 | 194 | ;; load specified prelude files |
| 195 | 195 | (progn |
| 196 | (format t "~&-- loading prelude") | |
| 196 | (format t "~%-- loading prelude") | |
| 197 | 197 | ;;(format t "~&-- do `save-system' for creating system prelude pre-loaded.") |
| 198 | 198 | (setq *cafeobj-standard-prelude-path* |
| 199 | 199 | (load-prelude *cafeobj-initial-prelude-file* 'process-cafeobj-input))) |
| 200 | 200 | (unless *cafeobj-standard-prelude-path* |
| 201 | (format t "~&-- loading standard prelude") | |
| 201 | (format t "~%-- loading standard prelude") | |
| 202 | 202 | ;;(format t "~&-- do `save-system' for creating system prelude pre-loaded.") |
| 203 | 203 | (setq *cafeobj-standard-prelude-path* |
| 204 | 204 | (load-prelude "std" 'process-cafeobj-input)))) |
| 205 | 205 | (when *cafeobj-secondary-prelude-file* |
| 206 | (format t "~&-- appending prelude") | |
| 206 | (format t "~%-- appending prelude") | |
| 207 | 207 | (setq *cafeobj-secondary-prelude-path* |
| 208 | 208 | (load-prelude+ *cafeobj-secondary-prelude-file* 'process-cafeobj-input))) |
| 209 | 209 | ;; load site init |
| 233 | 233 | |
| 234 | 234 | ;;; CafeOBJ INTERPRETER TOPLEVEL HELP |
| 235 | 235 | ;;; |
| 236 | (defun print-context-info () | |
| 237 | (let ((cmod (get-context-module t))) | |
| 238 | (cond ((null cmod) | |
| 239 | (format t "~&You are at top level, no context module is set.")) | |
| 240 | (*open-module* | |
| 241 | (format t "~&A module ~a is open. " (get-module-print-name *open-module*)) | |
| 242 | (format t "In addition to toplevel commands,~%you can put any declarations of module constructs.~%") | |
| 243 | (format t "Try typing '?com element' for the list of available constructs.")) | |
| 244 | (t | |
| 245 | (format t "~&Module ~a is set as current module." (get-module-print-name cmod)))))) | |
| 246 | ||
| 247 | (defun print-help-help () | |
| 248 | (format t "~2%** Here are commands for CafeOBJ online help system.~%") | |
| 249 | (format t "'?com [<class>]'~25T Shows available commands classified by <class>,~%") | |
| 250 | (format t "~25T ommiting <classy> shows a list of <class>.~%") | |
| 251 | (format t "'? <name>'~25T Gives the reference manual description of <name>~%") | |
| 252 | (format t "'?ex <name>'~25T Similar to '? <name>', but in this case~%") | |
| 253 | (format t "~25T also shows examples if available.~%") | |
| 254 | (format t "'?ap <term> [<term>] ...'~25TSearches all available online docs for the terms passed,~%") | |
| 255 | (format t "~25T type '? ?ap' for more detailed descriptions.~%") | |
| 256 | (format t "** Typing 'com' will show the list of major toplevel commands.~%") | |
| 257 | (format t "** URL 'http://cafeobj.org' privides anything you want to know about CafeOBJ.")) | |
| 258 | ||
| 236 | 259 | (defun cafeobj-top-level-help (&optional com) |
| 237 | 260 | (cond ((null (cdr com)) |
| 238 | (format t "~&-- CafeOBJ top level commands :") | |
| 239 | (format t "~&-- Top level definitional forms include `module'(object, theory), ~%-- `view', and `make'") | |
| 240 | (format t "~& ?~20Tprint out this help") | |
| 241 | (format t "~& quit -or-") | |
| 242 | (format t "~& q~20Texit from CafeOBJ interpreter") | |
| 243 | (format t "~& select <Modexp> ~20Tset the <Modexp> current") | |
| 244 | (format t "~& show -or-") | |
| 245 | (format t "~& describe~20Tprint various info., for further help, type `show ?'") | |
| 246 | (format t "~&-- setting switches:") | |
| 247 | (format t "~& set~20Tset toplevel switches, for further help: type `set ?'") | |
| 248 | (format t "~& protect <Modexp>~20Tprevent module from redefinition") | |
| 249 | (format t "~& unprotect <Modexp>~20T un-set protection of module") | |
| 250 | (format t "~&-- simple semantic tools:") | |
| 251 | (format t "~& check <things>~20Tcheck some properties of moudle,") | |
| 252 | (format t "~& ~20Tfor further help, type `check ?'") | |
| 253 | (format t "~& regularize <Modexp>~20T make the signature of <Modexp> regular") | |
| 254 | (format t "~&-- term rewriting commands:") | |
| 255 | (format t "~& reduce -or- ") | |
| 256 | (format t "~& red [in <Modexp> : ] <term> .") | |
| 257 | (format t "~& ~20Trewrite <term> using equations as rewerite rules") | |
| 258 | (format t "~& ~20Toptional <Modexp> specifies the context") | |
| 259 | (format t "~& exec [in <Modexp> : ] <term> .") | |
| 260 | ;; (format t "~& exec+ [in <Modexp> : ] <term> .") | |
| 261 | (format t "~& ~20Trewrite <term> using both equations and rules") | |
| 262 | (format t "~& ~20Toptional <Modexp> specifies the context") | |
| 263 | (format t "~& parse [in <Modexp> : ] <term> .") | |
| 264 | (format t "~& ~20Tparse <term>, print out the result") | |
| 265 | ;; (format t "~& test {reduction|execution} <term> :expect <term> . ") | |
| 266 | ;; (format t "~& ~20Tdo test reduction(execution) in the current context") | |
| 267 | ;; (format t "~& rew limit {<number>| .}") | |
| 268 | ;; (format t "~& ~20Tset(unset) max number of rewriting") | |
| 269 | ;; (format t "~& stop at [<term>] .") | |
| 270 | ;; (format t "~& ~20Tset(unset) stop pattern") | |
| 271 | (format t "~&-- theorem proving stuffs:") | |
| 272 | (format t "~& apply~20Tapply rewrite rules to a term,~%~20Tfor further help: type `apply ?'") | |
| 273 | (format t "~& start <term>~20Tset the term <term> as the target of \"apply\" command") | |
| 274 | (format t "~& open {<Modexp> | .}~20T open module") | |
| 275 | (format t "~& close ~20Tclose openning module") | |
| 276 | (format t "~&-- reading in files:") | |
| 277 | (format t "~& input -or-") | |
| 278 | (format t "~& in <file>~20Tread in <file>") | |
| 279 | (format t "~& require <feature> [<file>]") | |
| 280 | (format t "~& ~20Trequire <feature>") | |
| 281 | (format t "~& provide <feature>~20Tprovide the <feature>") | |
| 282 | (format t "~&-- save/restore module definitions:") | |
| 283 | (format t "~& save <file>~20Tsave current definitions of modules to <file>") | |
| 284 | (format t "~& restore <file>~20Trestore definitions of modules from <file>") | |
| 285 | (format t "~& reset ~20Trecover defintions of built-in modules and standard prelude") | |
| 286 | (format t "~& full reset~20Treset system to initial status") | |
| 287 | (format t "~&-- misc. commands") | |
| 288 | (format t "~& clean memo ~20T clean up term memoization table") | |
| 289 | (format t "~& dribble {<file>| .}~20T if <file> is given, begins to record the interaction") | |
| 290 | (format t "~& ~20Tto the specified file, else ends the recording.") | |
| 291 | (format t "~& cd <directory>~20Tchange current directory") | |
| 292 | (format t "~& ls <directory>~20Tlist files in directory") | |
| 293 | (format t "~& pwd~20Tprint current directory") | |
| 294 | (format t "~& lisp -or-") | |
| 295 | (format t "~& lispq <lisp>~20Tevaluate lisp expression <lisp>") | |
| 296 | (format t "~& ! <command>~20Tfork shell <command> (Unix only)")) | |
| 261 | (let ((ask (intern (car com)))) | |
| 262 | (case ask | |
| 263 | ((|?com| |?commands|) (oldoc-list-categories nil)) | |
| 264 | (otherwise (print-context-info) | |
| 265 | (print-help-help))))) | |
| 297 | 266 | (t (cafeobj-what-is com)))) |
| 267 | ||
| 268 | (defparameter .cafeobj-main-commands. | |
| 269 | "-- CafeOBJ major top level commands: | |
| 270 | NOTE: Top level definitional forms include declaration of `module' and `view'. | |
| 271 | -- help: | |
| 272 | ? shows the current context and the brief guide for using help system. | |
| 273 | -- exit: | |
| 274 | quit -or- q exit from CafeOBJ interpreter. | |
| 275 | -- setting working context: | |
| 276 | select <Modexp> . set the module specified by a module expression <Modexp> as current module. | |
| 277 | open <Modexp> . open the module specified by a module expression <Moexp>, | |
| 278 | <Modexp> will be a current module. | |
| 279 | close close the opening module. | |
| 280 | -- term rewriting commands: | |
| 281 | reduce -or- | |
| 282 | red [in <Modexp> : ] <term> . | |
| 283 | rewrite <term> using equations as rewerite rules | |
| 284 | optional <Modexp> specifies the rewriting context (module) | |
| 285 | exec [in <Modexp> : ] <term> . | |
| 286 | rewrite <term> using both equations and rules | |
| 287 | optional <Modexp> specifies the rewriting context (module) | |
| 288 | -- term parser: | |
| 289 | parse [in <Modexp> : ] <term> . | |
| 290 | parse <term>, print out the result | |
| 291 | optional <Modexp> specfies the parsing context (module) | |
| 292 | -- inspection: | |
| 293 | show -or- describe print various info., for further help, type `show ?' | |
| 294 | -- setting switches: | |
| 295 | set set toplevel switches, for further help: type `set ?' | |
| 296 | protect <Modexp> prevent module <Modexp> from redefinition | |
| 297 | unprotect <Modexp> un-set protection of module <Modexp> | |
| 298 | -- reading in files: | |
| 299 | input -or- | |
| 300 | in <pathname> requests the system to read the file specified by the pathname. | |
| 301 | The file itself may contain 'input' commands. | |
| 302 | -- system intialization | |
| 303 | reset restores the definitions of built-in modules and preludes, | |
| 304 | but does not affect other modules. | |
| 305 | full reset reinitializes the internal state of the system. | |
| 306 | all supplied modules definitions are lost. | |
| 307 | -- misc. commands | |
| 308 | cd <directory> change the system's working directory | |
| 309 | ls <directory> list files in directory | |
| 310 | pwd print the current directory | |
| 311 | ! <command> fork shell <command> (Unix only)" | |
| 312 | ) | |
| 313 | ||
| 314 | (defun show-cafeobj-main-commands () | |
| 315 | (format t "~a~%" .cafeobj-main-commands.)) | |
| 298 | 316 | |
| 299 | 317 | ;;; |
| 300 | 318 | (defparameter .?-invalid-chars. '("." "#" "'" "`")) |
| 301 | 319 | |
| 302 | #|| | |
| 303 | (defun cafeobj-what-is (inp) | |
| 304 | (flet ((check-pat (pat) | |
| 305 | (if (not (some #'(lambda (str) | |
| 306 | (member str .?-invalid-chars. :test #'string=)) | |
| 307 | pat)) | |
| 308 | t | |
| 309 | (progn (format *error-output* | |
| 310 | "Illegal command/switch pattern: ~{~a ~^~}" pat) | |
| 311 | nil)))) | |
| 312 | (let* ((id (if (cddr inp) | |
| 313 | (and (check-pat (cdr inp)) | |
| 314 | (mapcar #'read-from-string (cdr inp))) | |
| 315 | (and (cadr inp) | |
| 316 | (check-pat (cdr inp)) | |
| 317 | (read-from-string (cadr inp))))) | |
| 318 | (desc (if (keywordp id) | |
| 319 | (get-msg-description id) | |
| 320 | (and id (get-command-description (car inp) id))))) | |
| 321 | (unless id | |
| 322 | (format t "~&Usage: {? | ??} {<command/switch name or pattern> | <message ID>}") | |
| 323 | (return-from cafeobj-what-is nil)) | |
| 324 | (if desc | |
| 325 | (format t desc) | |
| 326 | (format t "~&Unknown command/switch or message ID: ~{~a ~^~}." (cdr inp)))))) | |
| 327 | ||# | |
| 328 | ||
| 329 | 320 | (defun cafeobj-what-is (inp) |
| 330 | 321 | (let* ((ask (intern (car inp))) |
| 331 | (question (cdr inp)) | |
| 332 | (description nil)) | |
| 322 | (question (cdr inp)) | |
| 323 | (description nil)) | |
| 333 | 324 | (case ask |
| 334 | 325 | (|?| (setq description (oldoc-get-documentation question :main t :example nil))) |
| 335 | 326 | (|??| (setq description (oldoc-get-documentation question :main t :example t))) |
| 336 | 327 | ((|?ex| |?example|) (setq description (oldoc-get-documentation question :main nil :example t))) |
| 337 | 328 | ((|?ap| |?apropos|) (setq description (oldoc-get-documentation question :apropos t))) |
| 329 | ((|?com| |?command|) (oldoc-list-categories question) | |
| 330 | (return-from cafeobj-what-is nil)) | |
| 338 | 331 | (otherwise |
| 339 | 332 | ;; this cannot happen |
| 340 | 333 | (with-output-chaos-error ('internal-error) |
| 341 | (format t "Unknown help command ~a" (car inp))))) | |
| 334 | (format t "Unknown help command ~a" (car inp))))) | |
| 342 | 335 | (cond (description (format t description) |
| 343 | (terpri)) | |
| 344 | (t (with-output-chaos-warning () | |
| 345 | (format t "System does not know about \"~{~a ~^~}\"." question)))))) | |
| 336 | (terpri)) | |
| 337 | (t (with-output-chaos-warning () | |
| 338 | (format t "System does not know about \"~{~a ~^~}\"." question)))))) | |
| 346 | 339 | |
| 347 | 340 | ;;; |
| 348 | 341 | (defun get-command-description (level id) |
| 392 | 385 | (defun print-cafeobj-prompt () |
| 393 | 386 | (fresh-all) |
| 394 | 387 | (flush-all) |
| 395 | (cond ((eq *prompt* 'system) | |
| 396 | (if *last-module* | |
| 397 | (if (module-is-inconsistent *last-module*) | |
| 388 | (let ((cur-module (get-context-module t))) | |
| 389 | (cond ((eq *prompt* 'system) | |
| 390 | (if cur-module | |
| 391 | (if (module-is-inconsistent cur-module) | |
| 398 | 392 | (progn |
| 399 | 393 | (with-output-chaos-warning () |
| 400 | 394 | (format t "~a is inconsistent due to changes in some of its submodules." |
| 401 | (module-name *last-module*)) | |
| 395 | (module-name cur-module)) | |
| 402 | 396 | (print-next) |
| 403 | 397 | (princ "resetting the `current module' of the system..")) |
| 404 | (setq *last-module* nil) | |
| 405 | (format *error-output* "~&CafeOBJ> ") | |
| 406 | ) | |
| 398 | (reset-context-module) | |
| 399 | (format *error-output* "~&CafeOBJ> ")) | |
| 407 | 400 | (let ((*standard-output* *error-output*)) |
| 408 | (print-simple-mod-name *last-module*) | |
| 401 | (print-simple-mod-name cur-module) | |
| 409 | 402 | (princ "> "))) |
| 410 | (format *error-output* "CafeOBJ> ")) | |
| 411 | (setf *sub-prompt* nil)) | |
| 412 | ((eq *prompt* 'none)) | |
| 413 | (*prompt* | |
| 414 | (let ((*standard-output* *error-output*)) | |
| 415 | (if (atom *prompt*) | |
| 416 | (princ *prompt*) | |
| 417 | (print-simple-princ-open *prompt*)) | |
| 418 | (princ " ")))) | |
| 419 | (flush-all)) | |
| 403 | ;; no context module | |
| 404 | (format *error-output* "CafeOBJ> ")) | |
| 405 | (setf *sub-prompt* nil)) | |
| 406 | ;; prompt specified to NONE | |
| 407 | ((eq *prompt* 'none)) | |
| 408 | ;; specified prompt | |
| 409 | (*prompt* | |
| 410 | (let ((*standard-output* *error-output*)) | |
| 411 | (if (atom *prompt*) | |
| 412 | (princ *prompt*) | |
| 413 | (print-simple-princ-open *prompt*)) | |
| 414 | (princ " ")))) | |
| 415 | (flush-all))) | |
| 420 | 416 | |
| 421 | 417 | ;;; SAVE INTERPRETER IMAGE |
| 422 | 418 | ;;;_____________________________________________________________________________ |
| 427 | 423 | (pathname (concatenate 'string topdir "/lib/"))) |
| 428 | 424 | (setq *system-ex-dir* |
| 429 | 425 | (pathname (concatenate 'string topdir "/exs/"))) |
| 430 | (setq *chaos-libpath* (list *system-lib-dir* *system-ex-dir*))) | |
| 426 | ;; (setq *chaos-libpath* (list *system-lib-dir* *system-ex-dir*)) | |
| 427 | (setq *chaos-libpath* (list *system-lib-dir*))) | |
| 431 | 428 | |
| 432 | 429 | #-(or (and CCL (not :openmcl)) ALLEGRO (and SBCL WIN32)) |
| 433 | 430 | (defun set-cafeobj-standard-library-path (&optional topdir) |
| 457 | 454 | (setq *system-prelude-dir* (translate-logical-pathname (merge-pathnames "prelude/"))) |
| 458 | 455 | (setq *system-lib-dir* (translate-logical-pathname (merge-pathnames "lib/"))) |
| 459 | 456 | (setq *system-ex-dir* (translate-logical-pathname (merge-pathnames "exs/"))) |
| 460 | (setq *chaos-libpath* | |
| 461 | (list *system-lib-dir* *system-ex-dir*))))) | |
| 457 | ;;; (setq *chaos-libpath* (list *system-lib-dir* *system-ex-dir*)) | |
| 458 | (setq *chaos-libpath* (list *system-lib-dir*))))) | |
| 462 | 459 | |
| 463 | 460 | #+(and :SBCL :win32) |
| 464 | 461 | (defun set-cafeobj-standard-library-path (&optional topdir) |
| 465 | 462 | (if topdir |
| 466 | 463 | (set-cafeobj-libpath topdir) |
| 467 | 464 | (let* ((*default-pathname-defaults* (make-pathname :host (pathname-host sb-ext:*core-pathname*) |
| 468 | :device (pathname-device sb-ext:*core-pathname*) | |
| 469 | :directory (pathname-directory sb-ext:*core-pathname*)))) | |
| 465 | :device (pathname-device sb-ext:*core-pathname*) | |
| 466 | :directory (pathname-directory sb-ext:*core-pathname*)))) | |
| 470 | 467 | (setq *cafeobj-install-dir* *default-pathname-defaults*) |
| 471 | 468 | (setq *system-prelude-dir* (translate-logical-pathname (merge-pathnames "prelude/"))) |
| 472 | 469 | (setq *system-lib-dir* (translate-logical-pathname (merge-pathnames "lib/"))) |
| 473 | 470 | (setq *system-ex-dir* (translate-logical-pathname (merge-pathnames "exs/"))) |
| 474 | (setq *chaos-libpath* | |
| 475 | (list *system-lib-dir* *system-ex-dir*))))) | |
| 471 | ;;; (setq *chaos-libpath* (list *system-lib-dir* *system-ex-dir*)) | |
| 472 | (setq *chaos-libpath* (list *system-lib-dir*))))) | |
| 476 | 473 | |
| 477 | 474 | ;;; patch by t-seino@jaist.ac.jp |
| 478 | 475 | #+(and CCL (not :openmcl)) |
| 486 | 483 | (full-pathname (make-pathname :host "ccl" :directory "lib/"))) |
| 487 | 484 | (setq *system-ex-dir* |
| 488 | 485 | (full-pathname (make-pathname :host "ccl" :directory "exs/"))) |
| 489 | (setq *chaos-libpath* (list *system-lib-dir* *system-ex-dir*))) | |
| 486 | ;; (setq *chaos-libpath* (list *system-lib-dir* *system-ex-dir*)) | |
| 487 | (setq *chaos-libpath* (list *system-lib-dir*))) | |
| 490 | 488 | |
| 491 | 489 | ;;; MAIN ROUTINE |
| 492 | 490 | ;;; PROCESSING INPUT FILE STREAM |
| 524 | 522 | (let ((com (get-command-info key))) |
| 525 | 523 | (unless com |
| 526 | 524 | (with-output-chaos-error ('no-commands) |
| 527 | (format t "No such command or declaration keyword '~a'." key))) | |
| 525 | (format t "No such command or declaration keyword '~a'." key))) | |
| 528 | 526 | (let ((parser (comde-parser com))) |
| 529 | 527 | (unless parser |
| 530 | (with-output-chaos-error ('no-parser) | |
| 531 | (format t "No parser is defined for command ~a" key))) | |
| 528 | (with-output-chaos-error ('no-parser) | |
| 529 | (format t "No parser is defined for command ~a" key))) | |
| 532 | 530 | (let ((pform (funcall parser inp))) |
| 533 | (unless pform | |
| 534 | (with-output-chaos-error ('parse-error) | |
| 535 | (format t "Invalid argument to command ~a." key))) | |
| 536 | (if (eq pform :help) | |
| 537 | (print-comde-usage com) | |
| 538 | (let ((evaluator (comde-evaluator com))) | |
| 539 | (unless evaluator | |
| 540 | (with-output-chaos-error ('no-evaluator) | |
| 541 | (format t "No evaluator is defined for command ~a." key))) | |
| 542 | (funcall evaluator pform))))))) | |
| 531 | (unless pform | |
| 532 | (with-output-chaos-error ('parse-error) | |
| 533 | (format t "Invalid argument to command ~a." key))) | |
| 534 | (if (eq pform :help) | |
| 535 | (print-comde-usage com) | |
| 536 | (let ((evaluator (comde-evaluator com))) | |
| 537 | (unless evaluator | |
| 538 | (with-output-chaos-error ('no-evaluator) | |
| 539 | (format t "No evaluator is defined for command ~a." key))) | |
| 540 | (funcall evaluator pform))))))) | |
| 543 | 541 | |
| 544 | 542 | ;;; |
| 545 | 543 | ;;; |
| 546 | 544 | (defun parse-cafeobj-input-from-string (string) |
| 547 | 545 | (let ((.reader-ch. 'space) |
| 548 | (*reader-input* *reader-void*) | |
| 549 | (*print-array* nil) | |
| 550 | (*print-circle* nil) | |
| 551 | (*old-context* nil) | |
| 552 | (*show-mode* :cafeobj)) | |
| 546 | (*reader-input* *reader-void*) | |
| 547 | (*print-array* nil) | |
| 548 | (*print-circle* nil) | |
| 549 | (*old-context* nil) | |
| 550 | (*show-mode* :cafeobj)) | |
| 553 | 551 | (let ((inp nil) |
| 554 | (.in-in. nil)) | |
| 552 | (.in-in. nil)) | |
| 555 | 553 | (declare (special .in-in.)) |
| 556 | 554 | (with-chaos-top-error ('handle-cafeobj-top-error) |
| 557 | (with-chaos-error ('handle-chaos-error) | |
| 558 | (setq inp (cafeobj-parse-from-string string)) | |
| 559 | (block process-input | |
| 560 | ;; PROCESS INPUT | |
| 561 | (cafeobj-evaluate-command (car inp) inp))))))) | |
| 555 | (with-chaos-error ('handle-chaos-error) | |
| 556 | (setq inp (cafeobj-parse-from-string string)) | |
| 557 | (block process-input | |
| 558 | ;; PROCESS INPUT | |
| 559 | (cafeobj-evaluate-command (car inp) inp))))))) | |
| 562 | 560 | ;;; |
| 563 | 561 | ;;; READING IN DECLARATIONS/COMMANDS and PROCESS THEM. |
| 564 | 562 | ;;; |
| 596 | 594 | |
| 597 | 595 | (block process-input |
| 598 | 596 | ;; PROCESS INPUT COMMANDS ============== |
| 599 | (cafeobj-evaluate-command (car inp) inp)) | |
| 597 | (cafeobj-evaluate-command (car inp) inp)) | |
| 600 | 598 | (setq *chaos-print-errors* t))) |
| 601 | 599 | (when .in-in. |
| 602 | 600 | (setq *chaos-print-errors* t) |
| 603 | 601 | (setq .in-in. nil))))))) |
| 604 | 602 | |
| 605 | (defun try-reduce-term (inp) | |
| 606 | (perform-reduction* inp *current-module* nil nil)) | |
| 607 | ||
| 608 | 603 | (defun handle-cafeobj-top-error (val) |
| 609 | 604 | (if *chaos-input-source* |
| 610 | 605 | (chaos-to-top val) |
| 4 | 4 | File: commands.lisp |
| 5 | 5 | ==============================================================================|# |
| 6 | 6 | ;;; |
| 7 | ;;; Copyright (c) 2000-2014, Toshimi Sawada. All rights reserved. | |
| 7 | ;;; Copyright (c) 2000-2015, Toshimi Sawada. All rights reserved. | |
| 8 | 8 | ;;; |
| 9 | 9 | ;;; Redistribution and use in source and binary forms, with or without |
| 10 | 10 | ;;; modification, are permitted provided that the following conditions |
| 89 | 89 | ") |
| 90 | 90 | |
| 91 | 91 | (define ("#define") |
| 92 | :category :module-element | |
| 93 | :parser identity | |
| 92 | :category :element | |
| 93 | :parser identity | |
| 94 | :title "`#define <symbol> := <term> .`" | |
| 94 | 95 | :mdkey "sharp-define" |
| 95 | 96 | :evaluator cafeobj-eval-module-element-proc |
| 96 | 97 | :doc " |
| 98 | 99 | ) |
| 99 | 100 | |
| 100 | 101 | (define ("--" "**") |
| 101 | :category :decl-toplevel | |
| 102 | :category :decl | |
| 102 | 103 | :parser parse-comment-command |
| 103 | 104 | :evaluator identity |
| 104 | 105 | :title "`**`, `**>`" |
| 111 | 112 | |
| 112 | 113 | |
| 113 | 114 | (define ("-->" "**>") |
| 114 | :category :decl-toplevel | |
| 115 | :category :decl | |
| 115 | 116 | :parser parse-comment-command |
| 116 | 117 | :evaluator eval-ast |
| 117 | 118 | :title "`--`, `-->`" |
| 188 | 189 | :evaluator cafeobj-top-level-help |
| 189 | 190 | :title "`? [<term>]`" |
| 190 | 191 | :mdkey "help" |
| 191 | :doc "Without any argument, lists all top-level commands. | |
| 192 | :doc "Without any argument, shows the brief guide of online help system. | |
| 192 | 193 | With argument gives the reference manual description of `term`. |
| 193 | 194 | In addition to this, many commands allow for passing `?` as argument |
| 194 | 195 | to obtain further help. |
| 334 | 335 | :category :library |
| 335 | 336 | :parser parse-autoload-command |
| 336 | 337 | :evaluator eval-ast |
| 337 | :doc " | |
| 338 | :title "`autoload <module-name> <file-name>`" | |
| 339 | :related ("no autoload") | |
| 340 | :doc "When evaluating a <module-name> and found that | |
| 341 | it is not yet declared, the system read in <file-name> then | |
| 342 | retries the evaluation. | |
| 343 | ") | |
| 344 | ||
| 345 | (define ("no-autoload") | |
| 346 | :category :library | |
| 347 | :parser parse-no-autoload-command | |
| 348 | :evaluator eval-ast | |
| 349 | :title "`no autoload <module-name>`" | |
| 350 | :related ("autoload") | |
| 351 | :doc "Stop `autoload` of module with the name <module-name> . | |
| 352 | Please refer to `autoload` command. | |
| 338 | 353 | ") |
| 339 | 354 | |
| 340 | 355 | (define ("axioms" "axiom" "axs") |
| 341 | :category :module-element | |
| 356 | :category :element | |
| 342 | 357 | :parser identity |
| 343 | 358 | :evaluator cafeobj-eval-module-element-proc |
| 344 | 359 | :title "`axioms { <decls> }`" |
| 350 | 365 | ") |
| 351 | 366 | |
| 352 | 367 | (define ("bceq" "bcq") |
| 353 | :category :module-element | |
| 354 | :parser identity | |
| 355 | :evaluator cafeobj-eval-module-element-proc | |
| 356 | :title "`bceq [ <op-exp> ] <term> = <term> if <boolterm> .`" | |
| 368 | :category :element | |
| 369 | :parser identity | |
| 370 | :evaluator cafeobj-eval-module-element-proc | |
| 371 | :title "`bceq [ <label-exp> ] <term> = <term> if <boolterm> .`" | |
| 357 | 372 | :related ("eq" "ceq" "beq") |
| 358 | 373 | :doc "Defines a behavioral conditional equation. For details see [`ceq`](#ceq). |
| 359 | 374 | ") |
| 360 | 375 | |
| 361 | 376 | (define ("beq") |
| 362 | :category :module-element | |
| 363 | :parser identity | |
| 364 | :evaluator cafeobj-eval-module-element-proc | |
| 365 | :title "`beq [ <op-exp> ] <term> = <term> .`" | |
| 377 | :category :element | |
| 378 | :parser identity | |
| 379 | :evaluator cafeobj-eval-module-element-proc | |
| 380 | :title "`beq [ <label-exp> ] <term> = <term> .`" | |
| 366 | 381 | :related ("eq" "ceq" "bceq") |
| 367 | 382 | :doc "Defines a behavioral equation. For details see [`eq`](#eq). |
| 368 | 383 | ") |
| 369 | 384 | |
| 370 | 385 | (define ("bctrans" "bctr") |
| 371 | :category :module-element | |
| 386 | :category :element | |
| 372 | 387 | :parser identity |
| 373 | 388 | :evaluator cafeobj-eval-module-element-proc |
| 374 | 389 | :title "`bctrans [ <label-exp> ] <term> => <term> if <bool> .`" |
| 378 | 393 | ") |
| 379 | 394 | |
| 380 | 395 | (define ("bop" "bops") |
| 381 | :category :module-element | |
| 396 | :category :element | |
| 382 | 397 | :parser identity |
| 383 | 398 | :evaluator cafeobj-eval-module-element-proc |
| 384 | 399 | :title "`bop <op-spec> : <sorts> -> <sort>`" |
| 391 | 406 | ") |
| 392 | 407 | |
| 393 | 408 | (define ("bpred" "bpreds" "bpd" "bpds") |
| 394 | :category :module-element | |
| 409 | :category :element | |
| 395 | 410 | :parser identity |
| 396 | 411 | :evaluator cafeobj-eval-module-element-proc |
| 397 | 412 | :title "`bpred <op-spec> : <sorts>`" |
| 414 | 429 | ") |
| 415 | 430 | |
| 416 | 431 | (define ("btrans" "btr") |
| 417 | :category :module-element | |
| 432 | :category :element | |
| 418 | 433 | :parser identity |
| 419 | 434 | :evaluator cafeobj-eval-module-element-proc |
| 420 | 435 | :title "`btrans [ <label-exp> ] <term> => <term> .`" |
| 426 | 441 | :category :rewrite |
| 427 | 442 | :parser parse-cbred-command |
| 428 | 443 | :evaluator eval-ast |
| 444 | :title "`cbred [ in <mod-exp> :] <term> .`" | |
| 429 | 445 | :doc " |
| 430 | 446 | ") |
| 431 | 447 | |
| 440 | 456 | ") |
| 441 | 457 | |
| 442 | 458 | (define ("ceq" "cq") |
| 443 | :category :module-element | |
| 444 | :parser identity | |
| 445 | :evaluator cafeobj-eval-module-element-proc | |
| 446 | :title "`ceq [ <op-exp> ] <term> = <term> if <boolterm> .`" | |
| 459 | :category :element | |
| 460 | :parser identity | |
| 461 | :evaluator cafeobj-eval-module-element-proc | |
| 462 | :title "`ceq [ <label-exp> ] <term> = <term> if <boolterm> .`" | |
| 447 | 463 | :related ("eq" "beq" "bceq") |
| 448 | 464 | :doc "Defines a conditional equation. Spaces around the `if` are obligatory. |
| 449 | 465 | `<boolterm>` needs to be a Boolean term. For other requirements |
| 513 | 529 | :category :rewrite |
| 514 | 530 | :parser identity |
| 515 | 531 | :evaluator cafeobj-eval-clear-memo-proc |
| 532 | :title "`clean memo`" | |
| 516 | 533 | :mdkey "cleanmemo" |
| 517 | 534 | :related (("clean memo switch" "`clean memo` switch")) |
| 518 | 535 | :doc "Resets (clears) the memo storage of the system. Memorized computations |
| 532 | 549 | :category :proof |
| 533 | 550 | :parser parse-close-command |
| 534 | 551 | :evaluator eval-ast |
| 552 | :title "`close`" | |
| 535 | 553 | :related ("open") |
| 536 | 554 | :doc "This command closes a modification of a module started by `open`. |
| 537 | 555 | ") |
| 555 | 573 | ") |
| 556 | 574 | |
| 557 | 575 | (define ("ctrans" "ctr") |
| 558 | :category :module-element | |
| 559 | :parser identity | |
| 560 | :evaluator cafeobj-eval-module-element-proc | |
| 561 | :title "`ctrans [ <label-exp> ] <term> => <term> .`" | |
| 576 | :category :element | |
| 577 | :parser identity | |
| 578 | :evaluator cafeobj-eval-module-element-proc | |
| 579 | :title "`ctrans [ <label-exp> ] <term> => <term> if <term> .`" | |
| 562 | 580 | :related ("trans" "btrans" "bctrans") |
| 563 | 581 | :doc "Defines a conditional transition. For details see [`trans`](#trans) |
| 564 | 582 | and [`ceq`](#ceq). |
| 570 | 588 | :evaluator eval-ast |
| 571 | 589 | :title "`describe <something>`" |
| 572 | 590 | :related ("show") |
| 573 | :doc "Similar to the `show` command but with more details. See `describe ?` for | |
| 591 | :doc "Similar to the `show` command but with more details. Call `describe ?` for | |
| 574 | 592 | the possible set of invocations. |
| 575 | 593 | ") |
| 576 | 594 | |
| 582 | 600 | ") |
| 583 | 601 | |
| 584 | 602 | (define ("eq") |
| 585 | :category :module-element | |
| 586 | :parser identity | |
| 587 | :evaluator cafeobj-eval-module-element-proc | |
| 588 | :title "`eq [ <op-exp> ]: <term> = <term> .`" | |
| 603 | :category :element | |
| 604 | :parser identity | |
| 605 | :evaluator cafeobj-eval-module-element-proc | |
| 606 | :title "`eq [ <label-exp> ] <term> = <term> .`" | |
| 589 | 607 | :related ("ceq" "beq" "bceq") |
| 590 | 608 | :doc "Declares an axiom, or equation. |
| 591 | 609 | |
| 596 | 614 | In simple words, the objects determined by the terms must be |
| 597 | 615 | interpretable as of the same sort. |
| 598 | 616 | |
| 599 | The optional part `<op-exp>` serves two purposes, one is to give | |
| 617 | The optional part `<label-exp>` serves two purposes, one is to give | |
| 600 | 618 | an axiom an identifier, and one is to modify its behavior. The |
| 601 | `<op-exp>` is of the form: | |
| 619 | `<label-exp>` is of the form: | |
| 602 | 620 | |
| 603 | 621 | ` [ <modifier> <label> ] : ` |
| 604 | 622 | |
| 671 | 689 | |
| 672 | 690 | |
| 673 | 691 | (define ("extending" "ex") |
| 674 | :category :module-element | |
| 692 | :category :element | |
| 675 | 693 | :parser identity |
| 676 | 694 | :evaluator cafeobj-eval-module-element-proc |
| 677 | 695 | :title "`extending ( <modexp> )`" |
| 717 | 735 | ") |
| 718 | 736 | |
| 719 | 737 | (define ("imports") |
| 720 | :category :module-element | |
| 738 | :category :element | |
| 721 | 739 | :parser identity |
| 722 | 740 | :evaluator cafeobj-eval-module-element-proc |
| 723 | 741 | :title "`imports { <import-decl> }`" |
| 724 | 742 | :related ("signature" "axioms" "extending" "including" "protecting" |
| 725 | "using") | |
| 743 | "using") | |
| 726 | 744 | :doc "Block enclosing import of other modules (`protecting` etc). |
| 727 | 745 | Other statements are not allowed within the `imports` block. |
| 728 | 746 | Optional structuring of the statements in a module. |
| 752 | 770 | ") |
| 753 | 771 | |
| 754 | 772 | (define ("including" "inc") |
| 755 | :category :module-element | |
| 773 | :category :element | |
| 756 | 774 | :parser identity |
| 757 | 775 | :evaluator cafeobj-eval-module-element-proc |
| 758 | 776 | :title "`including ( <modexp> )`" |
| 836 | 854 | |
| 837 | 855 | |
| 838 | 856 | (define ("let") |
| 839 | :category :decl-toplevel | |
| 857 | :category :decl | |
| 840 | 858 | :parser process-let-declaration-form |
| 841 | 859 | :evaluator eval-ast |
| 842 | 860 | :title "`let <identifier> = <term> .`" |
| 920 | 938 | ") |
| 921 | 939 | |
| 922 | 940 | (define ("module" "mod" "module*" "mod*" "module!" "mod!" "sys:mod!" "sys:module!" "sys:mod*" "sys:module*") |
| 923 | :category :decl-toplevel | |
| 941 | :category :decl | |
| 924 | 942 | :parser process-module-declaration-form |
| 925 | 943 | :evaluator eval-ast |
| 926 | 944 | :title "`[sys:]module[!|*] <modname> [ ( <params> ) ] [ <principal_sort_spec> ] { mod_elements ... }`" |
| 941 | 959 | |
| 942 | 960 | `module` introduces a module without specified semantic type. |
| 943 | 961 | |
| 944 | If `params` are given, it is a parameterized module. See `parameterized module` | |
| 945 | for more details. | |
| 962 | If `params` are given, it is a parameterized module. | |
| 963 | See [`parameterized module`](#parameterizedmodule) for more details. | |
| 946 | 964 | |
| 947 | 965 | If `principal_sort_spec` is given, it has to be of the form |
| 948 | 966 | `principal-sort <sortname>` (or `p-sort <sortname>`). The principal |
| 1054 | 1072 | ") |
| 1055 | 1073 | |
| 1056 | 1074 | (define ("op" "ops") |
| 1057 | :category :module-element | |
| 1075 | :category :element | |
| 1058 | 1076 | :parser identity |
| 1059 | 1077 | :evaluator cafeobj-eval-module-element-proc |
| 1060 | 1078 | :title "`op <op-spec> : <sorts> -> <sort> { <attribute-list> }`" |
| 1215 | 1233 | ") |
| 1216 | 1234 | |
| 1217 | 1235 | (define ("pred" "pd" "preds" "pds") |
| 1218 | :category :module-element | |
| 1236 | :category :element | |
| 1219 | 1237 | :parser identity |
| 1220 | 1238 | :evaluator cafeobj-eval-module-element-proc |
| 1221 | 1239 | :title "`pred <op-spec> : <sorts>`" |
| 1254 | 1272 | |
| 1255 | 1273 | |
| 1256 | 1274 | (define ("protect") |
| 1257 | :category :system | |
| 1275 | :category :switch | |
| 1258 | 1276 | :parser parse-protect-command |
| 1259 | 1277 | :evaluator eval-ast |
| 1260 | 1278 | :title "`protect <module-name>`" |
| 1265 | 1283 | ") |
| 1266 | 1284 | |
| 1267 | 1285 | (define ("protecting" "pr") |
| 1268 | :category :module-element | |
| 1286 | :category :element | |
| 1269 | 1287 | :parser identity |
| 1270 | 1288 | :evaluator cafeobj-eval-module-element-proc |
| 1271 | 1289 | :title "`protecting ( <modexp> )`" |
| 1272 | 1290 | :related ("extending" "using" "including") |
| 1273 | 1291 | :doc "Imports the object specified by `modexp` into the current |
| 1274 | module, preserving all intended models as they are. See `module expression` | |
| 1275 | for format of `modexp`. | |
| 1292 | module, preserving all intended models as they are. | |
| 1293 | See [`module expression`](#moduleexpression) for format of `modexp`. | |
| 1276 | 1294 | ") |
| 1277 | 1295 | |
| 1278 | 1296 | (define ("provide") |
| 1321 | 1339 | (define ("qualified term") |
| 1322 | 1340 | :type :doc-only |
| 1323 | 1341 | :mdkey "qualified" |
| 1324 | :example "`1:NzNat` `2:Nat`" | |
| 1342 | :example "`(1):NzNat` `(2):Nat`" | |
| 1325 | 1343 | :related ("parse") |
| 1326 | 1344 | :doc "In case that a term can be parsed into different sort, it is possible to |
| 1327 | 1345 | qualify the term to one of the possible sorts by affixing it with |
| 1370 | 1388 | ") |
| 1371 | 1389 | |
| 1372 | 1390 | (define ("regularize") |
| 1373 | :category :module | |
| 1391 | :category :misc | |
| 1374 | 1392 | :parser parse-regularize-command |
| 1375 | 1393 | :evaluator eval-ast |
| 1376 | 1394 | :title "`regularize <mod-name>`" |
| 1451 | 1469 | ") |
| 1452 | 1470 | |
| 1453 | 1471 | |
| 1454 | (define ("save-system" "save system") ; NOTE. this is obsolete. | |
| 1472 | (define ("save-system" "save system") ; NOTE. this is obsolete. | |
| 1455 | 1473 | :type :doc-only |
| 1456 | 1474 | :title "`save-system <pathname>`" |
| 1457 | 1475 | :related ("input" "save" "restore") |
| 1547 | 1565 | the `show` command are: |
| 1548 | 1566 | |
| 1549 | 1567 | - `show [ <modexp> ]` - describes the current modules of the one specified |
| 1550 | as argument | |
| 1568 | as argument | |
| 1551 | 1569 | - `show module tree [ <modexp> ]` - displays submodules of <modexp> in tree format |
| 1552 | 1570 | - `show switches` - lists all possible switches |
| 1553 | 1571 | - `show term [ tree ]` - displays a term, possible in tree format |
| 1554 | 1572 | |
| 1555 | See the entry for `switches` for a full list. | |
| 1573 | See the entry for [`switches`](#switches) for a full list. | |
| 1556 | 1574 | ") |
| 1557 | 1575 | |
| 1558 | 1576 | (define ("show mode switch") |
| 1566 | 1584 | |
| 1567 | 1585 | |
| 1568 | 1586 | (define ("signature" "sig") |
| 1569 | :category :module-element | |
| 1587 | :category :element | |
| 1570 | 1588 | :parser identity |
| 1571 | 1589 | :evaluator cafeobj-eval-module-element-proc |
| 1572 | 1590 | :title "`signature { <sig-decl> }`" |
| 1727 | 1745 | ") |
| 1728 | 1746 | |
| 1729 | 1747 | (define ("trans" "tr") |
| 1730 | :category :module-element | |
| 1748 | :category :element | |
| 1731 | 1749 | :parser identity |
| 1732 | 1750 | :evaluator cafeobj-eval-module-element-proc |
| 1733 | 1751 | :title "`trans [ <label-exp> ] <term> => <term> .`" |
| 1746 | 1764 | ") |
| 1747 | 1765 | |
| 1748 | 1766 | (define ("unprotect") |
| 1749 | :category :system | |
| 1767 | :category :switch | |
| 1750 | 1768 | :parser parse-unprotect-command |
| 1751 | 1769 | :evaluator eval-ast |
| 1752 | 1770 | :title "`unprotect <module-name>`" |
| 1757 | 1775 | ") |
| 1758 | 1776 | |
| 1759 | 1777 | (define ("using" "us") |
| 1760 | :category :module-element | |
| 1778 | :category :element | |
| 1761 | 1779 | :parser identity |
| 1762 | 1780 | :evaluator cafeobj-eval-module-element-proc |
| 1763 | 1781 | :title "`using ( <modexp> )`" |
| 1764 | 1782 | :related ("extending" "including" "protecting") |
| 1765 | 1783 | :doc "Imports the object specified by `modexp` into the current |
| 1766 | 1784 | module without any restrictions on the models. |
| 1767 | See `module expression` for format of `modexp`. | |
| 1785 | See [`module expression`](#moduleexpression) for format of `modexp`. | |
| 1768 | 1786 | ") |
| 1769 | 1787 | |
| 1770 | 1788 | (define ("var" "vars") |
| 1771 | :category :module-element | |
| 1789 | :category :element | |
| 1772 | 1790 | :parser identity |
| 1773 | 1791 | :evaluator cafeobj-eval-module-element-proc |
| 1774 | 1792 | :title "`var <var-name> : <sort-name>`" |
| 1801 | 1819 | ") |
| 1802 | 1820 | |
| 1803 | 1821 | (define ("view") |
| 1804 | :category :decl-toplevel | |
| 1822 | :category :decl | |
| 1805 | 1823 | :parser process-view-declaration-form |
| 1806 | 1824 | :evaluator eval-ast |
| 1807 | 1825 | :title "`view <name> from <modname> to <modname> { <viewelems> }`" |
| 1869 | 1887 | :category :rewrite |
| 1870 | 1888 | :parser parse-exec+-command |
| 1871 | 1889 | :evaluator eval-ast |
| 1890 | :title "`exec! [ in <mod-exp> : ] <term> .`" | |
| 1872 | 1891 | :mdkey "execute-dash" |
| 1873 | 1892 | :doc " |
| 1874 | 1893 | exec! [in <Modexpr> :] <Term> . |
| 1901 | 1920 | ") |
| 1902 | 1921 | |
| 1903 | 1922 | (define ("make") |
| 1904 | :category :decl-toplevel | |
| 1923 | :category :decl | |
| 1905 | 1924 | :parser parse-make-command |
| 1906 | 1925 | :evaluator eval-ast |
| 1907 | 1926 | :doc " |
| 1915 | 1934 | ") |
| 1916 | 1935 | |
| 1917 | 1936 | (define ("[") |
| 1918 | :category :module-element | |
| 1937 | :category :element | |
| 1919 | 1938 | :parser identity |
| 1920 | 1939 | :mdkey "sortsymbol" |
| 1921 | 1940 | :evaluator cafeobj-eval-module-element-proc |
| 1923 | 1942 | ") |
| 1924 | 1943 | |
| 1925 | 1944 | (define ("*") |
| 1926 | :category :module-element | |
| 1945 | :category :element | |
| 1927 | 1946 | :parser identity |
| 1928 | 1947 | :evaluator cafeobj-eval-module-element-proc |
| 1929 | 1948 | ) |
| 1930 | 1949 | |
| 1931 | 1950 | (define ("bsort") |
| 1932 | :category :module-element | |
| 1951 | :category :element | |
| 1933 | 1952 | :parser identity |
| 1934 | 1953 | :evaluator cafeobj-eval-module-element-proc |
| 1935 | 1954 | :doc " |
| 1936 | 1955 | ") |
| 1937 | 1956 | |
| 1938 | (define ("dpred") ; only for pignose | |
| 1939 | :category :module-element | |
| 1940 | :parser identity | |
| 1941 | :evaluator cafeobj-eval-module-element-proc | |
| 1957 | ||
| 1958 | ; seems these are obsolete, | |
| 1959 | ; (define ("dpred") ; only for pignose | |
| 1960 | ; :category :element | |
| 1961 | ; :parser identity | |
| 1962 | ; :evaluator cafeobj-eval-module-element-proc | |
| 1963 | ; :doc "(pignose) | |
| 1964 | ; ") | |
| 1965 | ||
| 1966 | ; (define ("dbpred") ; only for pignose | |
| 1967 | ; :category :element | |
| 1968 | ; :parser identity | |
| 1969 | ; :evaluator cafeobj-eval-module-element-proc | |
| 1970 | ; :doc "(pignose) | |
| 1971 | ; ") | |
| 1972 | ||
| 1973 | (define ("ax") ; pignose | |
| 1974 | :category :element | |
| 1975 | :parser identity | |
| 1976 | :evaluator cafeobj-eval-module-element-proc | |
| 1977 | :title "`ax [ <label-exp> ] <term> = <term>` ." | |
| 1942 | 1978 | :doc "(pignose) |
| 1943 | 1979 | ") |
| 1944 | 1980 | |
| 1945 | (define ("dbpred") ; only for pignose | |
| 1946 | :category :module-element | |
| 1947 | :parser identity | |
| 1948 | :evaluator cafeobj-eval-module-element-proc | |
| 1981 | (define ("bax") ; pignose | |
| 1982 | :category :element | |
| 1983 | :parser identity | |
| 1984 | :evaluator cafeobj-eval-module-element-proc | |
| 1985 | :title "`bax [ <label-exp> ] <term> = <term>` ." | |
| 1949 | 1986 | :doc "(pignose) |
| 1950 | 1987 | ") |
| 1951 | 1988 | |
| 1952 | ||
| 1953 | (define ("ax") ; pignose | |
| 1954 | :category :module-element | |
| 1955 | :parser identity | |
| 1956 | :evaluator cafeobj-eval-module-element-proc | |
| 1989 | (define ("goal") ; pignose | |
| 1990 | :category :element | |
| 1991 | :parser identity | |
| 1992 | :evaluator cafeobj-eval-module-element-proc | |
| 1993 | :title "`goal <term> .`" | |
| 1957 | 1994 | :doc "(pignose) |
| 1958 | 1995 | ") |
| 1959 | 1996 | |
| 1960 | (define ("bax") ; pignose | |
| 1961 | :category :module-element | |
| 1962 | :parser identity | |
| 1963 | :evaluator cafeobj-eval-module-element-proc | |
| 1997 | (define ("bgoal") ; pignose | |
| 1998 | :category :element | |
| 1999 | :parser identity | |
| 2000 | :evaluator cafeobj-eval-module-element-proc | |
| 2001 | :title "`bgoal <term> .`" | |
| 1964 | 2002 | :doc "(pignose) |
| 1965 | 2003 | ") |
| 1966 | 2004 | |
| 1967 | (define ("goal") ; pignose | |
| 1968 | :category :module-element | |
| 1969 | :parser identity | |
| 1970 | :evaluator cafeobj-eval-module-element-proc | |
| 2005 | (define ("pvar" "pvars") | |
| 2006 | :category :element | |
| 2007 | :parser identity | |
| 2008 | :evaluator cafeobj-eval-module-element-proc | |
| 2009 | :title "`pvar <var-name> : <sort-name>`" | |
| 2010 | :related ("var" "vars") | |
| 1971 | 2011 | :doc "(pignose) |
| 1972 | 2012 | ") |
| 1973 | ||
| 1974 | (define ("bgoal") ; pignose | |
| 1975 | :category :module-element | |
| 1976 | :parser identity | |
| 1977 | :evaluator cafeobj-eval-module-element-proc | |
| 1978 | :doc "(pignose) | |
| 1979 | ") | |
| 1980 | ||
| 1981 | (define ("pvar" "pvars") | |
| 1982 | :category :module-element | |
| 1983 | :parser identity | |
| 1984 | :evaluator cafeobj-eval-module-element-proc | |
| 1985 | :doc "(pignose) | |
| 1986 | ") | |
| 1987 | 2013 | |
| 1988 | 2014 | |
| 1989 | (define ("rule" "crule") | |
| 1990 | :category :module-element | |
| 1991 | :parser identity | |
| 1992 | :evaluator cafeobj-eval-module-element-proc | |
| 1993 | :doc " | |
| 1994 | ") | |
| 1995 | ||
| 1996 | (define ("rl" "crl") | |
| 1997 | :category :module-element | |
| 1998 | :parser identity | |
| 1999 | :evaluator cafeobj-eval-module-element-proc | |
| 2000 | :doc " | |
| 2001 | ") | |
| 2002 | ||
| 2003 | (define ("brule" "bcrule") | |
| 2004 | :category :module-element | |
| 2005 | :parser identity | |
| 2006 | :evaluator cafeobj-eval-module-element-proc | |
| 2007 | :doc " | |
| 2008 | ") | |
| 2009 | ||
| 2010 | (define ("brl" "bcrl") | |
| 2011 | :category :module-element | |
| 2012 | :parser identity | |
| 2013 | :evaluator cafeobj-eval-module-element-proc | |
| 2014 | :doc " | |
| 2015 | ") | |
| 2016 | ||
| 2017 | (define ("inspect") | |
| 2015 | (define ("rule" "rl" ) | |
| 2016 | :category :element | |
| 2017 | :parser identity | |
| 2018 | :evaluator cafeobj-eval-module-element-proc | |
| 2019 | :title "`rule [ <label-exp> ] <term> => <term> .`" | |
| 2020 | :related ("trans") | |
| 2021 | :doc "Synonym of 'trans'. | |
| 2022 | ") | |
| 2023 | ||
| 2024 | (define ("crule" "crl") | |
| 2025 | :category :element | |
| 2026 | :parser identity | |
| 2027 | :evaluator cafeobj-eval-module-element-proc | |
| 2028 | :title "`crule [ <label-exp> ] <term> => <term> if <term> .`" | |
| 2029 | :related ("ctrans" "rule") | |
| 2030 | :doc "Synonym of 'ctrans' | |
| 2031 | ") | |
| 2032 | ||
| 2033 | (define ("brule" "brl") | |
| 2034 | :category :element | |
| 2035 | :parser identity | |
| 2036 | :evaluator cafeobj-eval-module-element-proc | |
| 2037 | :related ("btrans") | |
| 2038 | :title "`brule [ <label-exp> ] <term> => <term> .`" | |
| 2039 | :doc "Synonym of 'btrans'. | |
| 2040 | ") | |
| 2041 | ||
| 2042 | (define ("bcrule" "bcrl") | |
| 2043 | :category :element | |
| 2044 | :parser identity | |
| 2045 | :evaluator cafeobj-eval-module-element-proc | |
| 2046 | :related ("bctrans") | |
| 2047 | :title "`bcrule [ <label-exp> ] <term> => <term> if <term> .`" | |
| 2048 | :doc "Synonym of 'bctrans' | |
| 2049 | ") | |
| 2050 | ||
| 2051 | (define ("inspect" "inspect-term") | |
| 2018 | 2052 | :category :proof |
| 2019 | 2053 | :parser parse-inspect-term-command |
| 2020 | 2054 | :evaluator eval-ast |
| 2021 | :doc " | |
| 2055 | :title "`inspect <term>`" | |
| 2056 | :doc "Inspect the internal structure of <term>. | |
| 2022 | 2057 | ") |
| 2023 | 2058 | |
| 2024 | 2059 | (define ("pushd") |
| 2025 | 2060 | :category :misc |
| 2026 | 2061 | :parser parse-pushd-command |
| 2027 | 2062 | :evaluator eval-ast |
| 2063 | :title "`pushd <directory>`" | |
| 2028 | 2064 | :doc " |
| 2029 | 2065 | ") |
| 2030 | 2066 | |
| 2032 | 2068 | :category :misc |
| 2033 | 2069 | :parser parse-popd-command |
| 2034 | 2070 | :evaluator eval-ast |
| 2071 | :title "`popd`" | |
| 2035 | 2072 | :doc " |
| 2036 | 2073 | ") |
| 2037 | 2074 | |
| 2062 | 2099 | :category :inspect |
| 2063 | 2100 | :parser parse-name-command |
| 2064 | 2101 | :evaluator eval-ast |
| 2102 | :title "`names <mod-exp>` ." | |
| 2103 | :doc "List up all the named objects in module <mod-exp>. | |
| 2104 | ") | |
| 2105 | ||
| 2106 | (define ("scase") | |
| 2107 | :category :proof | |
| 2108 | :parser parse-case-command | |
| 2109 | :evaluator eval-ast | |
| 2110 | :title "`scase (<term>) in (<mod-exp>) as <name> { <decl> ..} : <term> .`" | |
| 2065 | 2111 | :doc " |
| 2066 | show | |
| 2067 | ") | |
| 2068 | ||
| 2069 | (define ("scase") | |
| 2070 | :category :proof | |
| 2071 | :parser parse-case-command | |
| 2072 | :evaluator eval-ast | |
| 2073 | :doc " | |
| 2074 | 2112 | ") |
| 2075 | 2113 | |
| 2076 | 2114 | (define ("sos" "passive") |
| 2077 | 2115 | :category :proof |
| 2078 | 2116 | :parser pignose-parse-sos |
| 2079 | 2117 | :evaluator eval-ast |
| 2118 | :title "`sos { = | + | - } { <clause> , ... }`" | |
| 2080 | 2119 | :doc "(pignose) |
| 2081 | 2120 | ") |
| 2082 | 2121 | |
| 2084 | 2123 | :category :proof |
| 2085 | 2124 | :parser pignose-parse-db |
| 2086 | 2125 | :evaluator eval-ast |
| 2126 | :title "`db reset`" | |
| 2087 | 2127 | :doc "(pignose) |
| 2088 | 2128 | ") |
| 2089 | 2129 | |
| 2091 | 2131 | :category :proof |
| 2092 | 2132 | :parser pignose-parse-clause |
| 2093 | 2133 | :evaluator eval-ast |
| 2134 | :title "`clause <term> .`" | |
| 2094 | 2135 | :doc "(pignose) |
| 2095 | 2136 | ") |
| 2096 | 2137 | |
| 2098 | 2139 | :category :proof |
| 2099 | 2140 | :parser pignose-parse-list-command |
| 2100 | 2141 | :evaluator eval-ast |
| 2142 | :title "`list { axiom | sos | usable | flag | param | option | demod }`" | |
| 2101 | 2143 | :doc "(pignose) |
| 2102 | 2144 | ") |
| 2103 | 2145 | |
| 2105 | 2147 | :category :proof |
| 2106 | 2148 | :parser pignose-parse-flag |
| 2107 | 2149 | :evaluator eval-ast |
| 2150 | :title "`flag(<name>, { on | off })`" | |
| 2108 | 2151 | :doc "(pignose) |
| 2109 | 2152 | ") |
| 2110 | 2153 | |
| 2112 | 2155 | :category :proof |
| 2113 | 2156 | :parser pignose-parse-param |
| 2114 | 2157 | :evaluator eval-ast |
| 2158 | :title "`param(<name>, <value>)`" | |
| 2115 | 2159 | :doc "(pignose) |
| 2116 | 2160 | ") |
| 2117 | 2161 | |
| 2119 | 2163 | :category :proof |
| 2120 | 2164 | :parser pignose-parse-option |
| 2121 | 2165 | :evaluator eval-ast |
| 2166 | :title "`option { reset | = <name> }`" | |
| 2122 | 2167 | :doc "(pignose) |
| 2123 | 2168 | ") |
| 2124 | 2169 | |
| 2126 | 2171 | :category :proof |
| 2127 | 2172 | :parser pignose-parse-resolve |
| 2128 | 2173 | :evaluator eval-ast |
| 2174 | :title "`resolve {. | <file-path> }`" | |
| 2129 | 2175 | :doc "(pignose) |
| 2130 | 2176 | ") |
| 2131 | 2177 | |
| 2140 | 2186 | :category :proof |
| 2141 | 2187 | :parser pignose-parse-save-option |
| 2142 | 2188 | :evaluator eval-ast |
| 2189 | :title "`save-option <name>`" | |
| 2143 | 2190 | :doc "(pignose) |
| 2144 | 2191 | ") |
| 2145 | 2192 | |
| 2147 | 2194 | :category :proof |
| 2148 | 2195 | :parser pignose-parse-sigmatch |
| 2149 | 2196 | :evaluator eval-ast |
| 2197 | :title "`sigmatch (<mod-exp>) to (<mod-exp>)`" | |
| 2150 | 2198 | :doc "(pignose) |
| 2151 | 2199 | ") |
| 2152 | 2200 | |
| 2154 | 2202 | :category :proof |
| 2155 | 2203 | :parser pignose-parse-lex |
| 2156 | 2204 | :evaluator eval-ast |
| 2205 | :title "`lex (<op>, ..., <op>)`" | |
| 2157 | 2206 | :doc "(pignose) |
| 2158 | 2207 | ") |
| 2159 | 2208 | |
| 2168 | 2217 | ") |
| 2169 | 2218 | |
| 2170 | 2219 | ;;; CITP commands |
| 2220 | (define ("citp") | |
| 2221 | :type :doc-only | |
| 2222 | :title "CITP" | |
| 2223 | :related (":goal" ":apply" ":ind" ":auto" ":roll" ":init" ":cp" ":equation" ":rule" ":backward" ":select" ":red" ":csp" ":csp-" ":ctf" ":ctf-" ":def" ":imp") | |
| 2224 | :doc "Constructor Based Induction Theorem Prover | |
| 2225 | ||
| 2226 | The sub-system provides a certain level of automatization for theorem proving. | |
| 2227 | ||
| 2228 | TODO TODO | |
| 2229 | ") | |
| 2230 | ||
| 2171 | 2231 | (define (":goal") |
| 2172 | 2232 | :category :proof |
| 2173 | 2233 | :parser citp-parse-goal |
| 2174 | 2234 | :evaluator eval-citp-goal |
| 2175 | :title "`:goal { <axiom> . ... }`" | |
| 2235 | :title "`:goal { <sentence> . ... }`" | |
| 2176 | 2236 | :doc "TODO" |
| 2177 | 2237 | ) |
| 2178 | 2238 | |
| 2180 | 2240 | :category :proof |
| 2181 | 2241 | :parser citp-parse-apply |
| 2182 | 2242 | :evaluator eval-citp-apply |
| 2243 | :related ("citp") | |
| 2183 | 2244 | :title "`:apply (<tactic> ...) [to <goal-name>]`" |
| 2184 | :doc "TODO" | |
| 2245 | :doc "Apply the list of tactics given within parenthesis to either | |
| 2246 | the current goal, or the goal given as `<goal-name>`." | |
| 2185 | 2247 | ) |
| 2186 | 2248 | |
| 2187 | 2249 | (define (":ind") |
| 2188 | 2250 | :category :proof |
| 2189 | 2251 | :parser citp-parse-ind-on |
| 2190 | 2252 | :evaluator eval-citp-ind-on |
| 2253 | :related ("citp") | |
| 2191 | 2254 | :title "`:ind on <variable> ... .`" |
| 2192 | :doc "TODO" | |
| 2255 | :doc "Defines the variable for the induction tactic of CITP." | |
| 2193 | 2256 | ) |
| 2194 | 2257 | |
| 2195 | 2258 | (define (":auto") |
| 2196 | 2259 | :category :proof |
| 2197 | 2260 | :parser citp-parse-auto |
| 2198 | 2261 | :evaluator eval-citp-apply |
| 2262 | :related ("citp") | |
| 2199 | 2263 | :title "`:auto`" |
| 2200 | :doc "TODO" | |
| 2264 | :doc "Applies the following set of tactics: `(SI CA TC IP RD)`." | |
| 2201 | 2265 | ) |
| 2202 | 2266 | |
| 2203 | 2267 | (define (":roll") |
| 2204 | 2268 | :category :proof |
| 2205 | 2269 | :parser citp-parse-roll-back |
| 2206 | 2270 | :evaluator eval-citp-roll-back |
| 2271 | :related ("citp") | |
| 2207 | 2272 | :title "`:roll back`" |
| 2208 | 2273 | :doc "TODO" |
| 2209 | 2274 | ) |
| 2212 | 2277 | :category :proof |
| 2213 | 2278 | :parser citp-parse-init |
| 2214 | 2279 | :evaluator eval-citp-init |
| 2215 | :title "`:init { \"[\" <label> \"]\" | \"(\" <axiom> \"\")} \"{\" <variable> <- <term>; ... \"}\"`" | |
| 2280 | :related ("citp") | |
| 2281 | :title "`:init { \"[\" <label> \"]\" | \"(\" <sentence> \"\")} by \"{\" <variable> <- <term>; ... \"}\"`" | |
| 2216 | 2282 | :doc "TODO" |
| 2217 | 2283 | ) |
| 2218 | 2284 | |
| 2285 | (define (":imply" ":imp") | |
| 2286 | :category :proof | |
| 2287 | :parser citp-parse-imp | |
| 2288 | :evaluator eval-citp-imp | |
| 2289 | :related ("citp") | |
| 2290 | :title "`:imp \"[\" <label> \"]\" by \"{\" <variable> <- <term>; ...\"}\"`" | |
| 2291 | :doc "TODO" | |
| 2292 | ) | |
| 2293 | ||
| 2219 | 2294 | (define (":cp") |
| 2220 | 2295 | :category :proof |
| 2221 | 2296 | :parser citp-parse-critical-pair |
| 2222 | 2297 | :evaluator eval-citp-critical-pair |
| 2223 | :title "`:cp { \"[\" <label> \"]\" | \"(\" <axiom> . \")\" } >< { \"[\" <label> \"]\" | \"(\" <axiom> .\")\" }`" | |
| 2224 | :doc "TODO" | |
| 2298 | :related ("citp") | |
| 2299 | :title "`:cp { \"[\" <label> \"]\" | \"(\" <sentense> . \")\" } >< { \"[\" <label> \"]\" | \"(\" <sentence> .\")\" }`" | |
| 2300 | :doc "TODO specify critical pair" | |
| 2225 | 2301 | ) |
| 2226 | 2302 | |
| 2227 | 2303 | (define (":equation") |
| 2229 | 2305 | :parser citp-parse-equation |
| 2230 | 2306 | :evaluator eval-citp-equation |
| 2231 | 2307 | :title "`:equation`" |
| 2308 | :related ("citp") | |
| 2232 | 2309 | :doc "TODO" |
| 2233 | 2310 | ) |
| 2234 | 2311 | |
| 2237 | 2314 | :parser citp-parse-equation |
| 2238 | 2315 | :evaluator eval-citp-equation |
| 2239 | 2316 | :title "`:rule`" |
| 2317 | :related ("citp") | |
| 2240 | 2318 | :doc "TODO" |
| 2241 | 2319 | ) |
| 2242 | 2320 | |
| 2245 | 2323 | :parser citp-parse-backward |
| 2246 | 2324 | :evaluator eval-citp-backward |
| 2247 | 2325 | :title "`:backward equation`" |
| 2326 | :related ("citp") | |
| 2248 | 2327 | :doc "TODO" |
| 2249 | 2328 | ) |
| 2250 | 2329 | |
| 2253 | 2332 | :parser citp-parse-select |
| 2254 | 2333 | :evaluator eval-citp-select |
| 2255 | 2334 | :title "`:select <goal-name>`" |
| 2256 | :doc "TODO" | |
| 2335 | :related ("citp") | |
| 2336 | :doc "Select a goal for further application of tactics." | |
| 2257 | 2337 | ) |
| 2258 | 2338 | |
| 2259 | 2339 | (define (":red" ":exec" ":bred") |
| 2260 | 2340 | :category :proof |
| 2261 | 2341 | :parser citp-parse-red |
| 2262 | 2342 | :evaluator eval-citp-red |
| 2263 | :title "`:lred <term> .`" | |
| 2264 | :doc "TODO" | |
| 2343 | :title "`{ :red | :exec | :bred } [in <goal-name> :] <term> .`" | |
| 2344 | :related ("citp") | |
| 2345 | :doc "reduce the term in specified goal <goal-name>. " | |
| 2265 | 2346 | ) |
| 2266 | 2347 | |
| 2267 | 2348 | (define (":verbose") |
| 2269 | 2350 | :parser citp-parse-verbose |
| 2270 | 2351 | :evaluator eval-citp-verbose |
| 2271 | 2352 | :title "`:verbose { on | off }`" |
| 2353 | :related ("citp") | |
| 2354 | :doc "Turns on verbose reporting of the CITP subsystem." | |
| 2355 | ) | |
| 2356 | ||
| 2357 | (define (":normalize") | |
| 2358 | :category :proof | |
| 2359 | :parser citp-parse-normalize | |
| 2360 | :evaluator eval-citp-normalize | |
| 2361 | :title "`:normalize { on | off}`" | |
| 2362 | :related ("citp") | |
| 2363 | :doc "Normalize the LHS of an instance of the axiom generated by :init command." | |
| 2364 | ) | |
| 2365 | ||
| 2366 | (define (":ctf") | |
| 2367 | :category :proof | |
| 2368 | :parser citp-parse-ctf | |
| 2369 | :evaluator eval-citp-ctf | |
| 2370 | :related ("citp" ":ctf-") | |
| 2371 | :title "`:ctf { eq [ <label-exp> ] <term> = <term> .}`" | |
| 2372 | :doc "TODO Applies case splitting after a set of boolean expressions." | |
| 2373 | ) | |
| 2374 | ||
| 2375 | (define (":ctf-") | |
| 2376 | :category :proof | |
| 2377 | :parser citp-parse-ctf | |
| 2378 | :evaluator eval-citp-ctf | |
| 2379 | :related ("citp" ":ctf") | |
| 2380 | :title "`:ctf- { eq [ <label-exp> ] <term> = <term> .}`" | |
| 2272 | 2381 | :doc "TODO" |
| 2273 | 2382 | ) |
| 2274 | 2383 | |
| 2275 | (define (":ctf") | |
| 2276 | :category :proof | |
| 2277 | :parser citp-parse-ctf | |
| 2278 | :evaluator eval-citp-ctf | |
| 2279 | :title "`:ctf { eq [ <op-exp> ]: <term> = <term> .`" | |
| 2384 | (define (":csp") | |
| 2385 | :category :proof | |
| 2386 | :parser citp-parse-csp | |
| 2387 | :evaluator eval-citp-csp | |
| 2388 | :related ("citp" ":csp-") | |
| 2389 | :title "`:csp { eq [ <label-exp>] <term> = <term> . ...}`" | |
| 2390 | :doc "TODO applies case splitting after general equations TODO" | |
| 2391 | ) | |
| 2392 | ||
| 2393 | (define (":csp-") | |
| 2394 | :category :proof | |
| 2395 | :parser citp-parse-csp | |
| 2396 | :evaluator eval-citp-csp | |
| 2397 | :related ("citp" ":csp") | |
| 2398 | :title "`:csp- { eq [ <label-exp>] <term> = <term> . ...}`" | |
| 2280 | 2399 | :doc "TODO" |
| 2281 | 2400 | ) |
| 2282 | 2401 | |
| 2283 | (define (":csp") | |
| 2284 | :category :proof | |
| 2285 | :parser citp-parse-csp | |
| 2286 | :evaluator eval-citp-csp | |
| 2287 | :title "`:csp { eq [ <op-exp>]: <term> = <term> . ...}`" | |
| 2288 | :doc "TODO" | |
| 2402 | (define (":def" ":define") | |
| 2403 | :category :proof | |
| 2404 | :parser citp-parse-define | |
| 2405 | :evaluator eval-citp-define | |
| 2406 | :related ("citp") | |
| 2407 | :title "`:def <symbol> = { <ctf> | <csp>}`" | |
| 2408 | :doc "Assigns a name to a specific case splitting (`ctf` or `csp`), | |
| 2409 | so that it can be used as tactics in `:apply`." | |
| 2410 | :example "````` | |
| 2411 | :def name-1 = ctf [ <Term> . ] | |
| 2412 | :def name-2 = ctf-{ eq LHS = RHS . } | |
| 2413 | :def name-3 = csp { eq lhs1 = rhs1 . eq lhs2 = rhs2 . } | |
| 2414 | :def name-4 = csp-{ eq lhs3 = rhs3 . eq lhs4 = rhs4 . } | |
| 2415 | :apply(SI TC name-1 name-2 name-3 name-4) | |
| 2416 | ````` | |
| 2417 | " | |
| 2289 | 2418 | ) |
| 2290 | 2419 | |
| 2291 | 2420 | (define (":show" ":sh") |
| 2293 | 2422 | :parser citp-parse-show |
| 2294 | 2423 | :evaluator eval-citp-show |
| 2295 | 2424 | :title "`:show <something>`" |
| 2296 | :related (":describe") | |
| 2425 | :related ("citp" ":describe") | |
| 2297 | 2426 | :doc "TODO") |
| 2298 | 2427 | |
| 2299 | 2428 | (define (":describe" ":desc") |
| 2301 | 2430 | :parser citp-parse-show |
| 2302 | 2431 | :evaluator eval-citp-show |
| 2303 | 2432 | :title "`:describe <something>`" |
| 2304 | :related (":show") | |
| 2305 | :doc "Similar to the `:show` command but with more details. See `:describe ?` for | |
| 2433 | :related ("citp" ":show") | |
| 2434 | :doc "Similar to the `:show` command but with more details. Call `:describe ?` for | |
| 2306 | 2435 | the possible set of invocations. |
| 2307 | 2436 | ") |
| 2308 | 2437 | |
| 2438 | (define (":spoiler") | |
| 2439 | :category :proof | |
| 2440 | :parser citp-parse-spoiler | |
| 2441 | :evaluator identity | |
| 2442 | :related ("citp") | |
| 2443 | :title "`:spoiler { on | off}`" | |
| 2444 | :doc "TODO" | |
| 2445 | ) | |
| 2446 | ||
| 2447 | (define (":set") | |
| 2448 | :category :proof | |
| 2449 | :parser citp-parse-set | |
| 2450 | :evaluator citp-eval-set | |
| 2451 | :title "`:set(<name>, { on | off | show })`" | |
| 2452 | :related ("citp") | |
| 2453 | :doc "Set or show various flags of CITP CafeOBJ. | |
| 2454 | ") | |
| 2455 | ||
| 2456 | (define (":binspect") | |
| 2457 | :category :proof | |
| 2458 | :parser parse-citp-binspect | |
| 2459 | :evaluator eval-citp-binspect | |
| 2460 | :title "`:binspect [in <goal-name> :] <boolean-term> .`" | |
| 2461 | :doc "TODO" | |
| 2462 | ) | |
| 2463 | ||
| 2464 | (define ("binspect") | |
| 2465 | :category :proof | |
| 2466 | :parser parse-citp-binspect | |
| 2467 | :evaluator eval-citp-binspect | |
| 2468 | :title "`binspect [in <module-name> :] <boolean-term> .`" | |
| 2469 | :doc "TODO" | |
| 2470 | ) | |
| 2471 | ||
| 2472 | (define ("bresolve" ":bresolve") | |
| 2473 | :category :proof | |
| 2474 | :parser identity | |
| 2475 | :evaluator bresolve | |
| 2476 | :title "`{bresolve | :bresolve}`" | |
| 2477 | :doc "TODO" | |
| 2478 | ) | |
| 2479 | ||
| 2480 | (define ("bshow" ":bshow") | |
| 2481 | :category :proof | |
| 2482 | :parser citp-parse-bshow | |
| 2483 | :evaluator bshow | |
| 2484 | :title "`{bshow | :bshow} [tree]`" | |
| 2485 | :doc "TODO" | |
| 2486 | ) | |
| 2309 | 2487 | ;;; |
| 2310 | ) ; end eval-when | |
| 2488 | ||
| 2489 | (define ("commands" "com") | |
| 2490 | :category :help | |
| 2491 | :parser identity | |
| 2492 | :evaluator show-cafeobj-main-commands | |
| 2493 | :title "`commands`" | |
| 2494 | :mdkey "help" | |
| 2495 | :doc "Print outs the list of main toplevel commands. | |
| 2496 | ") | |
| 2497 | ||
| 2498 | (define ("?com" "?command") | |
| 2499 | :category :help | |
| 2500 | :parser identity | |
| 2501 | :evaluator cafeobj-top-level-help | |
| 2502 | :mdkey "help-commands" | |
| 2503 | :title "`?com [ <term> ]`" | |
| 2504 | :doc "List commands or declarations categorized by the key <term>. | |
| 2505 | <term> is one of 'decl', 'module', 'parse', 'rewrite', | |
| 2506 | 'inspect', 'switch', 'proof', 'system', 'inspect', 'library', 'help', 'io' or 'misc'. | |
| 2507 | If <term> is omitted, the list of available <term> will be printed. | |
| 2508 | ") | |
| 2509 | ||
| 2510 | ;;; | |
| 2511 | ) ; end eval-when | |
| 2311 | 2512 | ;;; EOF |
| 0 | ;;;-*- Mode: Lisp; Syntax:CommonLisp; Package:CHAOS; Base:10 -*- | |
| 0 | ;;;-*- Mode: Lisp; Syntax:Common-Lisp; Package:CHAOS; Base:10 -*- | |
| 1 | 1 | ;;; |
| 2 | ;;; Copyright (c) 2000-2014, Toshimi Sawada. All rights reserved. | |
| 2 | ;;; Copyright (c) 2000-2015, Toshimi Sawada. All rights reserved. | |
| 3 | 3 | ;;; |
| 4 | 4 | ;;; Redistribution and use in source and binary forms, with or without |
| 5 | 5 | ;;; modification, are permitted provided that the following conditions |
| 69 | 69 | ;;; VISIBLE SORTS |
| 70 | 70 | |
| 71 | 71 | (defparameter SortDeclaration |
| 72 | ' (|[| (:upto (< |,| |]|) :sorts) | |
| 72 | '(|[| (:upto (< |,| |]|) :sorts) | |
| 73 | 73 | :append (:seq-of (:one-of (<) (|,|)) |
| 74 | 74 | (:upto (< |,| |]|) :sorts)) |
| 75 | 75 | |]|)) |
| 237 | 237 | |}|)) |
| 238 | 238 | |
| 239 | 239 | ;;;----------------------------------------------------------------------------- |
| 240 | ;;; RECORD DECLARATION | |
| 241 | ;;; *NOTE* class is not part of CafeOBJ language. | |
| 242 | ;;;----------------------------------------------------------------------------- | |
| 243 | #|| -- this is obsolete | |
| 244 | (defparameter R-C-Declaration | |
| 245 | '((:+ record class) :symbol (:optional (:! Supers)) |{| | |
| 246 | (:optional (:! Sv-pairs)) | |
| 247 | |}|)) | |
| 248 | ||# | |
| 249 | ;;;----------------------------------------------------------------------------- | |
| 250 | 240 | ;;; LET |
| 251 | 241 | ;;;----------------------------------------------------------------------------- |
| 252 | 242 | |
| 279 | 269 | |
| 280 | 270 | (defparameter EqDeclaration |
| 281 | 271 | '(eq :term = :term |.|)) |
| 282 | ;; (defparameter EqDeclaration | |
| 283 | ;; '(eq (:optional |[| (:seq-of :symbol (:upto (|]|))) |:|) :term = :term |.|)) | |
| 284 | 272 | (defparameter BEqDeclaration |
| 285 | 273 | '((:+ beq bq) :term = :term |.|)) |
| 286 | 274 | (defparameter CEQDeclaration |
| 317 | 305 | '((:+ inc including) (:if-present as :symbol) |(| :modexp |)|)) |
| 318 | 306 | |
| 319 | 307 | ) |
| 308 | ||
| 309 | ;;;----------------------------------------------------------------------------- | |
| 310 | ;;; CITP tactics | |
| 311 | ;;;----------------------------------------------------------------------------- | |
| 312 | (eval-when (:execute :compile-toplevel :load-toplevel) | |
| 313 | (defparameter CTF | |
| 314 | '((:+ |:ctf| |:ctf-|) | |
| 315 | (:one-of (|{| (:one-of #.EqDeclaration | |
| 316 | #.BeqDeclaration | |
| 317 | #.FoplAXDeclaration) | |
| 318 | |}|) | |
| 319 | (\[ :term |.| \])))) | |
| 320 | ||
| 321 | (defparameter CSP | |
| 322 | '((:+ |:csp| |:csp-|) | |
| 323 | |{| (:many-of #.EqDeclaration | |
| 324 | #.RlDeclaration | |
| 325 | #.BeqDeclaration | |
| 326 | #.BRLDeclaration | |
| 327 | #.FoplAXDeclaration) | |
| 328 | |}|)) | |
| 329 | ||
| 330 | ) | |
| 320 | 331 | |
| 321 | 332 | ;;;----------------------------------------------------------------------------- |
| 322 | 333 | ;;; THE SCHEME OF WHOLE ALLOWABLE INPUTS |
| 461 | 472 | (:if-present in :modexp |:|) |
| 462 | 473 | (:seq-of :term) |.|) |
| 463 | 474 | (version) |
| 464 | ;; | |
| 475 | ;; AUTO LOAD | |
| 465 | 476 | (autoload :symbol :symbol) |
| 477 | (no-autoload :symbol) | |
| 466 | 478 | ;; (stop at :term |.|) |
| 467 | 479 | ;; ((:+ rwt) limit :symbol) |
| 468 | 480 | (test (:+ reduction red execution exec) (:if-present in :modexp |:|) |
| 489 | 501 | ((:+ --> **>) :comment) |
| 490 | 502 | ((:+ -- **) :comment) |
| 491 | 503 | (parse (:rdr #..term-delimiting-chars. |
| 492 | (:if-present in :modexp |:|) (:seq-of :term) |.|)) | |
| 504 | (:if-present in :modexp |:|) (:seq-of :term) |.|)) | |
| 493 | 505 | ((:+ lisp ev eval evq lispq) |
| 494 | 506 | (:call (read))) |
| 495 | 507 | (;; (:+ show sh set select describe desc) ; do |
| 534 | 546 | (open :modexp |.|) |
| 535 | 547 | (close) |
| 536 | 548 | (start :term |.|) |
| 537 | ;; scase (<Term>) on (<Modexp>) as <Name> { <ModuleElements> } : <GoalTerm> . | |
| 538 | (scase |(| (:seq-of :term) |)| in |(| :modexp |)| as :symbol |{| | |
| 539 | (:many-of | |
| 540 | ;; MODULE IMPORTATIONS | |
| 541 | ;; *NOTE* imports { ... } is not in MANUAL, and does not have | |
| 542 | ;; translater to Chaos now. | |
| 543 | ((:+ imports import) | |
| 544 | |{| | |
| 545 | (:many-of | |
| 546 | #.ExDeclaration | |
| 547 | #.PrDeclaration | |
| 548 | #.UsDeclaration | |
| 549 | #.IncDeclaration | |
| 550 | ((:+ --> **>) :comment) | |
| 551 | ((:+ -- **) :comment) | |
| 552 | ) | |
| 553 | |}|) | |
| 554 | #.ExDeclaration | |
| 555 | #.PrDeclaration | |
| 556 | #.UsDeclaration | |
| 557 | #.IncDeclaration | |
| 558 | ||
| 559 | ;; SIGNATURE | |
| 560 | ((:+ sig signature) |{| | |
| 561 | (:many-of | |
| 562 | #.BSortDeclaration | |
| 563 | #.BHSortDeclaration | |
| 564 | #.HSortDeclaration | |
| 565 | #.SortDeclaration | |
| 566 | #.OperatorDeclaration | |
| 567 | #.BOperatorDeclaration | |
| 568 | #.PredicateDeclaration | |
| 569 | #.BPredicateDeclaration | |
| 570 | #.OperatorAttribute | |
| 571 | ;; #.R-C-Declaration | |
| 572 | ((:+ --> **>) :comment) | |
| 573 | ((:+ -- **) :comment) | |
| 574 | ) | |
| 575 | |}|) | |
| 576 | ||
| 577 | ;; AXIOMS | |
| 578 | ((:+ axiom axioms axs) |{| | |
| 579 | (:many-of | |
| 580 | #.LetDeclaration | |
| 581 | #.MacroDeclaration | |
| 582 | #.VarDeclaration | |
| 583 | #.VarsDeclaration | |
| 584 | #.EqDeclaration | |
| 585 | #.CeqDeclaration | |
| 586 | #.RlDeclaration | |
| 587 | #.CRlDeclaration | |
| 588 | #.BeqDeclaration | |
| 589 | #.BCeqDeclaration | |
| 590 | #.BRLDeclaration | |
| 591 | #.BCRLDeclaration | |
| 592 | #.FoplAXDeclaration | |
| 593 | #.FoplGoalDeclaration | |
| 594 | ((:+ --> **>) :comment) | |
| 595 | ((:+ -- **) :comment) | |
| 596 | ) | |
| 597 | |}|) | |
| 598 | ||
| 599 | ;; Module elements without signature/axioms. | |
| 600 | #.BSortDeclaration | |
| 601 | #.BHSortDeclaration | |
| 602 | #.SortDeclaration | |
| 603 | #.HSortDeclaration | |
| 604 | #.BHSortDeclaration | |
| 605 | ;; #.R-C-Declaration | |
| 606 | #.OperatorDeclaration | |
| 607 | #.BOperatorDeclaration | |
| 608 | #.PredicateDeclaration | |
| 609 | #.BPredicateDeclaration | |
| 610 | #.OperatorAttribute | |
| 611 | #.LetDeclaration | |
| 612 | #.MacroDeclaration | |
| 613 | #.VarDeclaration | |
| 614 | #.VarsDeclaration | |
| 615 | #.EqDeclaration | |
| 616 | #.BEqDeclaration | |
| 617 | #.CeqDeclaration | |
| 618 | #.BCeqDeclaration | |
| 619 | #.RlDeclaration | |
| 620 | #.CRlDeclaration | |
| 621 | #.BRlDeclaration | |
| 622 | #.BCRLDeclaration | |
| 623 | #.FoplAXDeclaration | |
| 624 | #.FoplGoalDeclaration | |
| 625 | ((:+ --> **>) :comment) | |
| 626 | ((:+ -- **) :comment) | |
| 627 | ||
| 628 | ;; Misc elements. | |
| 629 | ;; (parse :term |.|) | |
| 630 | ((:+ ev lisp evq lispq) (:call (read))) | |
| 631 | ;; allow sole ".", and do nothing | |
| 632 | (|.|) | |
| 633 | ) | |
| 634 | |}| | |
| 635 | |:| (:seq-of :term) |.|) | |
| 549 | ;; scase (<Term>) on (<Modexp>) as <Name> { <ModuleElements> } : <GoalTerm> . | |
| 550 | (scase |(| (:seq-of :term) |)| in |(| :modexp |)| as :symbol |{| | |
| 551 | (:many-of | |
| 552 | ;; MODULE IMPORTATIONS | |
| 553 | ;; *NOTE* imports { ... } is not in MANUAL, and does not have | |
| 554 | ;; translater to Chaos now. | |
| 555 | ((:+ imports import) | |
| 556 | |{| | |
| 557 | (:many-of | |
| 558 | #.ExDeclaration | |
| 559 | #.PrDeclaration | |
| 560 | #.UsDeclaration | |
| 561 | #.IncDeclaration | |
| 562 | ((:+ --> **>) :comment) | |
| 563 | ((:+ -- **) :comment) | |
| 564 | ) | |
| 565 | |}|) | |
| 566 | #.ExDeclaration | |
| 567 | #.PrDeclaration | |
| 568 | #.UsDeclaration | |
| 569 | #.IncDeclaration | |
| 570 | ||
| 571 | ;; SIGNATURE | |
| 572 | ((:+ sig signature) |{| | |
| 573 | (:many-of | |
| 574 | #.BSortDeclaration | |
| 575 | #.BHSortDeclaration | |
| 576 | #.HSortDeclaration | |
| 577 | #.SortDeclaration | |
| 578 | #.OperatorDeclaration | |
| 579 | #.BOperatorDeclaration | |
| 580 | #.PredicateDeclaration | |
| 581 | #.BPredicateDeclaration | |
| 582 | #.OperatorAttribute | |
| 583 | ;; #.R-C-Declaration | |
| 584 | ((:+ --> **>) :comment) | |
| 585 | ((:+ -- **) :comment) | |
| 586 | ) | |
| 587 | |}|) | |
| 588 | ||
| 589 | ;; AXIOMS | |
| 590 | ((:+ axiom axioms axs) |{| | |
| 591 | (:many-of | |
| 592 | #.LetDeclaration | |
| 593 | #.MacroDeclaration | |
| 594 | #.VarDeclaration | |
| 595 | #.VarsDeclaration | |
| 596 | #.EqDeclaration | |
| 597 | #.CeqDeclaration | |
| 598 | #.RlDeclaration | |
| 599 | #.CRlDeclaration | |
| 600 | #.BeqDeclaration | |
| 601 | #.BCeqDeclaration | |
| 602 | #.BRLDeclaration | |
| 603 | #.BCRLDeclaration | |
| 604 | #.FoplAXDeclaration | |
| 605 | #.FoplGoalDeclaration | |
| 606 | ((:+ --> **>) :comment) | |
| 607 | ((:+ -- **) :comment) | |
| 608 | ) | |
| 609 | |}|) | |
| 610 | ||
| 611 | ;; Module elements without signature/axioms. | |
| 612 | #.BSortDeclaration | |
| 613 | #.BHSortDeclaration | |
| 614 | #.SortDeclaration | |
| 615 | #.HSortDeclaration | |
| 616 | #.BHSortDeclaration | |
| 617 | ;; #.R-C-Declaration | |
| 618 | #.OperatorDeclaration | |
| 619 | #.BOperatorDeclaration | |
| 620 | #.PredicateDeclaration | |
| 621 | #.BPredicateDeclaration | |
| 622 | #.OperatorAttribute | |
| 623 | #.LetDeclaration | |
| 624 | #.MacroDeclaration | |
| 625 | #.VarDeclaration | |
| 626 | #.VarsDeclaration | |
| 627 | #.EqDeclaration | |
| 628 | #.BEqDeclaration | |
| 629 | #.CeqDeclaration | |
| 630 | #.BCeqDeclaration | |
| 631 | #.RlDeclaration | |
| 632 | #.CRlDeclaration | |
| 633 | #.BRlDeclaration | |
| 634 | #.BCRLDeclaration | |
| 635 | #.FoplAXDeclaration | |
| 636 | #.FoplGoalDeclaration | |
| 637 | ((:+ --> **>) :comment) | |
| 638 | ((:+ -- **) :comment) | |
| 639 | ||
| 640 | ;; Misc elements. | |
| 641 | ;; (parse :term |.|) | |
| 642 | ((:+ ev lisp evq lispq) (:call (read))) | |
| 643 | ;; allow sole ".", and do nothing | |
| 644 | (|.|) | |
| 645 | ) | |
| 646 | |}| | |
| 647 | |:| (:seq-of :term) |.|) | |
| 636 | 648 | ;; trace/untrace |
| 637 | 649 | ((:+ trace untrace) :symbol) |
| 638 | 650 | ;; apply |
| 670 | 682 | (provide :symbol) |
| 671 | 683 | (require :top-term) |
| 672 | 684 | (autoload :symbol :symbol) |
| 673 | ;; for testing delimiters | |
| 674 | (delimiter (:+ = + -) | |
| 675 | |{| | |
| 676 | (:upto (|}|) :chars) | |
| 677 | :append (:seq-of (:upto (|}|) :chars)) | |
| 678 | |}|) | |
| 679 | ;; | |
| 680 | (delim) | |
| 685 | ;; for testing delimiters | |
| 686 | (delimiter (:+ = + -) | |
| 687 | |{| | |
| 688 | (:upto (|}|) :chars) | |
| 689 | :append (:seq-of (:upto (|}|) :chars)) | |
| 690 | |}|) | |
| 691 | ;; | |
| 692 | (delim) | |
| 681 | 693 | ;; PigNose commands |
| 682 | 694 | #+:bigpink (db reset) |
| 683 | 695 | #+:bigpink ((:+ sos passive) (:+ = + -) |
| 726 | 738 | (! :top-term) ; shell escape |
| 727 | 739 | (|.|) |
| 728 | 740 | ;; (chaos :args) |
| 729 | ;; new commands as of 2011/Q1 | |
| 730 | (? :args) ; help/messege description | |
| 741 | ;; new commands as of 2011/Q1 | |
| 742 | (? :args) ; help/messege description | |
| 731 | 743 | (?? :args) ; detailed help |
| 732 | ;; new commands as of 2012/Q1 | |
| 733 | ((:+ names name) :modexp |.|) | |
| 734 | (look up (:if-present in :modexp |:|) (:seq-of :top-opname)) | |
| 735 | ;; term inspector | |
| 736 | ((:+ inspect inspect-term) :args) | |
| 737 | ;; generate reference manual | |
| 738 | (gendoc :symbol) | |
| 739 | (?example :args) | |
| 740 | (?ex :args) | |
| 741 | (?apropos :comment) | |
| 742 | (?ap :comment) | |
| 743 | ;; CITP commands | |
| 744 | (|:goal| |{| (:many-of #.EqDeclaration | |
| 745 | #.CeqDeclaration | |
| 746 | #.RlDeclaration | |
| 747 | #.CRlDeclaration | |
| 748 | #.BeqDeclaration | |
| 749 | #.BCeqDeclaration | |
| 750 | #.BRLDeclaration | |
| 751 | #.BCRLDeclaration) | |
| 752 | |}|) | |
| 753 | (|:apply| (:if-present to (:symbol)) (|(| (:seq-of :symbol) |)|)) | |
| 754 | (|:auto|) | |
| 755 | (|:ind| (:+ on |:on|) |(| (:seq-of :term) |)|) | |
| 756 | (|:roll| (:+ back |:back|)) | |
| 757 | (|:init| (:one-of (|(| (:one-of #.EqDeclaration | |
| 758 | #.CeqDeclaration | |
| 759 | #.RlDeclaration | |
| 760 | #.CRlDeclaration | |
| 761 | #.BeqDeclaration | |
| 762 | #.BCeqDeclaration | |
| 763 | #.BRLDeclaration | |
| 764 | #.BCRLDeclaration) | |
| 765 | |)|) | |
| 766 | (\[ (:symbol) \])) | |
| 767 | |by| |{| ((:! SubstList)) |}|) | |
| 768 | (|:cp| (:one-of (|(| (:one-of #.EqDeclaration | |
| 769 | #.CeqDeclaration | |
| 770 | #.RlDeclaration | |
| 771 | #.CRlDeclaration | |
| 772 | #.BeqDeclaration | |
| 773 | #.BCeqDeclaration | |
| 774 | #.BRLDeclaration | |
| 775 | #.BCRLDeclaration) | |
| 776 | |)|) | |
| 777 | (\[ (:symbol) \])) | |
| 778 | >< | |
| 779 | (:one-of (|(| (:one-of #.EqDeclaration | |
| 780 | #.CeqDeclaration | |
| 781 | #.RlDeclaration | |
| 782 | #.CRlDeclaration | |
| 783 | #.BeqDeclaration | |
| 784 | #.BCeqDeclaration | |
| 785 | #.BRLDeclaration | |
| 786 | #.BCRLDeclaration) | |
| 787 | |)|) | |
| 788 | (\[ (:symbol) \]))) | |
| 789 | ((:+ |:equation| |:rule|)) | |
| 790 | (|:backward| (:+ equation rule |:equation| |:rule|)) | |
| 791 | (|:select| (:symbol)) | |
| 792 | ((:+ |:red| |lred| |:lred| |:exec| |:bred|) | |
| 793 | (:rdr #..term-delimiting-chars. (:if-present in :symbol |:|)) (:seq-of :term) |.|) | |
| 794 | (|:verbose| :symbol) | |
| 795 | (|:ctf| |{| #.EqDeclaration |}|) | |
| 796 | (|:csp| |{| (:many-of #.EqDeclaration | |
| 797 | #.RlDeclaration | |
| 798 | #.BeqDeclaration | |
| 799 | #.BRLDeclaration) | |
| 800 | |}|) | |
| 801 | ((:+ |:show| |:sh| |:describe| |:desc|) :args) | |
| 802 | )) ; end Top-Form | |
| 744 | ;; new commands as of 2012/Q1 | |
| 745 | ((:+ names name) :modexp |.|) | |
| 746 | (look up (:if-present in :modexp |:|) (:seq-of :top-opname)) | |
| 747 | ;; term inspector | |
| 748 | ((:+ inspect inspect-term) :args) | |
| 749 | ;; generate reference manual | |
| 750 | (gendoc :symbol) | |
| 751 | (?example :args) | |
| 752 | (?ex :args) | |
| 753 | (?apropos :comment) | |
| 754 | (?ap :comment) | |
| 755 | ((:+ ?com ?command) :args) | |
| 756 | ((:+ command commands com)) | |
| 757 | ;; CITP commands | |
| 758 | (|:goal| |{| (:many-of #.EqDeclaration | |
| 759 | #.CeqDeclaration | |
| 760 | #.RlDeclaration | |
| 761 | #.CRlDeclaration | |
| 762 | #.BeqDeclaration | |
| 763 | #.BCeqDeclaration | |
| 764 | #.BRLDeclaration | |
| 765 | #.BCRLDeclaration | |
| 766 | #.FoplAXDeclaration) | |
| 767 | |}|) | |
| 768 | (|:apply| (:if-present to (:symbol)) (|(| (:seq-of :symbol) |)|)) | |
| 769 | (|:auto|) | |
| 770 | (|:ind| (:+ on |:on|) |(| (:seq-of :term) |)|) | |
| 771 | (|:roll| (:+ back |:back|)) | |
| 772 | (|:init| (:one-of (|(| (:one-of #.EqDeclaration | |
| 773 | #.CeqDeclaration | |
| 774 | #.RlDeclaration | |
| 775 | #.CRlDeclaration | |
| 776 | #.BeqDeclaration | |
| 777 | #.BCeqDeclaration | |
| 778 | #.BRLDeclaration | |
| 779 | #.BCRLDeclaration | |
| 780 | #.FoplAXDeclaration) | |
| 781 | |)|) | |
| 782 | (\[ (:symbol) \])) | |
| 783 | |by| |{| ((:! SubstList)) |}|) | |
| 784 | ((:+ |:imply| |:imp|) (\[ (:symbol) \]) | |
| 785 | |by| |{| ((:! SubstList)) |}|) | |
| 786 | (|:cp| (:one-of (|(| (:one-of #.EqDeclaration | |
| 787 | #.CeqDeclaration | |
| 788 | #.RlDeclaration | |
| 789 | #.CRlDeclaration | |
| 790 | #.BeqDeclaration | |
| 791 | #.BCeqDeclaration | |
| 792 | #.BRLDeclaration | |
| 793 | #.BCRLDeclaration | |
| 794 | #.FoplGoalDeclaration) | |
| 795 | |)|) | |
| 796 | (\[ (:symbol) \])) | |
| 797 | >< | |
| 798 | (:one-of (|(| (:one-of #.EqDeclaration | |
| 799 | #.CeqDeclaration | |
| 800 | #.RlDeclaration | |
| 801 | #.CRlDeclaration | |
| 802 | #.BeqDeclaration | |
| 803 | #.BCeqDeclaration | |
| 804 | #.BRLDeclaration | |
| 805 | #.BCRLDeclaration | |
| 806 | #.FoplGoalDeclaration) | |
| 807 | |)|) | |
| 808 | (\[ (:symbol) \]))) | |
| 809 | ((:+ |:equation| |:rule|)) | |
| 810 | (|:backward| (:+ equation rule |:equation| |:rule|)) | |
| 811 | (|:select| (:symbol)) | |
| 812 | ((:+ |:red| |lred| |:lred| |:exec| |:bred|) | |
| 813 | (:rdr #..term-delimiting-chars. (:if-present in :symbol |:|)) (:seq-of :term) |.|) | |
| 814 | (|:verbose| :symbol) | |
| 815 | ;; (|:normalize| :symbol) | |
| 816 | #.CTF | |
| 817 | #.CSP | |
| 818 | ((:+ |:show| |:sh| |:describe| |:desc|) :args) | |
| 819 | ((:+ |:def| |:define|) :symbol = (:one-of #.CTF | |
| 820 | #.CSP | |
| 821 | (|(| (:seq-of :symbol) |)|))) | |
| 822 | (|:spoiler| (:one-of (on) (off) (|.|))) | |
| 823 | (|:binspect| | |
| 824 | (:rdr #..term-delimiting-chars. (:if-present in :symbol |:|)) (:seq-of :term) |.|) | |
| 825 | (binspect | |
| 826 | (:rdr #..term-delimiting-chars. (:if-present in :modexp |:|)) (:seq-of :term) |.|) | |
| 827 | ((:+ |:bresolve| bresolve)) | |
| 828 | ((:+ |:bshow| bshow) :args) | |
| 829 | (|:set| |(| :symbol |,| (:+ on off set clear ? show) |)|) | |
| 830 | )) ; end Top-Form | |
| 803 | 831 | |
| 804 | 832 | ;; some separated definitions of non-terminals. |
| 805 | 833 | ;; -------------------------------------------------- |
| 806 | 834 | ;; subterm specifier |
| 807 | 835 | |
| 808 | 836 | (Selector (:one-of |
| 809 | (|{| :int :append (:seq-of |,| :int) |}|) | |
| 810 | (|(| (:seq-of :int) |)|) | |
| 811 | (\[ :int (:optional |..| :int) \]))) | |
| 837 | (|{| :int :append (:seq-of |,| :int) |}|) | |
| 838 | (|(| (:seq-of :int) |)|) | |
| 839 | (\[ :int (:optional |..| :int) \]))) | |
| 812 | 840 | |
| 813 | 841 | ;; parameter part |
| 814 | 842 | ;; (Params (\[ (:! Param) :append (:seq-of |,| (:! Param)) \])) |
| 815 | 843 | (Param (:one-of-default |
| 816 | (:symbols |::| (:upto (|,| \] \)) :modexp)) | |
| 817 | ((:+ ex extending us using pr protecting inc including) | |
| 818 | :symbols |::| (:upto (|,| \] \)) :modexp)))) | |
| 819 | ||
| 820 | ;; importation modexp | |
| 821 | #|| not used | |
| 822 | (ImportModexp (:symbol :modexp)) | |
| 823 | (IM (:one-of-default | |
| 824 | (:modexp) | |
| 825 | (|::| :modexp))) | |
| 826 | ||# | |
| 827 | ;; (sortConst | |
| 828 | ;; (:one-of-default | |
| 829 | ;; (:sorts) | |
| 830 | ;; (:symbol = { :term |:| :sorts }))) | |
| 831 | ||
| 832 | #|| obsolete | |
| 833 | ;; super reference. | |
| 834 | (Supers (\[ (:! Super) :append (:seq-of |,| (:! Super)) \])) | |
| 835 | (Super ((:upto (|,| \]) :super))) | |
| 836 | ;; slot/value pairs | |
| 837 | (SV-Pairs ((:! Sv-pair) :append (:seq-of (:! Sv-pair)))) | |
| 838 | (Sv-Pair (:one-of-default | |
| 839 | (:symbol (:upto (|}|)) (:one-of (|:| :sort) | |
| 840 | (= |(| :term |)| |:| :sort))) | |
| 841 | ((:+ -- **) :comment) | |
| 842 | ((:+ --> **>) :comment))) | |
| 843 | ||# | |
| 844 | (:symbols |::| (:upto (|,| \] \)) :modexp)) | |
| 845 | ((:+ ex extending us using pr protecting inc including) | |
| 846 | :symbols |::| (:upto (|,| \] \)) :modexp)))) | |
| 847 | ||
| 844 | 848 | ;; Substitution |
| 845 | 849 | ;; variable-1 <- term-1; ... variable-n <- term-n; |
| 846 | 850 | ;; (SubstList ((:! Subst) :append (:seq-of (:! Subst) (:upto (|}|))))) |
| 847 | 851 | (SubstList ((:! Subst) :append (:seq-of (:! Subst)))) |
| 848 | 852 | ;; (Subst ((:term <- :term) |;|)) |
| 849 | 853 | (Subst ((:symbol <- :term) |;|)) |
| 850 | )) ; end of *cafeobj-scheme* | |
| 851 | ) ; end eval-when | |
| 854 | )) ; end of *cafeobj-scheme* | |
| 855 | ) ; end eval-when | |
| 852 | 856 | |
| 853 | 857 | |
| 854 | 858 | ;;; EOF |
| 4 | 4 | File: declarations.lisp |
| 5 | 5 | ==============================================================================|# |
| 6 | 6 | ;;; |
| 7 | ;;; Copyright (c) 2000-2014, Toshimi Sawada. All rights reserved. | |
| 7 | ;;; Copyright (c) 2000-2015, Toshimi Sawada. All rights reserved. | |
| 8 | 8 | ;;; |
| 9 | 9 | ;;; Redistribution and use in source and binary forms, with or without |
| 10 | 10 | ;;; modification, are permitted provided that the following conditions |
| 145 | 145 | :evaluator eval-ast) |
| 146 | 146 | |
| 147 | 147 | (define ("eq" "cq" "ceq" "rule" "rl" "crl" "crule" "trans" "ctrans" "tr" "ctr" |
| 148 | "beq" "bceq" "brule" "brl" "bcrule" "bcrl" "btrans" "btr" | |
| 149 | "bctrans" "bctr") | |
| 148 | "beq" "bceq" "brule" "brl" "bcrule" "bcrl" "btrans" "btr" | |
| 149 | "bctrans" "bctr") | |
| 150 | 150 | :type :inner-module |
| 151 | 151 | :category :axiom |
| 152 | 152 | :parser process-axiom-form |
| 237 | 237 | :evaluator eval-decl-do-nothing) |
| 238 | 238 | |
| 239 | 239 | ;;; |
| 240 | ) ; end eval-when | |
| 240 | ) ; end eval-when | |
| 241 | 241 | ;;; EOF |
| 4 | 4 | File: define.lisp |
| 5 | 5 | ==============================================================================|# |
| 6 | 6 | ;;; |
| 7 | ;;; Copyright (c) 2000-2014, Toshimi Sawada. All rights reserved. | |
| 7 | ;;; Copyright (c) 2000-2015, Toshimi Sawada. All rights reserved. | |
| 8 | ;;; Copyright (c) 2014-2015, Norbert Preining. All rights reserved. | |
| 8 | 9 | ;;; |
| 9 | 10 | ;;; Redistribution and use in source and binary forms, with or without |
| 10 | 11 | ;;; modification, are permitted provided that the following conditions |
| 44 | 45 | (defvar *cafeobj-declarations* (make-hash-table :test #'equal)) |
| 45 | 46 | |
| 46 | 47 | (defstruct (comde (:print-function print-comde)) |
| 47 | (key "" :type string) ; command/declaration keyword | |
| 48 | (type nil :type symbol) ; command or declaration | |
| 49 | (category nil :type symbol) ; kind of command/declaration | |
| 50 | (parser nil :type symbol) ; parser function | |
| 51 | (evaluator nil :type symbol) ; evaluator function | |
| 48 | (key "" :type string) ; command/declaration keyword | |
| 49 | (type nil :type symbol) ; command or declaration | |
| 50 | (category nil :type symbol) ; kind of command/declaration | |
| 51 | (parser nil :type symbol) ; parser function | |
| 52 | (evaluator nil :type symbol) ; evaluator function | |
| 52 | 53 | ) |
| 53 | 54 | |
| 54 | 55 | (defparameter .valid-comde-types. '(:top :inner-module :doc-only)) |
| 55 | 56 | (defparameter .valid-decl-categories. |
| 56 | '(:decl-toplevel ; toplevel declaration, such as 'module', 'view', e.t.c. | |
| 57 | ; i.e., declarations which can apper at toplevel. | |
| 58 | :signature ; signature part of module body, such as 'op' '[', e.t.c | |
| 59 | :axiom ; axiom part of mdoule body, such as 'eq, ceq', e.t.c | |
| 60 | :ignore ; comments, dot (.), lisp, ev, e.t.c. | |
| 61 | :import ; import part of module body, such as 'protecting' | |
| 57 | '(:decl-toplevel ; toplevel declaration, such as 'module', 'view', e.t.c. | |
| 58 | ; i.e., declarations which can apper at toplevel. | |
| 59 | :signature ; signature part of module body, such as 'op' '[', e.t.c | |
| 60 | :axiom ; axiom part of mdoule body, such as 'eq, ceq', e.t.c | |
| 61 | :ignore ; comments, dot (.), lisp, ev, e.t.c. | |
| 62 | :import ; import part of module body, such as 'protecting' | |
| 62 | 63 | :misc |
| 63 | 64 | )) |
| 64 | 65 | |
| 65 | 66 | (defparameter .valid-com-categories. |
| 66 | '(:decl-toplevel ; toplevel declaration, such as 'module', 'view', e.t.c. | |
| 67 | :checker ; check command | |
| 68 | :module ; apply some modifications to a module, such as regularize | |
| 69 | :rewrite ; commands related to rewriting, such as 'reduce', 'execute', e.t.c. | |
| 70 | :parse ; commands related to parsing terms, such as 'parse', e.t.c | |
| 71 | :inspect ; commands inspecting modules, terms, such as 'show', 'match', e.t.c | |
| 72 | :module-element ; declarations which can apper when a module is open. | |
| 73 | :proof ; commands related to proof stuff, such as 'open', 'apply, e.t.c. | |
| 74 | :switch ; 'set' commands | |
| 75 | :system ; various system related commands, such as 'protect', 'reset', e.t.c. | |
| 76 | :library ; library related commands, such as 'autoload', 'provide', e.t.c. | |
| 77 | :help ; '?', '??' | |
| 78 | :io ; 'input', 'save', e.t.c. | |
| 79 | :misc ; | |
| 67 | '(:decl ; toplevel declaration, such as 'module', 'view', e.t.c. | |
| 68 | :checker ; check command | |
| 69 | :rewrite ; commands related to rewriting, such as 'reduce', 'execute', e.t.c. | |
| 70 | :parse ; commands related to parsing terms, such as 'parse', e.t.c | |
| 71 | :inspect ; commands inspecting modules, terms, such as 'show', 'match', e.t.c | |
| 72 | :element ; declarations which can apper when a module is open. | |
| 73 | :proof ; commands related to proof stuff, such as 'open', 'apply, e.t.c. | |
| 74 | :switch ; 'set' commands | |
| 75 | :system ; various system related commands, such as 'protect', 'reset', e.t.c. | |
| 76 | :library ; library related commands, such as 'autoload', 'provide', e.t.c. | |
| 77 | :help ; '?', '??' | |
| 78 | :io ; 'input', 'save', e.t.c. | |
| 79 | :misc ; | |
| 80 | 80 | )) |
| 81 | 81 | |
| 82 | 82 | (defun print-comde (me &optional (stream *standard-output*) &rest ignore) |
| 87 | 87 | (format stream "~% parser : ~a" (comde-parser me)) |
| 88 | 88 | (format stream "~% evaluator : ~a" (comde-evaluator me))) |
| 89 | 89 | |
| 90 | (defparameter .category-descriptions. | |
| 91 | '((decl "CafeOBJ top-level declarations, such as 'module', 'view'.") | |
| 92 | (element "Declarations of module constructs, such as 'op', 'eq' ...") | |
| 93 | (parse "Commands parsing a term in the specified context.") | |
| 94 | (rewrite "Invokes term rewriting engine in various manner.") | |
| 95 | (inspect "Inspecting everhthing you want.") | |
| 96 | (switch "Commands controlling system's behavior.") | |
| 97 | (proof "Theorem proving commands.") | |
| 98 | (checker "Commands checking interesting properties of a module.") | |
| 99 | (library "Library related commands.") | |
| 100 | (system "System related commands.") | |
| 101 | (io "File input/output commands.") | |
| 102 | (misc "Miscellaneous commands.") | |
| 103 | (help "Online help commands."))) | |
| 90 | 104 | ;;; |
| 91 | 105 | ;;; get-command-info |
| 92 | 106 | ;;; |
| 118 | 132 | ;;; DEFINE |
| 119 | 133 | ;;; |
| 120 | 134 | (defmacro define ((&rest keys) &key (type :top) |
| 121 | (category :misc) | |
| 122 | (parser nil) | |
| 123 | (evaluator 'eval-ast) | |
| 124 | (doc nil) | |
| 125 | (title nil) | |
| 126 | (example nil) | |
| 127 | (related nil) | |
| 128 | (mdkey nil)) | |
| 135 | (category :misc) | |
| 136 | (parser nil) | |
| 137 | (evaluator 'eval-ast) | |
| 138 | (doc nil) | |
| 139 | (title nil) | |
| 140 | (example nil) | |
| 141 | (related nil) | |
| 142 | (mdkey nil)) | |
| 129 | 143 | (case type |
| 130 | 144 | (:top (unless (member category .valid-com-categories.) |
| 131 | (error "Internal error, invalid category ~s" category))) | |
| 145 | (error "Internal error, invalid category ~s" category))) | |
| 132 | 146 | (:inner-module (unless (member category .valid-decl-categories.) |
| 133 | (error "Internal error, invalid category ~s" category))) | |
| 147 | (error "Internal error, invalid category ~s" category))) | |
| 134 | 148 | (:doc-only) |
| 135 | 149 | (:otherwise (error "Internal error, invalid type ~s" type))) |
| 136 | 150 | (unless (eq type :doc-only) |
| 139 | 153 | ;; |
| 140 | 154 | `(progn |
| 141 | 155 | (unless (eq ,type :doc-only) |
| 142 | (let ((hash (if (or (eq ,type :top) | |
| 143 | (eq ,category :decl-toplevel)) | |
| 144 | *cafeobj-top-commands* | |
| 145 | *cafeobj-declarations*))) | |
| 146 | (dolist (key ',keys) | |
| 147 | (setf (gethash key hash) (make-comde :key key | |
| 148 | :type ',type | |
| 149 | :category ',category | |
| 150 | :parser ',parser | |
| 151 | :evaluator ',evaluator))))) | |
| 156 | (let ((hash (if (or (eq ,type :top) | |
| 157 | (eq ,category :decl-toplevel)) | |
| 158 | *cafeobj-top-commands* | |
| 159 | *cafeobj-declarations*))) | |
| 160 | (dolist (key ',keys) | |
| 161 | (setf (gethash key hash) (make-comde :key key | |
| 162 | :type ',type | |
| 163 | :category ',category | |
| 164 | :parser ',parser | |
| 165 | :evaluator ',evaluator))))) | |
| 152 | 166 | ;; set online help |
| 153 | (register-online-help (car ',keys) (cdr ',keys) ',title ',mdkey ',doc ',example ',related))) | |
| 167 | (register-online-help (car ',keys) (cdr ',keys) ',title ',mdkey ',doc ',example ',related ',category))) | |
| 154 | 168 | |
| 155 | 169 | (defun print-comde-usage (com) |
| 156 | 170 | (format t "~&[Usage] ~s, not yet" com)) |
| 4 | 4 | File: oldoc.lisp |
| 5 | 5 | ==============================================================================|# |
| 6 | 6 | ;;; |
| 7 | ;;; Copyright (c) 2000-2014, Toshimi Sawada. All rights reserved. | |
| 8 | ;;; Copyright (c) 2014, Norbert Preining. All rights reserved. | |
| 7 | ;;; Copyright (c) 2000-2015, Toshimi Sawada. All rights reserved. | |
| 8 | ;;; Copyright (c) 2014-2015, Norbert Preining. All rights reserved. | |
| 9 | 9 | ;;; |
| 10 | 10 | ;;; Redistribution and use in source and binary forms, with or without |
| 11 | 11 | ;;; modification, are permitted provided that the following conditions |
| 86 | 86 | ;; (after some mangling) a list of strings as "question" |
| 87 | 87 | ;; |
| 88 | 88 | ;; Example: |
| 89 | ;; ? clean me | |
| 89 | ;; ? clean me | |
| 90 | 90 | ;; will call the various ? related functions with |
| 91 | 91 | ;; question = ("clean" "me") |
| 92 | 92 | ;; |
| 150 | 150 | (oldoc-search-all question) |
| 151 | 151 | (let ((doc (oldoc-find-doc-entry question))) |
| 152 | 152 | (if (not (listp doc)) |
| 153 | (oldoc-format-documentation doc :raw nil :main main :example example :related related) | |
| 154 | (progn | |
| 155 | (if doc | |
| 156 | (format t "Did you mean one of ~a~%" doc)) | |
| 157 | nil))))) | |
| 158 | ||
| 159 | ||
| 160 | ||
| 153 | (oldoc-format-documentation doc :raw nil :main main :example example :related related) | |
| 154 | (progn | |
| 155 | (if doc | |
| 156 | (format t "Did you mean one of ~a~%" doc)) | |
| 157 | nil))))) | |
| 158 | ||
| 159 | ;; oldoc-list-categories | |
| 160 | ;; | |
| 161 | (declaim (special .category-descriptions. .valid-com-categories.)) | |
| 162 | ||
| 163 | (defun oldoc-list-categories (cat) | |
| 164 | (unless cat | |
| 165 | (format t "** ======================================================================~%") | |
| 166 | (format t "COMMAND CLASSES:~%") | |
| 167 | (format t "'?com <class>' shows the list of commands classified by <class>.~2%") | |
| 168 | (format t "class~10Tdescription~%") | |
| 169 | (format t "-------------------------------------------------------------------------~%") | |
| 170 | (dolist (entry .category-descriptions.) | |
| 171 | (format t "~a~10T~a~%" (first entry) (second entry))) | |
| 172 | (return-from oldoc-list-categories nil)) | |
| 173 | ;; gather commands | |
| 174 | (unless (member (car cat) .valid-com-categories. | |
| 175 | :test #'(lambda (x y) (string-equal x (symbol-name y)))) | |
| 176 | (with-output-chaos-error ('invalid-category) | |
| 177 | (format t "System does not know the command class '~a'.~%" (car cat)) | |
| 178 | (format t "Type '?cat' for the list of available class names."))) | |
| 179 | (let ((docs (oldoc-get-documents-by-category (car cat)))) | |
| 180 | (unless docs | |
| 181 | (with-output-chaos-warning () | |
| 182 | (format t "Sorry, the commands classified as '~a' not found." (car cat))) | |
| 183 | (return-from oldoc-list-categories nil)) | |
| 184 | (format t "The list of commands classified as '~a'.~%" (car cat)) | |
| 185 | (format t "Type '? <command-name>' for the online document of <command-name>.~%") | |
| 186 | (format t "==========================================================================") | |
| 187 | (do* ((dl docs (cdr dl)) | |
| 188 | (doc (car dl) (car dl)) | |
| 189 | (n 0 (1+ n))) | |
| 190 | ((endp dl)) | |
| 191 | (let ((key (car doc)) | |
| 192 | (desc (cdr doc))) | |
| 193 | (format t "~%~a~% ~a" key (format-markdown (oldoc-title desc))))))) | |
| 161 | 194 | |
| 162 | 195 | ;; |
| 163 | 196 | ;; INTERNAL functioons |
| 168 | 201 | (defvar *cafeobj-alias-db* (make-hash-table :test #'equal)) |
| 169 | 202 | |
| 170 | 203 | (defstruct (oldoc (:print-function print-online-document)) |
| 171 | (key "" :type string) ; | |
| 172 | (main "" :type string) ; document string of commad/declaration | |
| 204 | (key "" :type string) ; | |
| 205 | (category nil :type symbol) ; cateogry name of the subject | |
| 206 | (main "" :type string) ; document string of commad/declaration | |
| 173 | 207 | (title "" :type string) ; title |
| 174 | 208 | (rtitle "" :type string) ; reduced title for search |
| 175 | 209 | (example "" :type string) ; examples |
| 176 | 210 | (mdkey "" :type string) ; key written to reference manual |
| 177 | (names nil :type list) ; | |
| 211 | (names nil :type list) ; | |
| 178 | 212 | (related nil :type list) ; related commands |
| 179 | (cache nil) ; formatted doc cache for online help | |
| 213 | (cache nil) ; formatted doc cache for online help | |
| 180 | 214 | ) |
| 181 | 215 | |
| 182 | 216 | (defun print-online-document (doc &optional (stream *standard-output*) &rest ignore) |
| 189 | 223 | (format stream "~&example : ~a" (oldoc-example doc)) |
| 190 | 224 | (format stream "~&names : ~a" (oldoc-names doc)) |
| 191 | 225 | (format stream "~&related : ~a" (oldoc-related doc)) |
| 192 | (format stream "~&cache : ~a" (oldoc-cache doc))) | |
| 226 | (format stream "~&cache : ~a" (oldoc-cache doc)) | |
| 227 | (format stream "~&cateogry : ~a" (oldoc-category doc))) | |
| 193 | 228 | |
| 194 | 229 | (defun oldoc-make-key (whatever) |
| 195 | 230 | whatever) |
| 200 | 235 | |
| 201 | 236 | (defun oldoc-find-doc-entry (question) |
| 202 | 237 | (let* ((redss (oldoc-reduce-string (oldoc-question-to-string question))) |
| 203 | (key (oldoc-make-key redss)) | |
| 204 | (docref (gethash key *cafeobj-alias-db*))) | |
| 238 | (key (oldoc-make-key redss)) | |
| 239 | (docref (gethash key *cafeobj-alias-db*))) | |
| 205 | 240 | (if docref |
| 206 | (gethash docref *cafeobj-doc-db*) | |
| 241 | (gethash docref *cafeobj-doc-db*) | |
| 207 | 242 | ;; search for similar names |
| 208 | 243 | (let* ((similar-keys nil) (redsslen (length redss))) |
| 209 | (maphash #'(lambda (k v) | |
| 210 | (if (and (>= (length (oldoc-rtitle v)) redsslen) | |
| 211 | (string-equal redss (subseq (oldoc-rtitle v) 0 redsslen))) | |
| 212 | (push (cons k (list (oldoc-title v))) similar-keys) | |
| 213 | (dolist (n (oldoc-names v)) | |
| 214 | (if (and (>= (length n) redsslen) | |
| 215 | (string-equal redss (subseq n 0 redsslen))) | |
| 216 | (progn | |
| 217 | (push (cons k (list (oldoc-title v))) similar-keys) | |
| 218 | (return)))))) | |
| 219 | *cafeobj-doc-db*) | |
| 220 | ;; if only one similar name is found, return the entry for it | |
| 221 | (if (= 1 (length similar-keys)) | |
| 222 | (gethash (car (car similar-keys)) *cafeobj-doc-db*) | |
| 223 | ;; otherwise generate the list of " quoted possible names | |
| 224 | (map 'list #'(lambda (x) (concatenate 'string "\"" x "\"")) | |
| 225 | (apply #'append (map 'list 'cdr similar-keys)))))))) | |
| 244 | (maphash #'(lambda (k v) | |
| 245 | (if (and (>= (length (oldoc-rtitle v)) redsslen) | |
| 246 | (string-equal redss (subseq (oldoc-rtitle v) 0 redsslen))) | |
| 247 | (push (cons k (list (oldoc-title v))) similar-keys) | |
| 248 | (dolist (n (oldoc-names v)) | |
| 249 | (if (and (>= (length n) redsslen) | |
| 250 | (string-equal redss (subseq n 0 redsslen))) | |
| 251 | (progn | |
| 252 | (push (cons k (list (oldoc-title v))) similar-keys) | |
| 253 | (return)))))) | |
| 254 | *cafeobj-doc-db*) | |
| 255 | ;; if only one similar name is found, return the entry for it | |
| 256 | (if (= 1 (length similar-keys)) | |
| 257 | (gethash (car (car similar-keys)) *cafeobj-doc-db*) | |
| 258 | ;; otherwise generate the list of " quoted possible names | |
| 259 | (map 'list #'(lambda (x) (concatenate 'string "\"" x "\"")) | |
| 260 | (apply #'append (map 'list 'cdr similar-keys)))))))) | |
| 226 | 261 | |
| 227 | 262 | (defun oldoc-format-related (doc &key (raw nil)) |
| 228 | 263 | (let (outlist targetdoc targettitle) |
| 229 | 264 | (dolist (r (oldoc-related doc)) |
| 230 | 265 | (if (atom r) |
| 231 | (progn | |
| 232 | (setq targettitle (format nil "`~a`" r)) | |
| 233 | (setq targetdoc (oldoc-find-doc-entry (list r)))) | |
| 234 | (progn | |
| 235 | (setq targettitle (car r)) | |
| 236 | (if (cdr r) | |
| 237 | (setq targetdoc (oldoc-find-doc-entry (cdr r))) | |
| 238 | (setq targetdoc (oldoc-find-doc-entry (list (car r))))))) | |
| 266 | (progn | |
| 267 | (setq targettitle (format nil "`~a`" r)) | |
| 268 | (setq targetdoc (oldoc-find-doc-entry (list r)))) | |
| 269 | (progn | |
| 270 | (setq targettitle (car r)) | |
| 271 | (if (cdr r) | |
| 272 | (setq targetdoc (oldoc-find-doc-entry (cdr r))) | |
| 273 | (setq targetdoc (oldoc-find-doc-entry (list (car r))))))) | |
| 239 | 274 | (if (listp targetdoc) |
| 240 | ; problem - found several entries | |
| 241 | (if targetdoc | |
| 242 | (if raw | |
| 243 | (push (format nil "\[~a\]\(\#~a\)" targettitle "multiple_targets") outlist) | |
| 244 | (push (format nil "~a" targettitle) outlist)) | |
| 245 | (if raw | |
| 246 | (push (format nil "\[~a\]\(\#~a\)" targettitle "target_not_found") outlist) | |
| 247 | (push (format nil "~a" targettitle) outlist))) | |
| 248 | (if raw | |
| 249 | (push (format nil "\[~a\]\(\#~a\)" targettitle (oldoc-mdkey targetdoc)) outlist) | |
| 250 | (push (format nil "~a" targettitle) outlist)))) | |
| 275 | ; problem - found several entries | |
| 276 | (if targetdoc | |
| 277 | (if raw | |
| 278 | (push (format nil "\[~a\]\(\#~a\)" targettitle "multiple_targets") outlist) | |
| 279 | (push (format nil "~a" targettitle) outlist)) | |
| 280 | (if raw | |
| 281 | (push (format nil "\[~a\]\(\#~a\)" targettitle "target_not_found") outlist) | |
| 282 | (push (format nil "~a" targettitle) outlist))) | |
| 283 | (if raw | |
| 284 | (push (format nil "\[~a\]\(\#~a\)" targettitle (oldoc-mdkey targetdoc)) outlist) | |
| 285 | (push (format nil "~a" targettitle) outlist)))) | |
| 251 | 286 | (if outlist |
| 252 | (format nil "~{~a~^, ~}" outlist) | |
| 253 | ""))) | |
| 287 | (format nil "~{~a~^, ~}" outlist) | |
| 288 | ""))) | |
| 254 | 289 | |
| 255 | 290 | (defun oldoc-format-documentation (doc &key (raw nil) (main t) (example nil) (related t)) |
| 256 | 291 | (let ((outstr "") |
| 257 | (title (oldoc-title doc)) | |
| 258 | (mainstr (oldoc-main doc)) | |
| 259 | (exstr (oldoc-example doc)) | |
| 260 | (relstr (oldoc-format-related doc :raw raw)) | |
| 261 | (usecache (and main related (not raw) (not example)))) | |
| 292 | (title (oldoc-title doc)) | |
| 293 | (mainstr (oldoc-main doc)) | |
| 294 | (exstr (oldoc-example doc)) | |
| 295 | (relstr (oldoc-format-related doc :raw raw)) | |
| 296 | (usecache (and main related (not raw) (not example)))) | |
| 262 | 297 | (if (not raw) |
| 263 | (or (and usecache (oldoc-cache doc)) | |
| 264 | (progn | |
| 265 | (if main | |
| 266 | (setq outstr (format nil "~a~2%~a~2%" title mainstr))) | |
| 267 | ; related dealing | |
| 268 | (if (and related (not (string-equal relstr ""))) | |
| 269 | (setq outstr (format nil "~aRelated: ~a~2%" outstr relstr))) | |
| 270 | ; example dealing | |
| 271 | (if (not (string-equal exstr "")) | |
| 272 | ; we have examples available | |
| 273 | (if main | |
| 274 | (if (not example) | |
| 275 | (setq outstr (format nil "~a(Examples available)~2%" outstr)) | |
| 276 | (setq outstr (format nil "~aExamples:~%~a" outstr exstr))) | |
| 277 | (if (not example) | |
| 278 | ; huu? don't show main and don't show examples? | |
| 279 | (setq outstr (format nil "~a(Nothing to show?)~%" outstr)) | |
| 280 | ; don't show main, but examples, add also title! | |
| 281 | (setq outstr (format nil "Example(s) for ~a~2%~a" title exstr))))) | |
| 282 | ; manage cache | |
| 283 | (if usecache | |
| 284 | (setf (oldoc-cache doc) (format-markdown outstr)) | |
| 285 | (format-markdown outstr)))) | |
| 286 | (progn | |
| 287 | ;; case for raw output | |
| 288 | (setq outstr (format nil "## ~a ## {#~a}~2%" title (oldoc-mdkey doc))) | |
| 289 | (if main | |
| 290 | (setq outstr (format nil "~a~a~2%" outstr mainstr))) | |
| 291 | (if (and related (not (string-equal relstr ""))) | |
| 292 | (setq outstr (format nil "~aRelated: ~a~2%" outstr relstr))) | |
| 293 | (if (and example (not (string-equal exstr ""))) | |
| 294 | (setq outstr (format nil "~a### Example ###~2%~a~2%" outstr exstr))) | |
| 295 | outstr)))) | |
| 298 | (or (and usecache (oldoc-cache doc)) | |
| 299 | (progn | |
| 300 | (if main | |
| 301 | (setq outstr (format nil "~a~2%~a~2%" title mainstr))) | |
| 302 | ; related dealing | |
| 303 | (if (and related (not (string-equal relstr ""))) | |
| 304 | (setq outstr (format nil "~aRelated: ~a~2%" outstr relstr))) | |
| 305 | ; example dealing | |
| 306 | (if (not (string-equal exstr "")) | |
| 307 | ; we have examples available | |
| 308 | (if main | |
| 309 | (if (not example) | |
| 310 | (setq outstr (format nil "~a(Examples available)~2%" outstr)) | |
| 311 | (setq outstr (format nil "~aExamples:~%~a" outstr exstr))) | |
| 312 | (if (not example) | |
| 313 | ; huu? don't show main and don't show examples? | |
| 314 | (setq outstr (format nil "~a(Nothing to show?)~%" outstr)) | |
| 315 | ; don't show main, but examples, add also title! | |
| 316 | (setq outstr (format nil "Example(s) for ~a~2%~a" title exstr))))) | |
| 317 | ; manage cache | |
| 318 | (if usecache | |
| 319 | (setf (oldoc-cache doc) (format-markdown outstr)) | |
| 320 | (format-markdown outstr)))) | |
| 321 | (progn | |
| 322 | ;; case for raw output | |
| 323 | (setq outstr (format nil "## ~a ## {#~a}~2%" title (oldoc-mdkey doc))) | |
| 324 | (if main | |
| 325 | (setq outstr (format nil "~a~a~2%" outstr mainstr))) | |
| 326 | (if (and related (not (string-equal relstr ""))) | |
| 327 | (setq outstr (format nil "~aRelated: ~a~2%" outstr relstr))) | |
| 328 | (if (and example (not (string-equal exstr ""))) | |
| 329 | (setq outstr (format nil "~a### Example ###~2%~a~2%" outstr exstr))) | |
| 330 | outstr)))) | |
| 296 | 331 | |
| 297 | 332 | |
| 298 | 333 | ; (defun show-doc-entries () |
| 301 | 336 | ; (setq keys (sort keys #'string<=)) |
| 302 | 337 | ; (dolist (key keys) |
| 303 | 338 | ; (let ((oldoc (get-document-string-from-doc (gethash key *cafeobj-doc-db*)))) |
| 304 | ; (format t "~s" oldoc))))) | |
| 339 | ; (format t "~s" oldoc))))) | |
| 305 | 340 | |
| 306 | 341 | ;;; |
| 307 | 342 | ;;; search for an arbitrary regexp in all main strs, and return |
| 325 | 360 | \\z | (?=([\\s]+)) | (?!^)(?=[\"']) |
| 326 | 361 | ) |
| 327 | 362 | )" |
| 328 | :extended-mode t))) | |
| 363 | :extended-mode t))) | |
| 329 | 364 | (map 'list #'(lambda (x) (if (not (string-equal x "")) (push (string-trim "\"'" x) outlst))) |
| 330 | (cl-ppcre:all-matches-as-strings re str)) | |
| 365 | (cl-ppcre:all-matches-as-strings re str)) | |
| 331 | 366 | outlst)) |
| 332 | 367 | |
| 333 | 368 | (defun oldoc-search-all (question) |
| 334 | 369 | ; oldoc is special as ?ap is using the :comment reader, which means we |
| 335 | 370 | ; get one string till the end of line as argument. |
| 336 | 371 | (let ((retstr "") (matching-docs nil) |
| 337 | (matchers (map 'list #'(lambda (x) | |
| 338 | (if (oldoc-is-regex x) | |
| 339 | (handler-case | |
| 340 | ; we might get a string that is not a proper regexp, | |
| 341 | ; in this case fall back to use it as substring search | |
| 342 | (let ((re (cl-ppcre:create-scanner x :case-insensitive-mode :multi-line-mode))) | |
| 343 | (lambda (y) (cl-ppcre:scan re y))) | |
| 344 | (cl-ppcre:ppcre-syntax-error (condition) | |
| 345 | (format t "[Error] Cannot parse as regexp: ~S~%Treating it as normal string!~%" | |
| 346 | (cl-ppcre:ppcre-syntax-error-string condition)) | |
| 347 | (lambda (y) (search x y)))) | |
| 348 | (lambda (y) (search x y)))) | |
| 349 | (oldoc-parse-to-words (car question))))) | |
| 372 | (matchers (map 'list #'(lambda (x) | |
| 373 | (if (oldoc-is-regex x) | |
| 374 | (handler-case | |
| 375 | ; we might get a string that is not a proper regexp, | |
| 376 | ; in this case fall back to use it as substring search | |
| 377 | (let ((re (cl-ppcre:create-scanner x :case-insensitive-mode :multi-line-mode))) | |
| 378 | (lambda (y) (cl-ppcre:scan re y))) | |
| 379 | (cl-ppcre:ppcre-syntax-error (condition) | |
| 380 | (format t "[Error] Cannot parse as regexp: ~S~%Treating it as normal string!~%" | |
| 381 | (cl-ppcre:ppcre-syntax-error-string condition)) | |
| 382 | (lambda (y) (search x y)))) | |
| 383 | (lambda (y) (search x y)))) | |
| 384 | (oldoc-parse-to-words (car question))))) | |
| 350 | 385 | (maphash #'(lambda (key oldoc) |
| 351 | (declare (ignore key)) | |
| 352 | (let* ((fullss (oldoc-reduce-string (format nil "~a~%~{~a~^~%~}~a~%~a" | |
| 353 | (oldoc-title oldoc) | |
| 354 | (oldoc-names oldoc) | |
| 355 | (oldoc-main oldoc) | |
| 356 | (oldoc-example oldoc)))) | |
| 357 | (found (every #'identity | |
| 358 | (map 'list #'(lambda (x) | |
| 359 | (apply x (list fullss))) matchers)))) | |
| 360 | (when found | |
| 361 | (push (oldoc-title oldoc) matching-docs)))) | |
| 362 | *cafeobj-doc-db*) | |
| 363 | ; create the return string from the list of found keys | |
| 386 | (declare (ignore key)) | |
| 387 | (let* ((fullss (oldoc-reduce-string (format nil "~a~%~{~a~^~%~}~a~%~a" | |
| 388 | (oldoc-title oldoc) | |
| 389 | (oldoc-names oldoc) | |
| 390 | (oldoc-main oldoc) | |
| 391 | (oldoc-example oldoc)))) | |
| 392 | (found (every #'identity | |
| 393 | (map 'list #'(lambda (x) | |
| 394 | (apply x (list fullss))) matchers)))) | |
| 395 | (when found | |
| 396 | (push (oldoc-title oldoc) matching-docs)))) | |
| 397 | *cafeobj-doc-db*) | |
| 398 | ; create the return string from the list of found keys | |
| 364 | 399 | (when matching-docs |
| 365 | 400 | (setq retstr (format nil "Found the following matches:~% . ~{~a~^~% . ~}" matching-docs))) |
| 366 | 401 | (if (string= retstr "") |
| 367 | (setq retstr (format nil "No matches found!~%"))) | |
| 402 | (setq retstr (format nil "No matches found!~%"))) | |
| 368 | 403 | retstr)) |
| 369 | 404 | |
| 370 | 405 | ;;; |
| 373 | 408 | ;;; |
| 374 | 409 | |
| 375 | 410 | |
| 376 | (defun register-online-help (mainname aliasnames title mdkey doc example related) | |
| 411 | (defun register-online-help (mainname aliasnames title mdkey doc example related &optional (category 'misc)) | |
| 377 | 412 | (unless doc (return-from register-online-help nil)) |
| 378 | 413 | (unless (stringp doc) (return-from register-online-help nil)) |
| 379 | 414 | ; for each key generated from any name we generate an entry |
| 382 | 417 | (let ((mainkey (oldoc-make-key mainname))) |
| 383 | 418 | (dolist (name (cons mainname aliasnames)) |
| 384 | 419 | (let ((key (oldoc-make-key name))) |
| 385 | (setf (gethash key *cafeobj-alias-db*) mainkey))) | |
| 420 | (setf (gethash key *cafeobj-alias-db*) mainkey))) | |
| 386 | 421 | ; if the tile is not given, we use the mainname enclosed in ` ` |
| 387 | 422 | ; if the mdkey is not given, we use the mainname as is |
| 388 | 423 | (let* ((dt (or title (concatenate 'string "`" mainname "`"))) |
| 389 | (rt (oldoc-reduce-string dt))) | |
| 424 | (rt (oldoc-reduce-string dt))) | |
| 390 | 425 | (setf (gethash mainkey *cafeobj-doc-db*) |
| 391 | (make-oldoc :key mainkey | |
| 392 | :main doc | |
| 393 | :title dt | |
| 394 | :rtitle rt | |
| 395 | :mdkey (or mdkey mainname) | |
| 396 | :example (or example "") | |
| 397 | :related related | |
| 398 | :names (cons mainname aliasnames)))))) | |
| 426 | (make-oldoc :key mainkey | |
| 427 | :main doc | |
| 428 | :title dt | |
| 429 | :rtitle rt | |
| 430 | :mdkey (or mdkey (funcall #~s/^:/citp-/ mainname)) | |
| 431 | :example (or example "") | |
| 432 | :related related | |
| 433 | :names (cons mainname aliasnames) | |
| 434 | :category category))))) | |
| 399 | 435 | |
| 400 | 436 | ;; |
| 401 | 437 | ;; format-markdown and oldoc-reduce-string are similar, but serve different |
| 415 | 451 | |
| 416 | 452 | (defun format-markdown (str) |
| 417 | 453 | (funcall .md-replace-bq. |
| 418 | (funcall .md-replace-tilde. | |
| 419 | (funcall .md-remove-code-sign. | |
| 420 | (funcall .md-remove-link2. | |
| 421 | (funcall .md-remove-link. | |
| 422 | (funcall .md-remove-hash-hash. str))))))) | |
| 454 | (funcall .md-replace-tilde. | |
| 455 | (funcall .md-remove-code-sign. | |
| 456 | (funcall .md-remove-link2. | |
| 457 | (funcall .md-remove-link. | |
| 458 | (funcall .md-remove-hash-hash. str))))))) | |
| 423 | 459 | |
| 424 | 460 | (defun oldoc-reduce-string (str) |
| 425 | 461 | (funcall .md-remove-bq. |
| 426 | 462 | (funcall .md-remove-link2. |
| 427 | 463 | (funcall .md-remove-link. |
| 428 | (funcall .md-remove-hash-hash. str))))) | |
| 464 | (funcall .md-remove-hash-hash. str))))) | |
| 429 | 465 | |
| 430 | 466 | |
| 431 | 467 | |
| 435 | 471 | ;;; |
| 436 | 472 | (defvar .out-done. (make-hash-table :test #'equal)) |
| 437 | 473 | |
| 474 | ; refman-sort determines the order in the reference manual based on the | |
| 475 | ; keys. For now we simply sort alphabetically but ignore leading : | |
| 476 | ; from the CITP commands, so that | |
| 477 | ; :foobar | |
| 478 | ; is sorted near f and not at the beginning. | |
| 479 | (defun refman-sort (a b) | |
| 480 | (let ((aa (funcall #~s/^:// a)) (bb (funcall #~s/^:// b))) | |
| 481 | (string-lessp aa bb))) | |
| 482 | ||
| 438 | 483 | (defun export-refman (&optional (output "manual/md/reference.md")) |
| 439 | 484 | (clrhash .out-done.) |
| 440 | 485 | (let (data) |
| 441 | 486 | (with-open-file (out output :direction :output :if-exists :supersede :if-does-not-exist :create) |
| 442 | 487 | (maphash #'(lambda (k oldoc) |
| 443 | (let ((docstr (oldoc-format-documentation oldoc :raw t :main t :example t))) | |
| 444 | (unless docstr | |
| 445 | (error "The document string not found for ~s." k)) | |
| 446 | ; we would like to use the reduced title as sort criteria | |
| 447 | ; but in this case we get problems with entries like | |
| 448 | ; [sys:]module which is sorted around [ which is bad. | |
| 449 | ; TODO: add a key sort string or recognize []? | |
| 450 | ; (push (cons (oldoc-rtitle oldoc) docstr) data))) | |
| 451 | (push (cons k docstr) data))) | |
| 452 | *cafeobj-doc-db*) | |
| 453 | (setq data (sort data #'string-lessp :key #'car)) | |
| 488 | (let ((docstr (oldoc-format-documentation oldoc :raw t :main t :example t))) | |
| 489 | (unless docstr | |
| 490 | (error "The document string not found for ~s." k)) | |
| 491 | ; we would like to use the reduced title as sort criteria | |
| 492 | ; but in this case we get problems with entries like | |
| 493 | ; [sys:]module which is sorted around [ which is bad. | |
| 494 | ; TODO: add a key sort string or recognize []? | |
| 495 | ; (push (cons (oldoc-rtitle oldoc) docstr) data))) | |
| 496 | (push (cons k docstr) data))) | |
| 497 | *cafeobj-doc-db*) | |
| 498 | (setq data (sort data #'refman-sort :key #'car)) | |
| 454 | 499 | (dolist (d data) |
| 455 | (unless (gethash (car d) .out-done.) | |
| 456 | (format out "~a" (cdr d)) | |
| 457 | (setf (gethash (car d) .out-done.) t)))))) | |
| 500 | (unless (gethash (car d) .out-done.) | |
| 501 | (format out "~a" (cdr d)) | |
| 502 | (setf (gethash (car d) .out-done.) t)))))) | |
| 458 | 503 | |
| 459 | 504 | ;;; |
| 460 | 505 | ;;; show-undocumented |
| 467 | 512 | (declare (ignore ignore)) |
| 468 | 513 | (let ((docs nil)) |
| 469 | 514 | (maphash #'(lambda (key oldoc) |
| 470 | (declare (ignore key)) | |
| 471 | (let* ((str (oldoc-main oldoc)) | |
| 472 | (doc (cl-ppcre:split "\\s+" str))) | |
| 473 | (when (or (null doc) | |
| 474 | (null (cdr doc)) | |
| 475 | (funcall .todo. str)) | |
| 476 | (push oldoc docs)))) | |
| 477 | *cafeobj-doc-db*) | |
| 515 | (declare (ignore key)) | |
| 516 | (let* ((str (oldoc-main oldoc)) | |
| 517 | (doc (cl-ppcre:split "\\s+" str))) | |
| 518 | (when (or (null doc) | |
| 519 | (null (cdr doc)) | |
| 520 | (funcall .todo. str)) | |
| 521 | (push oldoc docs)))) | |
| 522 | *cafeobj-doc-db*) | |
| 478 | 523 | (setq docs (sort docs #'string<= :key #'oldoc-key)) |
| 479 | 524 | (format t "~%The following commands/declarations/concepts are not yet documented.") |
| 480 | 525 | (dolist (doc docs) |
| 481 | 526 | (format t "~%** key : ~s" (oldoc-key doc)) |
| 482 | 527 | (format t "~& names : ~s" (oldoc-names doc))))) |
| 483 | 528 | |
| 529 | ;; oldoc-get-documents-by-category | |
| 530 | ;; returns the list of | |
| 531 | (defun oldoc-get-documents-by-category (cat) | |
| 532 | (let ((coms nil)) | |
| 533 | (maphash #'(lambda (key oldoc) | |
| 534 | (let ((oldoc-cat (oldoc-category oldoc))) | |
| 535 | (when (string-equal cat (symbol-name oldoc-cat)) | |
| 536 | (push (cons key oldoc) coms)))) | |
| 537 | *cafeobj-doc-db*) | |
| 538 | (sort coms #'ob< :key #'car))) | |
| 539 | ||
| 484 | 540 | ;;; EOF |
| 0 | 0 | ;;;-*- Mode:LISP; Package:CHAOS; Base:10; Syntax:Common-lisp -*- |
| 1 | 1 | ;;; |
| 2 | ;;; Copyright (c) 2000-2014, Toshimi Sawada. All rights reserved. | |
| 2 | ;;; Copyright (c) 2000-2015, Toshimi Sawada. All rights reserved. | |
| 3 | 3 | ;;; |
| 4 | 4 | ;;; Redistribution and use in source and binary forms, with or without |
| 5 | 5 | ;;; modification, are permitted provided that the following conditions |
| 27 | 27 | ;;; |
| 28 | 28 | (in-package :chaos) |
| 29 | 29 | #|============================================================================== |
| 30 | System: CHAOS | |
| 31 | Module: cafeobj | |
| 32 | File: trans-com.lisp | |
| 30 | System: CHAOS | |
| 31 | Module: cafeobj | |
| 32 | File: trans-com.lisp | |
| 33 | 33 | ==============================================================================|# |
| 34 | 34 | #-:chaos-debug |
| 35 | 35 | (declaim (optimize (speed 3) (safety 0) #-GCL (debug 0))) |
| 45 | 45 | ;;; ***************************** |
| 46 | 46 | (defun parse-in-context-modexp-with-term (e) |
| 47 | 47 | (let (modexp |
| 48 | preterm) | |
| 48 | preterm) | |
| 49 | 49 | (if (= 4 (length e)) |
| 50 | (progn | |
| 51 | (setq modexp (parse-modexp (cadr (cadr e)))) | |
| 52 | (setq preterm (nth 2 e))) | |
| 53 | (progn | |
| 54 | (setq modexp nil) | |
| 55 | (setq preterm (nth 1 e)))) | |
| 50 | (progn | |
| 51 | (setq modexp (parse-modexp (cadr (cadr e)))) | |
| 52 | (setq preterm (nth 2 e))) | |
| 53 | (progn | |
| 54 | (setq modexp nil) | |
| 55 | (setq preterm (nth 1 e)))) | |
| 56 | 56 | (values modexp preterm))) |
| 57 | 57 | |
| 58 | 58 | ;;; "reduce" [ "in" <Modexp> ":" ] <Term> . |
| 99 | 99 | (defun parse-test-reduction (e &rest ignore) |
| 100 | 100 | (declare (ignore ignore)) |
| 101 | 101 | (let ((mode-spec (second e)) |
| 102 | (mode nil)) | |
| 102 | (mode nil)) | |
| 103 | 103 | (case-equal mode-spec |
| 104 | 104 | (("exec" "execute") (setq mode :exec)) |
| 105 | 105 | (("reduce" "red") (setq mode :red)) |
| 106 | 106 | (("behavioural-reduce" "bred") (setq mode :bred)) |
| 107 | 107 | (t (with-output-chaos-error ('invalid-op) |
| 108 | (format t "invalid `test' command option ~S" mode)) | |
| 109 | )) | |
| 108 | (format t "invalid `test' command option ~S" mode)) | |
| 109 | )) | |
| 110 | 110 | (setq e (cddr e)) |
| 111 | 111 | (let ((modexp nil) |
| 112 | (preterm nil) | |
| 113 | (expect nil)) | |
| 112 | (preterm nil) | |
| 113 | (expect nil)) | |
| 114 | 114 | (cond ((and (consp (car e)) (equal "in" (caar e))) |
| 115 | (setf modexp (parse-modexp (second (car e)))) | |
| 116 | (setf preterm (second e)) | |
| 117 | (setf expect (fourth e))) | |
| 118 | (t (setf modexp nil) | |
| 119 | (setf preterm (first e)) | |
| 120 | (setf expect (third e)))) | |
| 115 | (setf modexp (parse-modexp (second (car e)))) | |
| 116 | (setf preterm (second e)) | |
| 117 | (setf expect (fourth e))) | |
| 118 | (t (setf modexp nil) | |
| 119 | (setf preterm (first e)) | |
| 120 | (setf expect (third e)))) | |
| 121 | 121 | (%test-reduce* preterm expect modexp mode)))) |
| 122 | 122 | |
| 123 | 123 | ;;; **** |
| 126 | 126 | (defun parse-tram-command (inp &rest ignore) |
| 127 | 127 | (declare (ignore ignore)) |
| 128 | 128 | (let ((args (cadr inp)) |
| 129 | (command nil)) | |
| 129 | (command nil)) | |
| 130 | 130 | (case-equal (car inp) |
| 131 | 131 | (("red" "reduce") (setq command :reduce)) |
| 132 | 132 | (("exec" "execute") (setq command :execute)) |
| 133 | 133 | (("compile") (setq command :compile)) |
| 134 | 134 | (("reset") (setq command :reset)) |
| 135 | 135 | (otherwise (with-output-chaos-error () |
| 136 | (format t "unknown tram command ~a" (car inp))))) | |
| 136 | (format t "unknown tram command ~a" (car inp))))) | |
| 137 | 137 | (if (eq command :compile) |
| 138 | (let ((debug nil)) | |
| 139 | (loop | |
| 140 | (case-equal (car args) | |
| 141 | (("-a" "-all" "-e" "-exec") | |
| 142 | (setq command :compile-all) | |
| 143 | (setq args (cdr args))) | |
| 144 | (("-d" "-debug") | |
| 145 | (setq debug t) | |
| 146 | (setq args (cdr args))) | |
| 147 | (t (return nil)))) | |
| 148 | (%make-tram :command command :modexp args :debug debug)) | |
| 149 | (multiple-value-bind (modexp preterm) | |
| 150 | (parse-in-context-modexp-with-term inp) | |
| 151 | (%make-tram :command command :modexp modexp :term preterm))))) | |
| 152 | ||
| 138 | (let ((debug nil)) | |
| 139 | (loop | |
| 140 | (case-equal (car args) | |
| 141 | (("-a" "-all" "-e" "-exec") | |
| 142 | (setq command :compile-all) | |
| 143 | (setq args (cdr args))) | |
| 144 | (("-d" "-debug") | |
| 145 | (setq debug t) | |
| 146 | (setq args (cdr args))) | |
| 147 | (t (return nil)))) | |
| 148 | (%make-tram :command command :modexp args :debug debug)) | |
| 149 | (multiple-value-bind (modexp preterm) | |
| 150 | (parse-in-context-modexp-with-term inp) | |
| 151 | (%make-tram :command command :modexp modexp :term preterm))))) | |
| 152 | ||
| 153 | 153 | ;;; ******** |
| 154 | 154 | ;;; AUTOLOAD |
| 155 | 155 | ;;; ******** |
| 156 | 156 | (defun parse-autoload-command (inp &rest ignore) |
| 157 | 157 | (declare (ignore ignore)) |
| 158 | 158 | (let ((mod-name (second inp)) |
| 159 | (file (third inp))) | |
| 159 | (file (third inp))) | |
| 160 | 160 | (%autoload* mod-name file))) |
| 161 | ||
| 161 | ||
| 162 | ;;; | |
| 163 | ;;; NO AUTOLOAD | |
| 164 | ;;; | |
| 165 | (defun parse-no-autoload-command (inp &rest ignore) | |
| 166 | (declare (ignore ignore)) | |
| 167 | (let ((mod-name (second inp))) | |
| 168 | (%no-autoload* mod-name))) | |
| 169 | ||
| 162 | 170 | ;;; ****** |
| 163 | 171 | ;;; CBREAD |
| 164 | 172 | ;;; ****** |
| 169 | 177 | (multiple-value-bind (modexp preterm) |
| 170 | 178 | (parse-in-context-modexp-with-term toks) |
| 171 | 179 | (let ((lhs nil) |
| 172 | (rhs nil)) | |
| 180 | (rhs nil)) | |
| 173 | 181 | ;; |
| 174 | 182 | (loop (when (or (null preterm) |
| 175 | (member (car preterm) | |
| 176 | '("=" "=b=" "==") :test #'equal)) | |
| 177 | (return)) | |
| 178 | (push (car preterm) lhs) | |
| 179 | (setq preterm (cdr preterm))) | |
| 183 | (member (car preterm) | |
| 184 | '("=" "=b=" "==") :test #'equal)) | |
| 185 | (return)) | |
| 186 | (push (car preterm) lhs) | |
| 187 | (setq preterm (cdr preterm))) | |
| 180 | 188 | (setq lhs (nreverse lhs)) |
| 181 | 189 | (setq rhs (cdr preterm)) |
| 182 | 190 | (unless (and lhs rhs) |
| 183 | (with-output-chaos-error ('invalid-command-form) | |
| 184 | (princ "cbred: syntax error: ") | |
| 185 | (princ toks))) | |
| 191 | (with-output-chaos-error ('invalid-command-form) | |
| 192 | (princ "cbred: syntax error: ") | |
| 193 | (princ toks))) | |
| 186 | 194 | (%cbred* modexp lhs rhs)))) |
| 187 | 195 | |
| 188 | 196 | ;;; ******* |
| 190 | 198 | ;;; ******* |
| 191 | 199 | (defun parse-in-context-modexp-with-name (e) |
| 192 | 200 | (let (modexp |
| 193 | name) | |
| 201 | name) | |
| 194 | 202 | (setq e (cddr e)) |
| 195 | 203 | (if (cdr e) |
| 196 | (progn | |
| 197 | (setq modexp (parse-modexp (second (first e)))) | |
| 198 | (setq name (second e))) | |
| 199 | (progn | |
| 200 | (setq modexp nil) | |
| 201 | (setq name (first e)))) | |
| 204 | (progn | |
| 205 | (setq modexp (parse-modexp (second (first e)))) | |
| 206 | (setq name (second e))) | |
| 207 | (progn | |
| 208 | (setq modexp nil) | |
| 209 | (setq name (first e)))) | |
| 202 | 210 | (values modexp name))) |
| 203 | 211 | |
| 204 | 212 | (defun parse-look-up-command (e &rest ignore) |
| 216 | 224 | (defun parse-case-command (expr &rest ignore) |
| 217 | 225 | (declare (ignore ignore)) |
| 218 | 226 | (let ((case-term (nth 2 expr)) |
| 219 | (modexpr (parse-modexp (nth 6 expr))) | |
| 220 | (name (nth 9 expr)) | |
| 221 | (body (nth 11 expr)) | |
| 222 | (goal (nth 14 expr))) | |
| 227 | (modexpr (parse-modexp (nth 6 expr))) | |
| 228 | (name (nth 9 expr)) | |
| 229 | (body (nth 11 expr)) | |
| 230 | (goal (nth 14 expr))) | |
| 223 | 231 | (when (atom body) |
| 224 | 232 | (setq body nil) |
| 225 | 233 | (setq goal (nth 13 expr))) |
| 245 | 253 | (let ((name (nth 1 inp)) |
| 246 | 254 | (modexp (nth 3 inp))) |
| 247 | 255 | (%module-decl* name |
| 248 | :module | |
| 249 | :user | |
| 250 | (list (%import* :protecting (parse-modexp modexp)))))) | |
| 256 | :module | |
| 257 | :user | |
| 258 | (list (%import* :protecting (parse-modexp modexp)))))) | |
| 251 | 259 | |
| 252 | 260 | ;;; ***** |
| 253 | 261 | ;;; INPUT |
| 390 | 398 | (format t "too many args ~s" (cdr inp)))) |
| 391 | 399 | (let ((num (and (cadr inp) (parse-integer (cadr inp) :junk-allowed t)))) |
| 392 | 400 | (if num |
| 393 | (setf (%popd-num _popd-pat) (cadr inp)) | |
| 401 | (setf (%popd-num _popd-pat) (cadr inp)) | |
| 394 | 402 | (setf (%popd-num _popd-pat) nil)) |
| 395 | 403 | (eval-ast _popd-pat) |
| 396 | 404 | (setf (%popd-num _popd-pat) nil) |
| 491 | 499 | (let ((dat (cadr inp))) |
| 492 | 500 | (let ((it (car dat))) |
| 493 | 501 | (case-equal it |
| 494 | (("reg" "regular" "regularity") | |
| 495 | (%check* :regularity (cdr dat))) | |
| 496 | (("lazy" "laziness" "strict" "strictness") | |
| 497 | (%check* :strictness (cdr dat))) | |
| 498 | (("compat" "compatibility") | |
| 499 | (%check* :compatibility (cdr dat))) | |
| 500 | (("coherency" "coherent" "coh" "coherence") | |
| 501 | (%check* :coherency (cdr dat))) | |
| 502 | (("sensible" "sensibleness") | |
| 503 | (%check* :sensible (cdr dat))) | |
| 504 | (("rewriting" "rew") | |
| 505 | (%check* :rew-coherence (cdr dat))) | |
| 506 | (("invariance" "inv") | |
| 507 | (%check* :invariance (cdr dat))) | |
| 508 | (("safety") | |
| 509 | (%check* :safety (cdr dat))) | |
| 510 | (("refinement" "refine") | |
| 511 | (%check* :refinement (cdr dat))) | |
| 512 | (("?" "help" ":?" ":help") | |
| 513 | (cafeobj-check-help) | |
| 514 | (return-from parse-check-command t)))))) | |
| 502 | (("reg" "regular" "regularity") | |
| 503 | (%check* :regularity (cdr dat))) | |
| 504 | (("lazy" "laziness" "strict" "strictness") | |
| 505 | (%check* :strictness (cdr dat))) | |
| 506 | (("compat" "compatibility") | |
| 507 | (%check* :compatibility (cdr dat))) | |
| 508 | (("coherency" "coherent" "coh" "coherence") | |
| 509 | (%check* :coherency (cdr dat))) | |
| 510 | (("sensible" "sensibleness") | |
| 511 | (%check* :sensible (cdr dat))) | |
| 512 | (("rewriting" "rew") | |
| 513 | (%check* :rew-coherence (cdr dat))) | |
| 514 | (("invariance" "inv") | |
| 515 | (%check* :invariance (cdr dat))) | |
| 516 | (("safety") | |
| 517 | (%check* :safety (cdr dat))) | |
| 518 | (("refinement" "refine") | |
| 519 | (%check* :refinement (cdr dat))) | |
| 520 | (("?" "help" ":?" ":help") | |
| 521 | (cafeobj-check-help) | |
| 522 | (return-from parse-check-command t)))))) | |
| 515 | 523 | |
| 516 | 524 | ;;; |
| 517 | 525 | ;;; CHECK HELP |
| 519 | 527 | |
| 520 | 528 | (defun cafeobj-check-help (&rest ignore) |
| 521 | 529 | (declare (ignore ignore)) |
| 522 | (format t "~& check {reg | regularity} [<Modexp>]") | |
| 530 | (format t "~% check {reg | regularity} [<Modexp>]") | |
| 523 | 531 | (format t "~&~8Tcheck <Modexp> (or current module's) signagture is regular or not.") |
| 524 | 532 | (format t "~& check {compat | compatibility} [<Modexp>]") |
| 525 | 533 | (format t "~&~8Tcheck <Modexp> (or current module) is compatible or not.") |
| 567 | 575 | ;;; **** |
| 568 | 576 | (defun parse-name-command (inp) |
| 569 | 577 | (let ((modexp (second inp)) |
| 570 | (ast (%inspect* nil))) | |
| 578 | (ast (%inspect* nil))) | |
| 571 | 579 | (when modexp |
| 572 | 580 | (setf (%inspect-modexp ast) (parse-modexp modexp))) |
| 573 | 581 | ast)) |
| 582 | 590 | ;;; ****************** |
| 583 | 591 | ;;; MODULE Constructs. |
| 584 | 592 | ;;; ****************** |
| 593 | ||
| 594 | ;;; it is an error unless a module is open. | |
| 585 | 595 | (defun cafeobj-eval-module-element-proc (inp) |
| 586 | 596 | (if *open-module* |
| 587 | (with-in-module (*last-module*) | |
| 588 | (multiple-value-bind (type ast) | |
| 589 | (parse-module-element inp) | |
| 590 | (declare (ignore type)) | |
| 597 | (with-in-module ((get-context-module)) | |
| 598 | (multiple-value-bind (type ast) | |
| 599 | (parse-module-element inp) | |
| 600 | (declare (ignore type)) | |
| 591 | 601 | (dolist (a ast) |
| 592 | 602 | (eval-ast a)))) |
| 593 | 603 | (with-output-chaos-warning () |
| 0 | 0 | ;;;-*- Mode:LISP; Package:CHAOS; Base:10; Syntax:Common-lisp -*- |
| 1 | 1 | ;;; |
| 2 | ;;; Copyright (c) 2000-2014, Toshimi Sawada. All rights reserved. | |
| 2 | ;;; Copyright (c) 2000-2015, Toshimi Sawada. All rights reserved. | |
| 3 | 3 | ;;; |
| 4 | 4 | ;;; Redistribution and use in source and binary forms, with or without |
| 5 | 5 | ;;; modification, are permitted provided that the following conditions |
| 101 | 101 | (setf ,__exp (cdr ,__exp))) |
| 102 | 102 | (flatten-list (nreverse *__modexp))))) |
| 103 | 103 | (let ((mode (case-equal (car imp-expr) |
| 104 | (("pr" "protecting") :protecting) | |
| 105 | (("ex" "extending") :extending) | |
| 106 | (("us" "using") :using) | |
| 107 | (("inc" "including") :including))) | |
| 108 | (alias nil) | |
| 109 | (expr nil) | |
| 110 | (res nil)) | |
| 104 | (("pr" "protecting") :protecting) | |
| 105 | (("ex" "extending") :extending) | |
| 106 | (("us" "using") :using) | |
| 107 | (("inc" "including") :including))) | |
| 108 | (alias nil) | |
| 109 | (expr nil) | |
| 110 | (res nil)) | |
| 111 | 111 | ;; |
| 112 | 112 | (cond ((equal (second imp-expr) "(") |
| 113 | (setq expr (scan-parenthesized-unit (cdr imp-expr)))) | |
| 114 | ((and (consp (second imp-expr)) | |
| 115 | (equal "as" (car (second imp-expr)))) | |
| 116 | (setq alias (second (second imp-expr))) | |
| 117 | (setq expr (if (equal (third imp-expr) "(") | |
| 118 | (scan-parenthesized-unit (cddr imp-expr)) | |
| 119 | (cddr imp-expr)))) | |
| 120 | (t (setq expr (cdr imp-expr)))) | |
| 113 | (setq expr (scan-parenthesized-unit (cdr imp-expr)))) | |
| 114 | ((and (consp (second imp-expr)) | |
| 115 | (equal "as" (car (second imp-expr)))) | |
| 116 | (setq alias (second (second imp-expr))) | |
| 117 | (setq expr (if (equal (third imp-expr) "(") | |
| 118 | (scan-parenthesized-unit (cddr imp-expr)) | |
| 119 | (cddr imp-expr)))) | |
| 120 | (t (setq expr (cdr imp-expr)))) | |
| 121 | 121 | ;; |
| 122 | 122 | (loop (unless expr (return)) |
| 123 | 123 | (if (equal (second expr) "::") |
| 133 | 133 | (push (%make-import :mode mode |
| 134 | 134 | :parameter param |
| 135 | 135 | :module (parse-modexp (scan-modexp expr)) |
| 136 | :alias alias) | |
| 136 | :alias alias) | |
| 137 | 137 | res)) |
| 138 | 138 | ;; non parameterized importation |
| 139 | 139 | (push (%make-import :mode mode |
| 140 | 140 | :module (parse-modexp (scan-modexp expr)) |
| 141 | :alias alias) | |
| 141 | :alias alias) | |
| 142 | 142 | res)) |
| 143 | 143 | (setf expr (cdr expr))) |
| 144 | 144 | ;; |
| 150 | 150 | (defun parse-imports-form (e &rest ignore) |
| 151 | 151 | (declare (ignore ignore)) |
| 152 | 152 | (let ((body nil) |
| 153 | (im-body (caddr e))) | |
| 153 | (im-body (caddr e))) | |
| 154 | 154 | (unless (equal im-body "}") |
| 155 | 155 | (dolist (elt im-body) |
| 156 | (unless (equal im-body "}") | |
| 157 | (case-equal (car elt) | |
| 158 | (("--" "**") nil) | |
| 159 | ("-->" (setq body (nconc body | |
| 160 | (list (%dyna-comment* | |
| 161 | (cons "--" (cdr elt))))))) | |
| 162 | ("**>" (setq body | |
| 163 | (nconc body (list | |
| 164 | (%dyna-comment* (cons "**" (cdr elt))))))) | |
| 165 | (t (setf body (nconc body (process-importation-form elt)))))))) | |
| 156 | (unless (equal im-body "}") | |
| 157 | (case-equal (car elt) | |
| 158 | (("--" "**") nil) | |
| 159 | ("-->" (setq body (nconc body | |
| 160 | (list (%dyna-comment* | |
| 161 | (cons "--" (cdr elt))))))) | |
| 162 | ("**>" (setq body | |
| 163 | (nconc body (list | |
| 164 | (%dyna-comment* (cons "**" (cdr elt))))))) | |
| 165 | (t (setf body (nconc body (process-importation-form elt)))))))) | |
| 166 | 166 | body)) |
| 167 | 167 | |
| 168 | 168 | ;;; ***************************** |
| 421 | 421 | (with-output-chaos-warning () |
| 422 | 422 | (format t "# of arguments mismatch for mixfix operator `~{~a~}', ignored." |
| 423 | 423 | pat) |
| 424 | (format t "~% arity = ~a, coarity=~a" arity coarity) | |
| 424 | (format t "~% arity = ~a, coarity=~a" arity coarity) | |
| 425 | 425 | (return-from process-operator-declaration-form nil))))) |
| 426 | 426 | (if (equal type "op") |
| 427 | 427 | (%make-op-decl :name pat |
| 460 | 460 | (coarity "Bool") |
| 461 | 461 | (attr (process-opattr-form (cadr (nth 4 e))))) |
| 462 | 462 | (cond ((member type '("pred" "pd") :test #'equal) |
| 463 | (%make-op-decl :name pat | |
| 464 | :arity arity | |
| 465 | :coarity coarity | |
| 466 | :attribute attr | |
| 467 | :hidden nil)) | |
| 468 | ((member type '("bpred" "bpd") :test #'equal) | |
| 469 | (%make-op-decl :name pat | |
| 470 | :arity arity | |
| 471 | :coarity coarity | |
| 472 | :attribute attr | |
| 473 | :hidden :hidden)) | |
| 474 | (t | |
| 475 | (with-output-panic-message () | |
| 476 | (format t "unknown predicate type ~a" type))))))) | |
| 463 | (%make-op-decl :name pat | |
| 464 | :arity arity | |
| 465 | :coarity coarity | |
| 466 | :attribute attr | |
| 467 | :hidden nil)) | |
| 468 | ((member type '("bpred" "bpd") :test #'equal) | |
| 469 | (%make-op-decl :name pat | |
| 470 | :arity arity | |
| 471 | :coarity coarity | |
| 472 | :attribute attr | |
| 473 | :hidden :hidden)) | |
| 474 | (t | |
| 475 | (with-output-panic-message () | |
| 476 | (format t "unknown predicate type ~a" type))))))) | |
| 477 | 477 | |
| 478 | 478 | ;;; PREDS |
| 479 | 479 | (defun process-predicates-declaration-form (decl &rest ignore) |
| 480 | 480 | (declare (ignore ignore)) |
| 481 | 481 | (mapcar #'(lambda (pat) |
| 482 | (process-predicate-declaration-form | |
| 483 | (list* "pred" (if (consp pat) pat (list pat)) (cddr decl)))) | |
| 484 | (group-paren-units (cadr decl)))) | |
| 482 | (process-predicate-declaration-form | |
| 483 | (list* "pred" (if (consp pat) pat (list pat)) (cddr decl)))) | |
| 484 | (group-paren-units (cadr decl)))) | |
| 485 | 485 | |
| 486 | 486 | ;;; BPREDS |
| 487 | 487 | (defun process-bpredicates-declaration-form (decl &rest ignore) |
| 488 | 488 | (declare (ignore ignore)) |
| 489 | 489 | (mapcar #'(lambda (pat) |
| 490 | (process-predicate-declaration-form | |
| 491 | (list* "bpred" (if (consp pat) pat (list pat)) (cddr decl)))) | |
| 492 | (group-paren-units (cadr decl)))) | |
| 490 | (process-predicate-declaration-form | |
| 491 | (list* "bpred" (if (consp pat) pat (list pat)) (cddr decl)))) | |
| 492 | (group-paren-units (cadr decl)))) | |
| 493 | 493 | |
| 494 | 494 | ;;; OPS |
| 495 | 495 | (defun process-operators-declaration-form (decl &rest ignore) |
| 595 | 595 | (defun process-signature (e &rest ignore) |
| 596 | 596 | (declare (ignore ignore)) |
| 597 | 597 | (let ((body nil) |
| 598 | (s-body (caddr e))) | |
| 598 | (s-body (caddr e))) | |
| 599 | 599 | (unless (equal s-body "}") |
| 600 | 600 | (dolist (elt s-body) |
| 601 | (unless (equal elt "}") | |
| 602 | (multiple-value-bind (type sig) | |
| 603 | (parse-module-element elt) | |
| 604 | (declare (ignore type)) | |
| 605 | (setf body (nconc body sig)))))) | |
| 601 | (unless (equal elt "}") | |
| 602 | (multiple-value-bind (type sig) | |
| 603 | (parse-module-element elt) | |
| 604 | (declare (ignore type)) | |
| 605 | (setf body (nconc body sig)))))) | |
| 606 | 606 | body)) |
| 607 | 607 | |
| 608 | 608 | ;;; ************************* |
| 679 | 679 | (when (and (not (equal (first lhs) "(")) |
| 680 | 680 | (equal (first lhs) "[")) |
| 681 | 681 | (let ((b-pos nil) |
| 682 | (c-pos nil)) | |
| 683 | (setq b-pos (position "]" lhs :test #'equal)) | |
| 684 | (setq c-pos (position ":" lhs :test #'equal)) | |
| 685 | (when (and b-pos c-pos (= 1 (- c-pos b-pos))) | |
| 686 | (setf labels (mapcar #'(lambda (x) (intern (string x))) | |
| 687 | (cdr (firstn lhs b-pos)))) | |
| 688 | (setf lhs (nthcdr (1+ c-pos) lhs))))) | |
| 682 | (c-pos nil)) | |
| 683 | (setq b-pos (position "]" lhs :test #'equal)) | |
| 684 | (setq c-pos (position ":" lhs :test #'equal)) | |
| 685 | (when (and b-pos c-pos (= 1 (- c-pos b-pos))) | |
| 686 | (setf labels (mapcar #'(lambda (x) (intern (string x))) | |
| 687 | (cdr (firstn lhs b-pos)))) | |
| 688 | (setf lhs (nthcdr (1+ c-pos) lhs))))) | |
| 689 | 689 | (%axiom-decl* type labels lhs rhs cond behavioural))) |
| 690 | 690 | |
| 691 | 691 | ;;; |
| 695 | 695 | (defun process-axioms-declaration (e &rest ignore) |
| 696 | 696 | (declare (ignore ignore)) |
| 697 | 697 | (let ((body nil) |
| 698 | (a-body (caddr e))) | |
| 698 | (a-body (caddr e))) | |
| 699 | 699 | (unless (equal a-body "}") |
| 700 | 700 | (dolist (elt a-body) |
| 701 | (unless (equal elt "}" ) | |
| 702 | (multiple-value-bind (type ax) | |
| 703 | (parse-module-element elt) | |
| 704 | (declare (ignore type)) | |
| 705 | (setf body (nconc body ax)))))) | |
| 701 | (unless (equal elt "}" ) | |
| 702 | (multiple-value-bind (type ax) | |
| 703 | (parse-module-element elt) | |
| 704 | (declare (ignore type)) | |
| 705 | (setf body (nconc body ax)))))) | |
| 706 | 706 | body)) |
| 707 | 707 | |
| 708 | 708 | ;;; ******************** |
| 763 | 763 | :test #'equal) |
| 764 | 764 | (setq psort opt)) |
| 765 | 765 | (t (setq param opt))))) |
| 766 | (4 (setq param (nth 2 decl)) ; full featured declaration | |
| 766 | (4 (setq param (nth 2 decl)) ; full featured declaration | |
| 767 | 767 | (setq psort (nth 3 decl)))) |
| 768 | 768 | |
| 769 | 769 | (setq body (nth (1+ b-pos) decl)) |
| 801 | 801 | (defun parse-module-elements (s &rest ignore) |
| 802 | 802 | (declare (ignore ignore)) |
| 803 | 803 | (let ((body nil) |
| 804 | (sig nil) | |
| 805 | (ax nil)) | |
| 804 | (sig nil) | |
| 805 | (ax nil)) | |
| 806 | 806 | (dolist (e s) |
| 807 | 807 | (multiple-value-bind (kind elt) |
| 808 | (parse-module-element e) | |
| 809 | (case kind | |
| 810 | ((:ignore :misc) nil) | |
| 811 | (:signature (setq sig (nconc sig elt))) | |
| 812 | (:import (setq sig (nconc sig elt))) | |
| 813 | (:axiom (setq ax (nconc ax elt)))))) | |
| 808 | (parse-module-element e) | |
| 809 | (case kind | |
| 810 | ((:ignore :misc) nil) | |
| 811 | (:signature (setq sig (nconc sig elt))) | |
| 812 | (:import (setq sig (nconc sig elt))) | |
| 813 | (:axiom (setq ax (nconc ax elt)))))) | |
| 814 | 814 | (setf body (append sig ax)) |
| 815 | 815 | body)) |
| 816 | 816 | |
| 819 | 819 | (let ((decl (get-decl-info (car e)))) |
| 820 | 820 | (unless decl |
| 821 | 821 | (with-output-chaos-error ('no-decl) |
| 822 | (format t "No such declaration '~a'" (car e)))) | |
| 822 | (format t "No such declaration '~a'" (car e)))) | |
| 823 | 823 | (let ((parser (comde-parser decl))) |
| 824 | 824 | (unless parser |
| 825 | (with-output-chaos-error ('no-parser) | |
| 826 | (format t "No parser is defined for declaration ~a" (car e)))) | |
| 825 | (with-output-chaos-error ('no-parser) | |
| 826 | (format t "No parser is defined for declaration ~a" (car e)))) | |
| 827 | 827 | (let ((ast (funcall parser e))) |
| 828 | (declare (list ast)) | |
| 829 | (when (and ast (atom (car ast))) | |
| 830 | (setq ast (list ast))) | |
| 831 | (values (comde-category decl) ast))))) | |
| 828 | (declare (list ast)) | |
| 829 | (when (and ast (atom (car ast))) | |
| 830 | (setq ast (list ast))) | |
| 831 | (values (comde-category decl) ast))))) | |
| 832 | 832 | |
| 833 | 833 | (defun parse-module-element-1 (e &rest ignore) |
| 834 | 834 | (multiple-value-bind (type elt) |
| 0 | 0 | ;;;-*- Mode:LISP; Package:CHAOS; Base:10; Syntax:Common-lisp -*- |
| 1 | 1 | ;;; |
| 2 | ;;; Copyright (c) 2000-2014, Toshimi Sawada. All rights reserved. | |
| 2 | ;;; Copyright (c) 2000-2015, Toshimi Sawada. All rights reserved. | |
| 3 | 3 | ;;; |
| 4 | 4 | ;;; Redistribution and use in source and binary forms, with or without |
| 5 | 5 | ;;; modification, are permitted provided that the following conditions |
| 0 | 0 | ;;;-*-Mode:LISP; Package: CHAOS; Base:10; Syntax:Common-lisp -*- |
| 1 | 1 | ;;; |
| 2 | ;;; Copyright (c) 2000-2014, Toshimi Sawada. All rights reserved. | |
| 2 | ;;; Copyright (c) 2000-2015, Toshimi Sawada. All rights reserved. | |
| 3 | 3 | ;;; |
| 4 | 4 | ;;; Redistribution and use in source and binary forms, with or without |
| 5 | 5 | ;;; modification, are permitted provided that the following conditions |
| 60 | 60 | (setf (sort-is-hidden *huniversal-sort*) t) |
| 61 | 61 | (setf (sort-is-hidden *hbottom-sort*) t) |
| 62 | 62 | (setq sup-universal-sort-name |
| 63 | (intern | |
| 64 | (concatenate 'string (string (sort-id *universal-sort*)) | |
| 63 | (intern | |
| 64 | (concatenate 'string (string (sort-id *universal-sort*)) | |
| 65 | 65 | "." |
| 66 | 66 | (make-module-print-name2 (sort-module *universal-sort*))))) |
| 67 | 67 | (setq sup-huniversal-sort-name |
| 68 | (intern | |
| 69 | (concatenate 'string (string (sort-id *huniversal-sort*)) | |
| 68 | (intern | |
| 69 | (concatenate 'string (string (sort-id *huniversal-sort*)) | |
| 70 | 70 | "." |
| 71 | 71 | (make-module-print-name2 (sort-module *huniversal-sort*))))) |
| 72 | 72 | (compile-module *universal-module*)) |
| 79 | 79 | ;; Sorts for syntax errors |
| 80 | 80 | (let ((syntax-err (define-builtin-sort '|SyntaxErr| *parser-module*)) |
| 81 | 81 | (type-err (define-builtin-sort '|TypeErr| *parser-module*)) |
| 82 | (sort-id (define-builtin-sort '|SortId| *parser-module*))) | |
| 82 | (sort-id (define-builtin-sort '|SortId| *parser-module*))) | |
| 83 | 83 | (setf *syntax-err-sort* syntax-err) |
| 84 | 84 | (setf *type-err-sort* type-err) |
| 85 | 85 | (setf *sort-id-sort* sort-id) |
| 154 | 154 | |
| 155 | 155 | (defun print-ast-dict () |
| 156 | 156 | (maphash #'(lambda (x y) |
| 157 | (format t "~&key=~a, entries -------------------" x) | |
| 157 | (format t "~%key=~a, entries -------------------" x) | |
| 158 | 158 | (dolist (elt y) |
| 159 | 159 | (let ((ee (cdr elt))) |
| 160 | 160 | (terpri) |
| 186 | 186 | (defun install-chaos-hard-wired-modules () |
| 187 | 187 | (setq *dribble-ast* nil) |
| 188 | 188 | (setq *ast-log* nil) |
| 189 | (setq *last-module* nil *current-module* nil) | |
| 189 | (reset-context-module) | |
| 190 | 190 | (setq *include-bool* nil) |
| 191 | 191 | (setq *include-rwl* nil) |
| 192 | 192 | (setq *regularize-signature* nil) |
| 198 | 198 | (eval-ast-if-need '(%module-decl "TRUTH-VALUE" :object :hard |
| 199 | 199 | ((%psort-decl (%sort-ref "Bool" nil)) |
| 200 | 200 | (%sort-decl (%sort-ref "Bool" nil) nil) |
| 201 | (%sort-decl (%sort-ref "*Condition*" nil) nil) | |
| 202 | (%subsort-decl (nil (%sort-ref "Bool" nil) :< (%sort-ref "*Condition*" nil))) | |
| 201 | (%sort-decl (%sort-ref "*Condition*" nil) nil) | |
| 202 | (%subsort-decl (nil (%sort-ref "Bool" nil) :< (%sort-ref "*Condition*" nil))) | |
| 203 | 203 | (%op-decl ("false") nil (%sort-ref "Bool" nil) |
| 204 | 204 | (%opattrs nil nil nil nil nil t nil nil) |
| 205 | 205 | nil) |
| 280 | 280 | (%bsort-decl "String" nil nil prin1 stringp nil)))) |
| 281 | 281 | (install-string) |
| 282 | 282 | ;; |
| 283 | ;; | |
| 284 | (setq *last-module* nil *current-module* nil) | |
| 283 | (reset-context-module) | |
| 285 | 284 | (setq *include-bool* t) |
| 286 | 285 | (setq *include-rwl* t) |
| 287 | 286 | ) |
| 302 | 301 | (setq *ast-log* nil) |
| 303 | 302 | (setq *include-bool* t) |
| 304 | 303 | (setq *include-rwl* t) |
| 305 | (setq *last-module* nil | |
| 306 | *current-module* nil) | |
| 304 | (reset-context-module) | |
| 307 | 305 | (setq *regularize-signature* nil) |
| 308 | 306 | ;; set recover proc. |
| 309 | 307 | (setq *system-soft-wired* |
| 310 | '((%lisp-eval (install-chaos-soft-wired-modules)))) | |
| 308 | '((%lisp-eval (install-chaos-soft-wired-modules)))) | |
| 311 | 309 | )) |
| 312 | 310 | |
| 313 | 311 | (defun chaos-misc-init () |
| 382 | 380 | (setq *z-string-value* (get-z-module-or-panic "STRING-VALUE")) |
| 383 | 381 | ; (setq *z-string* (get-z-module-or-panic "STRING")) |
| 384 | 382 | (setq *tram-builtin-modules* |
| 385 | (list *z-nznat-value* | |
| 386 | *z-nat-value* | |
| 387 | *z-int-value* | |
| 383 | (list *z-nznat-value* | |
| 384 | *z-nat-value* | |
| 385 | *z-int-value* | |
| 388 | 386 | ; *z-nznat* *z-nat* *z-int* |
| 389 | *z-rat-value* | |
| 387 | *z-rat-value* | |
| 390 | 388 | ; *z-rat* |
| 391 | *z-float-value* | |
| 389 | *z-float-value* | |
| 392 | 390 | ; *z-float* |
| 393 | ;; *z-qid* | |
| 394 | *z-char-value* | |
| 391 | ;; *z-qid* | |
| 392 | *z-char-value* | |
| 395 | 393 | ; *z-char* |
| 396 | *z-string-value* | |
| 394 | *z-string-value* | |
| 397 | 395 | ; *z-string* |
| 398 | )) | |
| 396 | )) | |
| 399 | 397 | (setup-tram-bool-modules)) |
| 400 | 398 | |
| 401 | 399 | ;;; |
| 0 | 0 | ;;;-*-Mode:LISP; Package: Chaos; Base:10; Syntax:Common-lisp -*- |
| 1 | 1 | ;;; |
| 2 | ;;; Copyright (c) 2000-2014, Toshimi Sawada. All rights reserved. | |
| 2 | ;;; Copyright (c) 2000-2015, Toshimi Sawada. All rights reserved. | |
| 3 | 3 | ;;; |
| 4 | 4 | ;;; Redistribution and use in source and binary forms, with or without |
| 5 | 5 | ;;; modification, are permitted provided that the following conditions |
| 27 | 27 | ;;; |
| 28 | 28 | (in-package :chaos) |
| 29 | 29 | #|============================================================================== |
| 30 | System: Chaos | |
| 31 | Module: primitives.chaos | |
| 32 | File: meta.lisp | |
| 30 | System: Chaos | |
| 31 | Module: primitives.chaos | |
| 32 | File: meta.lisp | |
| 33 | 33 | ===============================================================================|# |
| 34 | 34 | ;;; |
| 35 | 35 | ;;; |
| 57 | 57 | (defun mnth (chaos-list num) |
| 58 | 58 | (and (chaos-list-p chaos-list) |
| 59 | 59 | (or (nth num (chaos-list-list chaos-list)) |
| 60 | *chaos-null*))) | |
| 60 | *chaos-null*))) | |
| 61 | 61 | |
| 62 | 62 | (defun mnthcdr (chaos-list num) |
| 63 | 63 | (and (chaos-list-p chaos-list) |
| 64 | 64 | (or (nthcdr num (chaos-list-list chaos-list)) |
| 65 | *chaos-null*))) | |
| 65 | *chaos-null*))) | |
| 66 | 66 | |
| 67 | 67 | (defun mlength (chaos-list) |
| 68 | 68 | (and (chaos-list-p chaos-list) |
| 72 | 72 | (declare (ignore ignore)) |
| 73 | 73 | (let ((lst (chaos-list-list obj))) |
| 74 | 74 | (if lst |
| 75 | (format stream ":[~s]" lst) | |
| 75 | (format stream ":[~s]" lst) | |
| 76 | 76 | (format stream ":[]")))) |
| 77 | 77 | |
| 78 | 78 | ;;; |
| 95 | 95 | (if (and (termp obj) (term-is-system-object? obj)) |
| 96 | 96 | obj |
| 97 | 97 | (with-in-module (module) |
| 98 | (let ((sort (cond ((null obj) *chaos-void-sort*) | |
| 99 | ((symbolp obj) *chaos-void-sort*) | |
| 100 | ((sort-p obj) *sort-sort*) | |
| 101 | ((method-p obj) *operator-sort*) | |
| 102 | ((module-p obj) *module-sort*) | |
| 103 | ((axiom-p obj) *axiom-sort*) | |
| 104 | ((termp obj) *term-sort*) | |
| 105 | ((chaos-list-p obj) *chaos-list-sort*) | |
| 106 | ((subst*-p obj) *subst-sort*) | |
| 107 | ((signature-struct-p obj) *signature-sort*) | |
| 108 | ((axiom-set-p obj) *axiomset-sort*) | |
| 109 | ((trs-p obj) *trs-sort*) | |
| 110 | ((is-ast obj) *chaos-expr-sort*) | |
| 111 | (t *chaos-void-sort*)))) | |
| 112 | (if (sort= sort *term-sort*) | |
| 113 | (make-meta-term obj) | |
| 114 | (if (sort= sort *chaos-void-sort*) | |
| 115 | (make-system-object-term 'void *chaos-void-sort*) | |
| 116 | (make-system-object-term obj sort))))))) | |
| 98 | (let ((sort (cond ((null obj) *chaos-void-sort*) | |
| 99 | ((symbolp obj) *chaos-void-sort*) | |
| 100 | ((sort-p obj) *sort-sort*) | |
| 101 | ((method-p obj) *operator-sort*) | |
| 102 | ((module-p obj) *module-sort*) | |
| 103 | ((axiom-p obj) *axiom-sort*) | |
| 104 | ((termp obj) *term-sort*) | |
| 105 | ((chaos-list-p obj) *chaos-list-sort*) | |
| 106 | ((subst*-p obj) *subst-sort*) | |
| 107 | ((signature-struct-p obj) *signature-sort*) | |
| 108 | ((axiom-set-p obj) *axiomset-sort*) | |
| 109 | ((trs-p obj) *trs-sort*) | |
| 110 | ((is-ast obj) *chaos-expr-sort*) | |
| 111 | (t *chaos-void-sort*)))) | |
| 112 | (if (sort= sort *term-sort*) | |
| 113 | (make-meta-term obj) | |
| 114 | (if (sort= sort *chaos-void-sort*) | |
| 115 | (make-system-object-term 'void *chaos-void-sort*) | |
| 116 | (make-system-object-term obj sort))))))) | |
| 117 | 117 | |
| 118 | 118 | ;;; msubterms |
| 119 | 119 | (defun msubterms (term) |
| 130 | 130 | #|| |
| 131 | 131 | (defun create-list-of-objects (fun system-obj-term) |
| 132 | 132 | (create-system-object-term (mapcar #'(lambda (x) (create-system-object-term x)) |
| 133 | (funcall fun (term-system-object system-obj-term))))) | |
| 133 | (funcall fun (term-system-object system-obj-term))))) | |
| 134 | 134 | ||# |
| 135 | 135 | |
| 136 | 136 | #|| |
| 137 | 137 | (defun create-list-of-objects (fun system-obj-term) |
| 138 | 138 | (let ((vals (funcall fun (term-system-object system-obj-term)))) |
| 139 | 139 | (if vals |
| 140 | (create-system-object-term (make-chaos-list :list (mapcar #'(lambda (x) (create-system-object-term x)) vals))) | |
| 140 | (create-system-object-term (make-chaos-list :list (mapcar #'(lambda (x) (create-system-object-term x)) vals))) | |
| 141 | 141 | (create-system-object-term *chaos-null*)))) |
| 142 | 142 | ||# |
| 143 | 143 | |
| 144 | 144 | (defun create-list-of-objects (fun system-obj-term) |
| 145 | 145 | (let ((vals (funcall fun (term-system-object system-obj-term)))) |
| 146 | 146 | (if vals |
| 147 | (make-chaos-list :list (mapcar #'(lambda (x) (create-system-object-term x)) vals)) | |
| 147 | (make-chaos-list :list (mapcar #'(lambda (x) (create-system-object-term x)) vals)) | |
| 148 | 148 | *chaos-null*))) |
| 149 | 149 | |
| 150 | 150 | (defun do-apply!! (fun args) |
| 151 | 151 | (let ((rfun (symbol-function (intern (term-builtin-value fun)))) |
| 152 | 152 | (rargs (if (and (sort= *cosmos* (term-sort args)) |
| 153 | (term-is-application-form? args) | |
| 154 | (equal (method-symbol (term-head args)) '("_" "," "_"))) | |
| 155 | (list-assoc-subterms args (term-head args)) | |
| 156 | (list args)))) | |
| 153 | (term-is-application-form? args) | |
| 154 | (equal (method-symbol (term-head args)) '("_" "," "_"))) | |
| 155 | (list-assoc-subterms args (term-head args)) | |
| 156 | (list args)))) | |
| 157 | 157 | (if rfun |
| 158 | 158 | (apply rfun rargs) |
| 159 | 159 | (create-system-object-term nil)))) |
| 185 | 185 | (defun in-same-cc (s1 s2) |
| 186 | 186 | (if (not *current-module*) |
| 187 | 187 | (with-output-chaos-error ('no-current-module) |
| 188 | (format t "Context module is not set")) | |
| 188 | (format t "Context module is not set")) | |
| 189 | 189 | (with-in-module (*current-module*) |
| 190 | 190 | (is-in-same-connected-component s1 s2 *current-sort-order*)))) |
| 191 | 191 | |
| 205 | 205 | |
| 206 | 206 | (defun meta-get-context-module (module) |
| 207 | 207 | (let ((rmod (if (termp module) |
| 208 | (cond ((and (termp module) (term-is-system-object? module)) | |
| 209 | (term-system-object module)) | |
| 210 | ((and (term-is-builtin-constant? module) | |
| 211 | (sort= (term-sort module) *string-sort*)) | |
| 212 | (eval-modexp (term-builtin-value module))) | |
| 213 | (t :invalid)) | |
| 214 | (if (module-p module) | |
| 215 | module | |
| 216 | :invalid-modexp)))) | |
| 208 | (cond ((and (termp module) (term-is-system-object? module)) | |
| 209 | (term-system-object module)) | |
| 210 | ((and (term-is-builtin-constant? module) | |
| 211 | (sort= (term-sort module) *string-sort*)) | |
| 212 | (eval-modexp (term-builtin-value module))) | |
| 213 | (t :invalid)) | |
| 214 | (if (module-p module) | |
| 215 | module | |
| 216 | :invalid-modexp)))) | |
| 217 | 217 | (if (or (eq rmod :invalid) (eq rmod :invalid-modexp)) |
| 218 | (with-output-chaos-error ('invalid-module) | |
| 219 | (format t "Invalid module specification ~S" module)) | |
| 218 | (with-output-chaos-error ('invalid-module) | |
| 219 | (format t "Invalid module specification ~S" module)) | |
| 220 | 220 | rmod))) |
| 221 | 221 | |
| 222 | 222 | (defun meta-get-term (pterm &optional (module *current-module*)) |
| 226 | 226 | (with-in-module (module) |
| 227 | 227 | (let ((rterm pterm)) |
| 228 | 228 | (cond ((sort= (term-sort pterm) *term-sort*) |
| 229 | (setq rterm (term-arg-1 pterm))) | |
| 230 | ((and (term-is-builtin-constant? pterm) | |
| 231 | (sort= (term-sort pterm) *string-sort*)) | |
| 232 | (setq rterm (simple-parse *current-module* | |
| 233 | (term-builtin-value pterm) | |
| 234 | *cosmos*)) | |
| 235 | (when (term-is-an-error rterm) | |
| 236 | (with-output-chaos-error ('invalid-term) | |
| 237 | (format t "Could not parse: ~S" (term-builtin-value pterm))))) | |
| 238 | (t rterm)) | |
| 229 | (setq rterm (term-arg-1 pterm))) | |
| 230 | ((and (term-is-builtin-constant? pterm) | |
| 231 | (sort= (term-sort pterm) *string-sort*)) | |
| 232 | (setq rterm (simple-parse *current-module* | |
| 233 | (term-builtin-value pterm) | |
| 234 | *cosmos*)) | |
| 235 | (when (term-is-an-error rterm) | |
| 236 | (with-output-chaos-error ('invalid-term) | |
| 237 | (format t "Could not parse: ~S" (term-builtin-value pterm))))) | |
| 238 | (t rterm)) | |
| 239 | 239 | rterm))) |
| 240 | 240 | |
| 241 | 241 | (defun meta-get-integer (pterm &optional (module *current-module*)) |
| 242 | 242 | (let ((rterm (meta-get-term pterm module)) |
| 243 | (value nil)) | |
| 243 | (value nil)) | |
| 244 | 244 | (when (term-is-builtin-constant? rterm) |
| 245 | 245 | (setq value (term-builtin-value rterm))) |
| 246 | 246 | (unless (integerp value) |
| 247 | 247 | (with-output-chaos-error ('ivalid-integer) |
| 248 | (format t "Invlid number specification ~S" pterm))) | |
| 248 | (format t "Invlid number specification ~S" pterm))) | |
| 249 | 249 | value)) |
| 250 | 250 | |
| 251 | 251 | (defun meta-get-list-integers (pterm &optional (module *current-module*)) |
| 252 | 252 | (if (and (consp pterm) |
| 253 | (every #'integerp pterm)) | |
| 253 | (every #'integerp pterm)) | |
| 254 | 254 | pterm |
| 255 | 255 | (let ((rterm (meta-get-term pterm module))) |
| 256 | 256 | (unless (chaos-list-p rterm) |
| 257 | (with-output-chaos-error ('invalid-integers) | |
| 258 | (format t "Invalid integer list ~S" pterm))) | |
| 257 | (with-output-chaos-error ('invalid-integers) | |
| 258 | (format t "Invalid integer list ~S" pterm))) | |
| 259 | 259 | (meta-get-list-integers (chaos-list-list rterm))))) |
| 260 | 260 | |
| 261 | 261 | (defvar *meta-match-depth* 0) |
| 262 | 262 | (defvar *use-choose-match* nil) |
| 263 | 263 | |
| 264 | 264 | (defun do-meta-match (target pattern &optional (module *current-module*) |
| 265 | depth | |
| 266 | (type :match) | |
| 267 | (start-pos nil)) | |
| 265 | depth | |
| 266 | (type :match) | |
| 267 | (start-pos nil)) | |
| 268 | 268 | (let* ((rmod (meta-get-context-module module)) |
| 269 | (rtarget (meta-get-term target)) | |
| 270 | (rpattern (meta-get-term pattern)) | |
| 271 | (rdepth (if depth (meta-get-integer pattern) -1)) | |
| 272 | (rpos (if start-pos (meta-get-list-integers start-pos rmod) nil)) | |
| 273 | (*meta-match-depth* 0)) | |
| 269 | (rtarget (meta-get-term target)) | |
| 270 | (rpattern (meta-get-term pattern)) | |
| 271 | (rdepth (if depth (meta-get-integer pattern) -1)) | |
| 272 | (rpos (if start-pos (meta-get-list-integers start-pos rmod) nil)) | |
| 273 | (*meta-match-depth* 0)) | |
| 274 | 274 | (with-in-module (rmod) |
| 275 | 275 | (when rpos |
| 276 | (setq rtarget (get-subterm-pos rtarget rpos))) | |
| 276 | (setq rtarget (get-subterm-pos rtarget rpos))) | |
| 277 | 277 | (let ((real-target (if (eq type :match) |
| 278 | (supply-psuedo-variables rtarget) | |
| 279 | rtarget))) | |
| 280 | (let ((first-match-meth (if (eq type :match) | |
| 281 | (if *use-choose-match* | |
| 282 | nil | |
| 283 | '@matcher) | |
| 284 | 'first-unify)) | |
| 285 | (next-match-meth (if (eq type :match) | |
| 286 | (if *use-choose-match* | |
| 287 | nil | |
| 288 | 'next-match) | |
| 289 | 'next-unify)) | |
| 290 | ;; (result nil) | |
| 291 | ) | |
| 292 | (when (and *use-choose-match* | |
| 293 | (eq type :match)) | |
| 294 | (let ((meth (choose-match-method real-target *bool-true* nil))) | |
| 295 | (setf first-match-meth (car meth)) | |
| 296 | (setf next-match-meth (cdr meth)))) | |
| 297 | ;; | |
| 298 | (perform-meta-match* real-target rpattern rdepth first-match-meth next-match-meth)))))) | |
| 278 | (supply-psuedo-variables rtarget) | |
| 279 | rtarget))) | |
| 280 | (let ((first-match-meth (if (eq type :match) | |
| 281 | (if *use-choose-match* | |
| 282 | nil | |
| 283 | '@matcher) | |
| 284 | 'first-unify)) | |
| 285 | (next-match-meth (if (eq type :match) | |
| 286 | (if *use-choose-match* | |
| 287 | nil | |
| 288 | 'next-match) | |
| 289 | 'next-unify)) | |
| 290 | ;; (result nil) | |
| 291 | ) | |
| 292 | (when (and *use-choose-match* | |
| 293 | (eq type :match)) | |
| 294 | (let ((meth (choose-match-method real-target *bool-true* nil))) | |
| 295 | (setf first-match-meth (car meth)) | |
| 296 | (setf next-match-meth (cdr meth)))) | |
| 297 | ;; | |
| 298 | (perform-meta-match* real-target rpattern rdepth first-match-meth next-match-meth)))))) | |
| 299 | 299 | |
| 300 | 300 | #|| |
| 301 | 301 | (defun perform-meta-match* (target pattern depth fm nm) |
| 302 | 302 | (let |
| 303 | 303 | |
| 304 | ;; ---- first match | |
| 305 | (multiple-value-bind (global-state subst no-match e-equal) | |
| 306 | (funcall first-match-meth pattern real-target) | |
| 307 | (when no-match | |
| 308 | (if (eq type :match) | |
| 309 | (format t "~&-- no match") | |
| 310 | (format t "~&-- no unify")) | |
| 311 | (return-from do-meta-match *chaos-null*)) | |
| 312 | (if (eq type :match) | |
| 313 | (format t "~&-- match success.") | |
| 314 | (format t "~&-- unify success.")) | |
| 315 | (when e-equal | |
| 316 | (format t "~&-- given terms are equational equal.") | |
| 317 | (return-from do-meta-match *chaos-null*)) | |
| 318 | (push (make-subst* :bindings subst) result) | |
| 319 | (multiple-value-setq (global-state subst no-match) | |
| 320 | (funcall next-match-meth global-state)) | |
| 321 | (while (not no-match) | |
| 322 | (push (make-subst* :bindings subst) result) | |
| 323 | (multiple-value-setq (global-state subst no-match) | |
| 324 | (funcall next-match-meth global-state))) | |
| 325 | (make-chaos-list :list (nreverse result))))) | |
| 304 | ;; ---- first match | |
| 305 | (multiple-value-bind (global-state subst no-match e-equal) | |
| 306 | (funcall first-match-meth pattern real-target) | |
| 307 | (when no-match | |
| 308 | (if (eq type :match) | |
| 309 | (format t "~&-- no match") | |
| 310 | (format t "~&-- no unify")) | |
| 311 | (return-from do-meta-match *chaos-null*)) | |
| 312 | (if (eq type :match) | |
| 313 | (format t "~&-- match success.") | |
| 314 | (format t "~&-- unify success.")) | |
| 315 | (when e-equal | |
| 316 | (format t "~&-- given terms are equational equal.") | |
| 317 | (return-from do-meta-match *chaos-null*)) | |
| 318 | (push (make-subst* :bindings subst) result) | |
| 319 | (multiple-value-setq (global-state subst no-match) | |
| 320 | (funcall next-match-meth global-state)) | |
| 321 | (while (not no-match) | |
| 322 | (push (make-subst* :bindings subst) result) | |
| 323 | (multiple-value-setq (global-state subst no-match) | |
| 324 | (funcall next-match-meth global-state))) | |
| 325 | (make-chaos-list :list (nreverse result))))) | |
| 326 | 326 | |
| 327 | 327 | ||# |
| 328 | 328 | |
| 329 | 329 | (defun meta-subst-image (term sub) |
| 330 | 330 | (let ((subst (subst*-bindings sub)) |
| 331 | (image nil)) | |
| 331 | (image nil)) | |
| 332 | 332 | (setq image (substitution-image subst term)) |
| 333 | 333 | (make-meta-term image))) |
| 334 | 334 | |
| 338 | 338 | (defun meta-get-occur (oc) |
| 339 | 339 | (let ((oc-list (list-assoc-subterms oc (term-head oc)))) |
| 340 | 340 | (if oc-list |
| 341 | (mapcar #'(lambda (x) (term-builtin-value x)) oc-list) | |
| 341 | (mapcar #'(lambda (x) (term-builtin-value x)) oc-list) | |
| 342 | 342 | nil))) |
| 343 | 343 | |
| 344 | 344 | (defun meta-occur-at (t1 occur) |
| 345 | 345 | (let ((term (meta-term-term t1)) |
| 346 | (roccur (meta-get-occur occur)) | |
| 347 | (res nil)) | |
| 346 | (roccur (meta-get-occur occur)) | |
| 347 | (res nil)) | |
| 348 | 348 | (setq res (subterm-op term roccur)) |
| 349 | 349 | (if res |
| 350 | (make-meta-term res) | |
| 350 | (make-meta-term res) | |
| 351 | 351 | (make-meta-term nil)))) |
| 352 | 352 | |
| 353 | 353 | ;;; TODO |
| 0 | 0 | ;;;-*- Mode:LISP; Package:CHAOS; Base:10; Syntax:Common-lisp -*- |
| 1 | 1 | ;;; |
| 2 | ;;; Copyright (c) 2000-2014, Toshimi Sawada. All rights reserved. | |
| 2 | ;;; Copyright (c) 2000-2015, Toshimi Sawada. All rights reserved. | |
| 3 | 3 | ;;; |
| 4 | 4 | ;;; Redistribution and use in source and binary forms, with or without |
| 5 | 5 | ;;; modification, are permitted provided that the following conditions |
| 27 | 27 | ;;; |
| 28 | 28 | (in-package :chaos) |
| 29 | 29 | #|============================================================================== |
| 30 | System: Chaos | |
| 31 | Module: chaos | |
| 32 | File: prelude.lisp | |
| 30 | System: Chaos | |
| 31 | Module: chaos | |
| 32 | File: prelude.lisp | |
| 33 | 33 | ==============================================================================|# |
| 34 | 34 | |
| 35 | 35 | ;;;----------------------------------------------------------------------------- |
| 39 | 39 | (defvar *LAST-TERM-eqn-rhs* nil) |
| 40 | 40 | (defun install-last-term () |
| 41 | 41 | (let* ((LAST-TERM (eval-modexp "LAST-TERM")) |
| 42 | (opinfo nil)) | |
| 42 | (opinfo nil)) | |
| 43 | 43 | (with-in-module (last-term) |
| 44 | 44 | (setq opinfo (find-operator '("last-term") 0 LAST-TERM)) |
| 45 | 45 | (setq *LAST-TERM-op-term* (opinfo-operator opinfo)) |
| 46 | 46 | (when *LAST-TERM-op-term* |
| 47 | (let ((meth (opinfo-methods opinfo))) | |
| 48 | (when meth | |
| 49 | (let ((rules (method-rules-with-different-top (car meth)))) | |
| 50 | (when rules | |
| 51 | (setf *LAST-TERM-eqn-rhs* (rule-rhs (car rules))))) | |
| 52 | )))))) | |
| 47 | (let ((meth (opinfo-methods opinfo))) | |
| 48 | (when meth | |
| 49 | (let ((rules (method-rules-with-different-top (car meth)))) | |
| 50 | (when rules | |
| 51 | (setf *LAST-TERM-eqn-rhs* (rule-rhs (car rules))))) | |
| 52 | )))))) | |
| 53 | 53 | |
| 54 | 54 | (defun set-last-term (term) |
| 55 | 55 | (when *LAST-TERM-eqn-rhs* |
| 66 | 66 | (defun is_Err (val) (declare (ignore val)) t) |
| 67 | 67 | (defun install-err () |
| 68 | 68 | (setq *sort-error* |
| 69 | (find-sort-in (eval-modexp "ERR") '|Err|))) | |
| 69 | (find-sort-in (eval-modexp "ERR") '|Err|))) | |
| 70 | 70 | |
| 71 | ||
| 71 | ||
| 72 | 72 | ;;;----------------------------------------------------------------------------- |
| 73 | 73 | ;;; module BUILT-IN |
| 74 | 74 | ;;;----------------------------------------------------------------------------- |
| 96 | 96 | |
| 97 | 97 | (defun install_BUILTIN () |
| 98 | 98 | (setq *sort_Builtin* |
| 99 | (find-sort-in (eval-modexp "BUILT-IN") "Built-in"))) | |
| 99 | (find-sort-in (eval-modexp "BUILT-IN") "Built-in"))) | |
| 100 | 100 | |
| 101 | 101 | ;;;----------------------------------------------------------------------------- |
| 102 | 102 | ;;; module LISP |
| 146 | 146 | ;; |
| 147 | 147 | (unless *apply-ignore-modules* |
| 148 | 148 | (setq *apply-ignore-modules* |
| 149 | (append *print-ignore-mods* | |
| 150 | (mapcar #'eval-modexp | |
| 151 | '("CHARACTER" "STRING" "OBJECT"))))) | |
| 149 | (append *print-ignore-mods* | |
| 150 | (mapcar #'eval-modexp | |
| 151 | '("CHARACTER" "STRING" "OBJECT"))))) | |
| 152 | 152 | ) |
| 153 | 153 | |
| 154 | 154 | ;; EOF |
| 0 | 0 | ;;;-*- Mode:LISP; Package:CHAOS; Base:10; Syntax:Common-lisp -*- |
| 1 | 1 | ;;; |
| 2 | ;;; Copyright (c) 2000-2014, Toshimi Sawada. All rights reserved. | |
| 2 | ;;; Copyright (c) 2000-2015, Toshimi Sawada. All rights reserved. | |
| 3 | 3 | ;;; |
| 4 | 4 | ;;; Redistribution and use in source and binary forms, with or without |
| 5 | 5 | ;;; modification, are permitted provided that the following conditions |
| 27 | 27 | ;;; |
| 28 | 28 | (in-package :chaos) |
| 29 | 29 | #|============================================================================== |
| 30 | System: Chaos | |
| 31 | Module: boot | |
| 32 | File: preproc.lisp | |
| 30 | System: Chaos | |
| 31 | Module: boot | |
| 32 | File: preproc.lisp | |
| 33 | 33 | ==============================================================================|# |
| 34 | 34 | |
| 35 | 35 | ;;;***************************************************************************** |
| 36 | ;;; Support procs of | |
| 37 | ;;; OBJ compatible Standard Prelude | |
| 38 | ;;; + | |
| 39 | ;;; Chaos specific builtin modules | |
| 36 | ;;; Support procs of | |
| 37 | ;;; OBJ compatible Standard Prelude | |
| 38 | ;;; + | |
| 39 | ;;; Chaos specific builtin modules | |
| 40 | 40 | ;;;***************************************************************************** |
| 41 | 41 | |
| 42 | 42 | ;;;----------------------------------------------------------------------------- |
| 54 | 54 | (defun token-is-sort-id (token) |
| 55 | 55 | (and (stringp token) |
| 56 | 56 | (<= 1 (length token)) |
| 57 | (find-all-sorts-in (or *current-module* *last-module*) | |
| 58 | token))) | |
| 57 | (find-all-sorts-in (get-context-module) token))) | |
| 59 | 58 | (defun create-sort-id (token) token) |
| 60 | 59 | (defun print-sort-id (x) (princ x)) |
| 61 | 60 | (defun is-sort-Id (x) |
| 69 | 68 | #|| |
| 70 | 69 | (defun setup-identical () |
| 71 | 70 | (let ((id-opinfo nil) |
| 72 | (nid-opinfo nil)) | |
| 71 | (nid-opinfo nil)) | |
| 73 | 72 | (setf *IDENTICAL-module* (eval-modexp "IDENTICAL")) |
| 74 | 73 | (with-in-module (*identical-module*) |
| 75 | 74 | (setf id-opinfo (find-operator '("_" "===" "_") |
| 76 | 2 | |
| 77 | *identical-module*)) | |
| 75 | 2 | |
| 76 | *identical-module*)) | |
| 78 | 77 | (setf *identical* |
| 79 | (lowest-method* (car (opinfo-methods id-opinfo)))) | |
| 78 | (lowest-method* (car (opinfo-methods id-opinfo)))) | |
| 80 | 79 | (setf nid-opinfo (find-operator '("_" "=/==" "_") 2 *identical-module*)) |
| 81 | 80 | (setf *nonidentical* |
| 82 | (lowest-method* (car (opinfo-methods nid-opinfo)))) | |
| 81 | (lowest-method* (car (opinfo-methods nid-opinfo)))) | |
| 83 | 82 | ))) |
| 84 | 83 | ||# |
| 85 | 84 | |
| 127 | 126 | (defun is-NzRat-token (token) |
| 128 | 127 | (and (stringp token) |
| 129 | 128 | (every #'(lambda (x) |
| 130 | (or (digit-char-p x) | |
| 131 | (eql #\- x) | |
| 132 | (eql #\/ x))) | |
| 133 | token) | |
| 129 | (or (digit-char-p x) | |
| 130 | (eql #\- x) | |
| 131 | (eql #\/ x))) | |
| 132 | token) | |
| 134 | 133 | (let* ((first (if (eql #\- (char token 0)) 1 0)) |
| 135 | (slash (position #\/ token))) | |
| 136 | (and slash | |
| 137 | (is-NzNat-token (subseq token first slash)) | |
| 138 | (is-NzNat-token (subseq token (+ slash 1))))))) | |
| 134 | (slash (position #\/ token))) | |
| 135 | (and slash | |
| 136 | (is-NzNat-token (subseq token first slash)) | |
| 137 | (is-NzNat-token (subseq token (+ slash 1))))))) | |
| 139 | 138 | (defun create-NzRat (x) (read-from-string x)) |
| 140 | 139 | (defun is-NzRat (x) (and (rationalp x) (not (= 0 x)))) |
| 141 | 140 | |
| 155 | 154 | (not (find #\. token)) |
| 156 | 155 | ;; (alpha-char-p (char token 0)) |
| 157 | 156 | (let ((pos (position #\: token)) |
| 158 | (len (length token))) | |
| 159 | (and (<= 1 len) | |
| 160 | (if pos | |
| 161 | (= pos (1- len)) | |
| 162 | t))))) | |
| 157 | (len (length token))) | |
| 158 | (and (<= 1 len) | |
| 159 | (if pos | |
| 160 | (= pos (1- len)) | |
| 161 | t))))) | |
| 163 | 162 | ;; (defun create-Id (token) (intern token)) |
| 164 | 163 | (defun create-Id (token) token) |
| 165 | 164 | ;; (defun print-Id (x) (princ (string x))) |
| 254 | 253 | ;;;----------------------------------------------------------------------------- |
| 255 | 254 | (defun is-Float-token (token) |
| 256 | 255 | (and (stringp token) |
| 257 | (or (digit-char-p (char token 0)) | |
| 258 | (and (member (char token 0) '(#\+ #\. #\-)) | |
| 259 | (<= 2 (length token)) | |
| 260 | (digit-char-p (char token 1)))) | |
| 256 | (let ((chars (coerce token 'list))) | |
| 257 | (and (<= 2 (length chars)) | |
| 258 | (member #\. chars))) | |
| 261 | 259 | (multiple-value-bind (res len) (read-from-string token) |
| 262 | (declare (ignore res)) | |
| 263 | (and (= (length token) len) | |
| 264 | (member (type-of (read-from-string token)) | |
| 265 | '(float long-float short-float fixnum bignum ratio | |
| 266 | single-float double-float | |
| 267 | )))))) | |
| 260 | (and (= (length token) len) | |
| 261 | (member (type-of res) | |
| 262 | '(float long-float short-float fixnum bignum ratio | |
| 263 | single-float double-float)))))) | |
| 264 | ||
| 268 | 265 | (defun create-Float (token) |
| 269 | 266 | (coerce (read-from-string token) 'long-float)) |
| 270 | 267 | (defun print-Float (val) (prin1 val)) |
| 275 | 272 | ;;;----------------------------------------------------------------------------- |
| 276 | 273 | (defmacro is-compiled-chaos-value (_val) |
| 277 | 274 | `(and (consp ,_val) |
| 278 | (eq (car ,_val) '|%Chaos|))) | |
| 275 | (eq (car ,_val) '|%Chaos|))) | |
| 279 | 276 | |
| 280 | 277 | (defun print-chaos-value (val) |
| 281 | 278 | #|| |
| 282 | 279 | (format t "#% ~s" |
| 283 | (if (is-compiled-chaos-value val) | |
| 284 | (nth 2 val) | |
| 285 | val)) | |
| 280 | (if (is-compiled-chaos-value val) | |
| 281 | (nth 2 val) | |
| 282 | val)) | |
| 286 | 283 | ||# |
| 287 | 284 | (print-chaos-object val) |
| 288 | 285 | ) |
| 317 | 314 | (prepare-for-parsing *truth-value-module*) |
| 318 | 315 | (with-in-module (*truth-value-module*) |
| 319 | 316 | (setq *bool-sort* |
| 320 | (find-sort-in *truth-value-module* "Bool")) | |
| 317 | (find-sort-in *truth-value-module* "Bool")) | |
| 321 | 318 | (setq *condition-sort* |
| 322 | 319 | (find-sort-in *truth-value-module* "*Condition*")) |
| 323 | 320 | (let* ((t-opinfo (find-operator '("true") 0 *truth-value-module*)) |
| 324 | (f-opinfo (find-operator '("false") 0 *truth-value-module*)) | |
| 325 | (t-meth (lowest-method* (car (opinfo-methods t-opinfo)))) | |
| 326 | (f-meth (lowest-method* (car (opinfo-methods f-opinfo))))) | |
| 321 | (f-opinfo (find-operator '("false") 0 *truth-value-module*)) | |
| 322 | (t-meth (lowest-method* (car (opinfo-methods t-opinfo)))) | |
| 323 | (f-meth (lowest-method* (car (opinfo-methods f-opinfo))))) | |
| 327 | 324 | (setq *BOOL-true* (make-applform *bool-sort* |
| 328 | t-meth | |
| 329 | nil)) | |
| 325 | t-meth | |
| 326 | nil)) | |
| 330 | 327 | (setq *bool-true-meth* t-meth) |
| 331 | 328 | (setq *bool-false* (make-applform *bool-sort* |
| 332 | f-meth | |
| 333 | nil)) | |
| 329 | f-meth | |
| 330 | nil)) | |
| 334 | 331 | (setq *bool-false-meth* f-meth)) |
| 335 | 332 | )) |
| 336 | 333 | |
| 340 | 337 | (prepare-for-parsing *truth-module*) |
| 341 | 338 | (with-in-module (*truth-module*) |
| 342 | 339 | (let* ((sort-mem-op-info (find-operator '("_" ":is" "_") |
| 343 | 2 | |
| 344 | *truth-module*)) | |
| 345 | (sort-mem-meth (lowest-method* (car (opinfo-methods sort-mem-op-info))))) | |
| 340 | 2 | |
| 341 | *truth-module*)) | |
| 342 | (sort-mem-meth (lowest-method* (car (opinfo-methods sort-mem-op-info))))) | |
| 346 | 343 | (setq *sort-membership* sort-mem-meth)) |
| 347 | 344 | |
| 348 | 345 | (let* ((if-op-info (find-operator '("if" "_" "then" "_" "else" "_" "fi") |
| 349 | 3 | |
| 350 | *truth-module*)) | |
| 351 | (if-meth (lowest-method* (car (opinfo-methods if-op-info))))) | |
| 346 | 3 | |
| 347 | *truth-module*)) | |
| 348 | (if-meth (lowest-method* (car (opinfo-methods if-op-info))))) | |
| 352 | 349 | (setq *BOOL-if* if-meth) |
| 353 | 350 | ;; |
| 354 | 351 | (let* ((equal-op-info (find-operator '("_" "==" "_") 2 *truth-module*)) |
| 355 | (equal-meth (lowest-method* (car (opinfo-methods equal-op-info)))) | |
| 356 | (beq-op-info (find-operator '("_" "=*=" "_") 2 *truth-module*)) | |
| 357 | (beq-meth (lowest-method* (car (opinfo-methods beq-op-info)))) | |
| 358 | (n-equal-op-info (find-operator '("_" "=/=" "_") 2 *truth-module*)) | |
| 359 | (n-equal-meth (lowest-method* (car (opinfo-methods n-equal-op-info)))) | |
| 360 | (beh-eq-info (find-operator '("_" "=b=" "_") 2 *truth-module*)) | |
| 361 | (beh-eq-meth (lowest-method* (car (opinfo-methods beh-eq-info))))) | |
| 362 | (setq *bool-equal* equal-meth) | |
| 363 | (setq *beh-equal* beq-meth) | |
| 364 | (setq *bool-nonequal* n-equal-meth) | |
| 365 | (setq *beh-eq-pred* beh-eq-meth) | |
| 366 | )))) | |
| 352 | (equal-meth (lowest-method* (car (opinfo-methods equal-op-info)))) | |
| 353 | (beq-op-info (find-operator '("_" "=*=" "_") 2 *truth-module*)) | |
| 354 | (beq-meth (lowest-method* (car (opinfo-methods beq-op-info)))) | |
| 355 | (n-equal-op-info (find-operator '("_" "=/=" "_") 2 *truth-module*)) | |
| 356 | (n-equal-meth (lowest-method* (car (opinfo-methods n-equal-op-info)))) | |
| 357 | (beh-eq-info (find-operator '("_" "=b=" "_") 2 *truth-module*)) | |
| 358 | (beh-eq-meth (lowest-method* (car (opinfo-methods beh-eq-info))))) | |
| 359 | (setq *bool-equal* equal-meth) | |
| 360 | (setq *beh-equal* beq-meth) | |
| 361 | (setq *bool-nonequal* n-equal-meth) | |
| 362 | (setq *beh-eq-pred* beh-eq-meth) | |
| 363 | )))) | |
| 367 | 364 | ||# |
| 368 | 365 | |
| 369 | 366 | #|| |
| 371 | 368 | (setq *BOOL-module* (eval-modexp "BOOL")) |
| 372 | 369 | (with-in-module (*bool-module*) |
| 373 | 370 | (let* ((and-op-info (find-operator '("_" "and" "_") 2 *bool-module*)) |
| 374 | (and-meth (lowest-method* (car (opinfo-methods and-op-info))))) | |
| 371 | (and-meth (lowest-method* (car (opinfo-methods and-op-info))))) | |
| 375 | 372 | (setq *bool-and* and-meth)) |
| 376 | 373 | (let* ((or-op-info (find-operator '("_" "or" "_") 2 *bool-module*)) |
| 377 | (or-meth (lowest-method* (car (opinfo-methods or-op-info))))) | |
| 374 | (or-meth (lowest-method* (car (opinfo-methods or-op-info))))) | |
| 378 | 375 | (setq *bool-or* or-meth)) |
| 379 | 376 | (let* ((not-op-info (find-operator '("not" "_") 1 *bool-module*)) |
| 380 | (not-meth (lowest-method* (car (opinfo-methods not-op-info))))) | |
| 377 | (not-meth (lowest-method* (car (opinfo-methods not-op-info))))) | |
| 381 | 378 | (setq *bool-not* not-meth)) |
| 382 | 379 | (let* ((xor-op-info (find-operator '("_" "xor" "_") 2 *bool-module*)) |
| 383 | (xor-meth (lowest-method* (car (opinfo-methods xor-op-info))))) | |
| 380 | (xor-meth (lowest-method* (car (opinfo-methods xor-op-info))))) | |
| 384 | 381 | (setq *bool-xor* xor-meth)) |
| 385 | 382 | (let* ((imp-op-info (find-operator '("_" "implies" "_") 2 *bool-module*)) |
| 386 | (imp-meth (lowest-method* (car (opinfo-methods imp-op-info))))) | |
| 383 | (imp-meth (lowest-method* (car (opinfo-methods imp-op-info))))) | |
| 387 | 384 | (setq *bool-imply* imp-meth)) |
| 388 | 385 | (let* ((and-also (find-operator '("_" "and-also" "_") 2 *bool-module*)) |
| 389 | (and-also-meth (lowest-method* (car (opinfo-methods and-also))))) | |
| 386 | (and-also-meth (lowest-method* (car (opinfo-methods and-also))))) | |
| 390 | 387 | (setq *bool-and-also* and-also-meth)) |
| 391 | 388 | (let* ((or-else (find-operator '("_" "or-else" "_") 2 *bool-module*)) |
| 392 | (or-else-meth (lowest-method* (car (opinfo-methods or-else))))) | |
| 389 | (or-else-meth (lowest-method* (car (opinfo-methods or-else))))) | |
| 393 | 390 | (setq *bool-or-else* or-else-meth)) |
| 394 | 391 | (let* ((iff (find-operator '("_" "iff" "_") 2 *bool-module*)) |
| 395 | (iff-meth (lowest-method* (car (opinfo-methods iff))))) | |
| 392 | (iff-meth (lowest-method* (car (opinfo-methods iff))))) | |
| 396 | 393 | (setq *bool-iff* iff-meth)) |
| 397 | 394 | |
| 398 | 395 | )) |
| 444 | 441 | (final-setup *rwl-module*) |
| 445 | 442 | (with-in-module (*rwl-module*) |
| 446 | 443 | (let* ((nat-star (find-sort-in *rwl-module* "Nat*")) |
| 447 | (rwl-op-info (find-operator '("_" "==>" "_") 2 *rwl-module*)) | |
| 448 | (rwl-pred (lowest-method* (car (opinfo-methods rwl-op-info)))) | |
| 449 | (rwl-op-info2 (find-operator '("_" "=" "(" "_" ")" "=>" "_") | |
| 450 | 3 | |
| 451 | *rwl-module*)) | |
| 452 | (rwl-pred2 (lowest-method* (car (opinfo-methods rwl-op-info2))))) | |
| 444 | (rwl-op-info (find-operator '("_" "==>" "_") 2 *rwl-module*)) | |
| 445 | (rwl-pred (lowest-method* (car (opinfo-methods rwl-op-info)))) | |
| 446 | (rwl-op-info2 (find-operator '("_" "=" "(" "_" ")" "=>" "_") | |
| 447 | 3 | |
| 448 | *rwl-module*)) | |
| 449 | (rwl-pred2 (lowest-method* (car (opinfo-methods rwl-op-info2))))) | |
| 453 | 450 | (unless nat-star |
| 454 | (with-output-panic-message () | |
| 455 | (princ "could not find sort Nat*...") | |
| 456 | (break))) | |
| 451 | (with-output-panic-message () | |
| 452 | (princ "could not find sort Nat*...") | |
| 453 | (break))) | |
| 457 | 454 | (unless rwl-pred |
| 458 | (with-output-panic-message () | |
| 459 | (princ "could not find ==> operaotr....") | |
| 460 | (break))) | |
| 455 | (with-output-panic-message () | |
| 456 | (princ "could not find ==> operaotr....") | |
| 457 | (break))) | |
| 461 | 458 | (unless rwl-pred2 |
| 462 | (with-output-panic-message () | |
| 463 | (print "could not find =(?)=> operator ....") | |
| 464 | (break))) | |
| 459 | (with-output-panic-message () | |
| 460 | (print "could not find =(?)=> operator ....") | |
| 461 | (break))) | |
| 465 | 462 | ;; |
| 466 | 463 | (setq *rwl-nat-star-sort* nat-star) |
| 467 | 464 | (setq *rwl-predicate* rwl-pred) |
| 478 | 475 | (defun install-character () |
| 479 | 476 | (let ((char-module (eval-modexp "CHAR-VALUE"))) |
| 480 | 477 | (if (and char-module (not (modexp-is-error char-module))) |
| 481 | (let ((c-sort (find-sort-in char-module "Character"))) | |
| 482 | (if c-sort | |
| 483 | (setq *character-sort* c-sort) | |
| 484 | (with-output-panic-message () | |
| 485 | (princ "could not find Character sort in module CHAR-VALUE")))) | |
| 486 | (with-output-panic-message () | |
| 487 | (princ "Could not find module CHAR-VALUE.") | |
| 488 | (break))))) | |
| 478 | (let ((c-sort (find-sort-in char-module "Character"))) | |
| 479 | (if c-sort | |
| 480 | (setq *character-sort* c-sort) | |
| 481 | (with-output-panic-message () | |
| 482 | (princ "could not find Character sort in module CHAR-VALUE")))) | |
| 483 | (with-output-panic-message () | |
| 484 | (princ "Could not find module CHAR-VALUE.") | |
| 485 | (break))))) | |
| 489 | 486 | |
| 490 | 487 | ;;; character-token ::= 'char' |
| 491 | 488 | ;;; char ::= <alphanumeric> |
| 493 | 490 | (defun is-character-token (tok) |
| 494 | 491 | (and (stringp tok) |
| 495 | 492 | (let ((len (length tok))) |
| 496 | (and (< 2 len) | |
| 497 | (eql (char tok 0) #\') | |
| 498 | (eql (char tok (1- len)) #\') | |
| 499 | (let ((first-char (char tok 1))) | |
| 500 | (case first-char | |
| 501 | (#\\ ; escape | |
| 502 | (or (every #'(lambda (x) (digit-char-p x)) (subseq tok 2 (1- len))) | |
| 503 | (= len 4))) | |
| 504 | (t (= len 3)))))))) | |
| 493 | (and (< 2 len) | |
| 494 | (eql (char tok 0) #\') | |
| 495 | (eql (char tok (1- len)) #\') | |
| 496 | (let ((first-char (char tok 1))) | |
| 497 | (case first-char | |
| 498 | (#\\ ; escape | |
| 499 | (or (every #'(lambda (x) (digit-char-p x)) (subseq tok 2 (1- len))) | |
| 500 | (= len 4))) | |
| 501 | (t (= len 3)))))))) | |
| 505 | 502 | |
| 506 | 503 | (defun create-character (tok) |
| 507 | 504 | (let ((len (length tok))) |
| 508 | 505 | (if (= 3 len) |
| 509 | (char tok 1) | |
| 510 | (let ((first-char (char tok 2))) | |
| 511 | (if (digit-char-p first-char) | |
| 512 | (let ((num (read-from-string (subseq tok 2 (1- len))))) | |
| 513 | (if (< num char-code-limit) | |
| 514 | (code-char num) | |
| 515 | (with-output-chaos-error ('invalid-char-code) | |
| 516 | (format t "invalid character code '\\~d' is given" num) | |
| 517 | ))) | |
| 518 | (case first-char | |
| 519 | (#\n #\newline) | |
| 520 | (#\l #\linefeed) | |
| 521 | (#\t #\tab) | |
| 522 | (#\s #\space) | |
| 523 | (#\p #\page) | |
| 524 | (otherwise first-char))))))) | |
| 506 | (char tok 1) | |
| 507 | (let ((first-char (char tok 2))) | |
| 508 | (if (digit-char-p first-char) | |
| 509 | (let ((num (read-from-string (subseq tok 2 (1- len))))) | |
| 510 | (if (< num char-code-limit) | |
| 511 | (code-char num) | |
| 512 | (with-output-chaos-error ('invalid-char-code) | |
| 513 | (format t "invalid character code '\\~d' is given" num) | |
| 514 | ))) | |
| 515 | (case first-char | |
| 516 | (#\n #\newline) | |
| 517 | (#\l #\linefeed) | |
| 518 | (#\t #\tab) | |
| 519 | (#\s #\space) | |
| 520 | (#\p #\page) | |
| 521 | (otherwise first-char))))))) | |
| 525 | 522 | |
| 526 | 523 | (defun is-character (obj) (characterp obj)) |
| 527 | 524 | |
| 528 | 525 | (defun print-character (obj) |
| 529 | 526 | (if (graphic-char-p obj) |
| 530 | 527 | (if (eql obj #\space) |
| 531 | (princ "'\\s'") | |
| 532 | (format t "'~a'" obj)) | |
| 528 | (princ "'\\s'") | |
| 529 | (format t "'~a'" obj)) | |
| 533 | 530 | (case obj |
| 534 | (#\newline (princ "'\\n'")) | |
| 535 | ;; #-:CLISP (#\linefeed (princ "'\\l'")) | |
| 536 | (#\tab (princ "'\\t'")) | |
| 537 | (#\space (princ "'\\s'")) | |
| 538 | (#\page (princ "'\\p'")) | |
| 539 | (otherwise (format t "'\\~d'" (char-code obj)))))) | |
| 531 | (#\newline (princ "'\\n'")) | |
| 532 | ;; #-:CLISP (#\linefeed (princ "'\\l'")) | |
| 533 | (#\tab (princ "'\\t'")) | |
| 534 | (#\space (princ "'\\s'")) | |
| 535 | (#\page (princ "'\\p'")) | |
| 536 | (otherwise (format t "'\\~d'" (char-code obj)))))) | |
| 540 | 537 | |
| 541 | 538 | ;;;----------------------------------------------------------------------------- |
| 542 | 539 | ;;; module STRING |
| 544 | 541 | (defun install-string () |
| 545 | 542 | (let ((string-module (eval-modexp "STRING-VALUE"))) |
| 546 | 543 | (if (and string-module (not (modexp-is-error string-module))) |
| 547 | (let ((s-sort (find-sort-in string-module "String"))) | |
| 548 | (if s-sort | |
| 549 | (setq *string-sort* s-sort) | |
| 550 | (with-output-panic-message() | |
| 551 | (princ "could not find String sort in module STRING-VALUE")))) | |
| 552 | (with-output-panic-message() | |
| 553 | (princ "Could not find module STRING-VALUE.") | |
| 554 | (break))))) | |
| 544 | (let ((s-sort (find-sort-in string-module "String"))) | |
| 545 | (if s-sort | |
| 546 | (setq *string-sort* s-sort) | |
| 547 | (with-output-panic-message() | |
| 548 | (princ "could not find String sort in module STRING-VALUE")))) | |
| 549 | (with-output-panic-message() | |
| 550 | (princ "Could not find module STRING-VALUE.") | |
| 551 | (break))))) | |
| 555 | 552 | |
| 556 | 553 | (defun s-find (Char Str Num) |
| 557 | 554 | (let ((C (term-builtin-value Char)) |
| 558 | (S (term-builtin-value Str)) | |
| 559 | (N (term-builtin-value Num))) | |
| 555 | (S (term-builtin-value Str)) | |
| 556 | (N (term-builtin-value Num))) | |
| 560 | 557 | (let ((pos (position C S :start N))) |
| 561 | 558 | (if pos |
| 562 | (simple-parse-from-string (format nil "~s" pos)) | |
| 563 | (simple-parse-from-string "notFound"))))) | |
| 559 | (simple-parse-from-string (format nil "~s" pos)) | |
| 560 | (simple-parse-from-string "notFound"))))) | |
| 564 | 561 | |
| 565 | 562 | (defun s-rfind (Char Str Num) |
| 566 | 563 | (let ((C (term-builtin-value char)) |
| 567 | (S (term-builtin-value Str)) | |
| 568 | (N (term-builtin-value Num))) | |
| 564 | (S (term-builtin-value Str)) | |
| 565 | (N (term-builtin-value Num))) | |
| 569 | 566 | (let ((pos (position C S :start N :from-end t))) |
| 570 | 567 | (if pos |
| 571 | (simple-parse-from-string (format nil "~s" pos)) | |
| 572 | (simple-parse-from-string "notFound"))))) | |
| 568 | (simple-parse-from-string (format nil "~s" pos)) | |
| 569 | (simple-parse-from-string "notFound"))))) | |
| 573 | 570 | |
| 574 | 571 | ; ;;;----------------------------------------------------------------------------- |
| 575 | 572 | ; ;;; module CHAOS:EXPR |
| 577 | 574 | ; (defun install-chaos-expr () |
| 578 | 575 | ; (let ((module (eval-modexp "CHAOS:EXPR"))) |
| 579 | 576 | ; (labels ((sort-missing (sort-name) |
| 580 | ; (with-output-panic-message () | |
| 581 | ; (format t "missing sort ~s" sort-name)))) | |
| 577 | ; (with-output-panic-message () | |
| 578 | ; (format t "missing sort ~s" sort-name)))) | |
| 582 | 579 | ; (macrolet ((set-sort (sym s-name) |
| 583 | ; `(or (setq ,sym (find-sort-in module ,s-name)) | |
| 584 | ; (sort-missing ,s-name)))) | |
| 580 | ; `(or (setq ,sym (find-sort-in module ,s-name)) | |
| 581 | ; (sort-missing ,s-name)))) | |
| 585 | 582 | ; (if (and module (not (modexp-is-error module))) |
| 586 | ; (progn | |
| 587 | ; (final-setup module) | |
| 588 | ; (set-sort *chaos-value-sort* "ChaosObject") | |
| 589 | ; (set-sort *sort-sort* "ChaosSort") | |
| 590 | ; (set-sort *general-sort* "Sort") | |
| 591 | ; (set-sort *and-sort* "AndSort") | |
| 592 | ; (set-sort *or-sort* "OrSort") | |
| 593 | ; (set-sort *err-sort* "ErrSort") | |
| 594 | ; (set-sort *operator-sort* "Operator") | |
| 595 | ; (set-sort *axiom-sort* "Axiom") | |
| 596 | ; (set-sort *module-sort* "Module") | |
| 597 | ; (set-sort *term-sort* "Term") | |
| 598 | ; (set-sort *variable-sort* "Variable") | |
| 599 | ; (set-sort *appl-form-sort* "ApplForm") | |
| 600 | ; (set-sort *pvariable-sort* "PVariable") | |
| 601 | ; (set-sort *lisp-term-sort* "LispTerm") | |
| 602 | ; (set-sort *slisp-term-sort* "SlispTerm") | |
| 603 | ; (set-sort *glisp-term-sort* "GlispTerm") | |
| 604 | ; (set-sort *bconst-term-sort* "BconstTerm") | |
| 605 | ; (set-sort *optheory-sort* "OpTheory") | |
| 606 | ; (set-sort *modexpr-sort* "ModExpr") | |
| 607 | ; (set-sort *chaos-list-sort* "ChaosList") | |
| 608 | ; (set-sort *chaos-void-sort* "ChaosVoid") | |
| 609 | ; #|| | |
| 610 | ; (declare-subsort-in-module | |
| 611 | ; `((,*general-sort* ,*and-sort* ,*or-sort* ,*err-sort* | |
| 612 | ; :< ,*sort-sort*) | |
| 613 | ; (,*sort-sort* ,*operator-sort* ,*axiom-sort* ,*module-sort* | |
| 614 | ; ,*term-sort* ,*modexpr-sort* ,*string-sort* | |
| 615 | ; ,*qid-sort* ,*chaos-list-sort* | |
| 616 | ; :< ,*chaos-value-sort*) | |
| 617 | ; (,*chaos-void-sort* :< ,*general-sort* ,*and-sort* ,*or-sort* ,*err-sort* | |
| 618 | ; ,*operator-sort* ,*axiom-sort* | |
| 619 | ; ,*module-sort* ,*term-sort* ,*modexpr-sort* | |
| 620 | ; ,*chaos-list-sort*)) | |
| 621 | ; module) | |
| 622 | ; ||# | |
| 623 | ; ) | |
| 624 | ; (with-output-panic-message() | |
| 625 | ; (princ "Could not find module ChaosExpr.") | |
| 626 | ; (break))))))) | |
| 583 | ; (progn | |
| 584 | ; (final-setup module) | |
| 585 | ; (set-sort *chaos-value-sort* "ChaosObject") | |
| 586 | ; (set-sort *sort-sort* "ChaosSort") | |
| 587 | ; (set-sort *general-sort* "Sort") | |
| 588 | ; (set-sort *and-sort* "AndSort") | |
| 589 | ; (set-sort *or-sort* "OrSort") | |
| 590 | ; (set-sort *err-sort* "ErrSort") | |
| 591 | ; (set-sort *operator-sort* "Operator") | |
| 592 | ; (set-sort *axiom-sort* "Axiom") | |
| 593 | ; (set-sort *module-sort* "Module") | |
| 594 | ; (set-sort *term-sort* "Term") | |
| 595 | ; (set-sort *variable-sort* "Variable") | |
| 596 | ; (set-sort *appl-form-sort* "ApplForm") | |
| 597 | ; (set-sort *pvariable-sort* "PVariable") | |
| 598 | ; (set-sort *lisp-term-sort* "LispTerm") | |
| 599 | ; (set-sort *slisp-term-sort* "SlispTerm") | |
| 600 | ; (set-sort *glisp-term-sort* "GlispTerm") | |
| 601 | ; (set-sort *bconst-term-sort* "BconstTerm") | |
| 602 | ; (set-sort *optheory-sort* "OpTheory") | |
| 603 | ; (set-sort *modexpr-sort* "ModExpr") | |
| 604 | ; (set-sort *chaos-list-sort* "ChaosList") | |
| 605 | ; (set-sort *chaos-void-sort* "ChaosVoid") | |
| 606 | ; #|| | |
| 607 | ; (declare-subsort-in-module | |
| 608 | ; `((,*general-sort* ,*and-sort* ,*or-sort* ,*err-sort* | |
| 609 | ; :< ,*sort-sort*) | |
| 610 | ; (,*sort-sort* ,*operator-sort* ,*axiom-sort* ,*module-sort* | |
| 611 | ; ,*term-sort* ,*modexpr-sort* ,*string-sort* | |
| 612 | ; ,*qid-sort* ,*chaos-list-sort* | |
| 613 | ; :< ,*chaos-value-sort*) | |
| 614 | ; (,*chaos-void-sort* :< ,*general-sort* ,*and-sort* ,*or-sort* ,*err-sort* | |
| 615 | ; ,*operator-sort* ,*axiom-sort* | |
| 616 | ; ,*module-sort* ,*term-sort* ,*modexpr-sort* | |
| 617 | ; ,*chaos-list-sort*)) | |
| 618 | ; module) | |
| 619 | ; ||# | |
| 620 | ; ) | |
| 621 | ; (with-output-panic-message() | |
| 622 | ; (princ "Could not find module ChaosExpr.") | |
| 623 | ; (break))))))) | |
| 627 | 624 | |
| 628 | 625 | ;;;----------------------------------------------------------------------------- |
| 629 | 626 | ;;; Record Structure/Object |
| 635 | 632 | (let ((oid-mod (eval-modexp "OBJECT-ID"))) |
| 636 | 633 | (when (or (null oid-mod) (modexp-is-error oid-mod)) |
| 637 | 634 | (with-output-panic-message () |
| 638 | (princ "OBJECT-ID is missing!.") | |
| 639 | (break))) | |
| 635 | (princ "OBJECT-ID is missing!.") | |
| 636 | (break))) | |
| 640 | 637 | (let ((oid-sort (find-sort-in oid-mod "ObjectId"))) |
| 641 | 638 | (unless oid-sort (with-output-panic-message () |
| 642 | (princ "sort ObjectId missing!.") | |
| 643 | (chaos-to-top))) | |
| 639 | (princ "sort ObjectId missing!.") | |
| 640 | (chaos-to-top))) | |
| 644 | 641 | (setq *object-identifier-sort* oid-sort)))) |
| 645 | 642 | |
| 646 | 643 | ;;; |
| 648 | 645 | ;;; |
| 649 | 646 | (defun install-record-object () |
| 650 | 647 | (let ((av-pair (eval-modexp "AVPAIR")) |
| 651 | (rs (eval-modexp "RECORD-STRUCTURE")) | |
| 652 | (ob (eval-modexp "OBJECT")) | |
| 653 | (con (eval-modexp "STATE-CONFIGURATION")) | |
| 654 | (acz-con (eval-modexp "ACZ-CONFIGURATION"))) | |
| 648 | (rs (eval-modexp "RECORD-STRUCTURE")) | |
| 649 | (ob (eval-modexp "OBJECT")) | |
| 650 | (con (eval-modexp "STATE-CONFIGURATION")) | |
| 651 | (acz-con (eval-modexp "ACZ-CONFIGURATION"))) | |
| 655 | 652 | (if (and av-pair (not (modexp-is-error av-pair))) |
| 656 | (let ((attrid (find-sort-in av-pair "AttrId")) | |
| 657 | (attrval (find-sort-in av-pair "AttrValue")) | |
| 658 | (attribute (find-sort-in av-pair "Attribute")) | |
| 659 | (attribute-list (find-sort-in av-pair "Attributes"))) | |
| 660 | (if attrid | |
| 661 | (setf *attribute-id-sort* attrid) | |
| 662 | (with-output-panic-message () | |
| 663 | (princ "Panic: could not find sort AttrId") | |
| 664 | (break))) | |
| 665 | (if attrval | |
| 666 | (setf *attr-value-sort* attrval) | |
| 667 | (with-output-panic-message () | |
| 668 | (princ "Panic: counld not find sort AttrValue") | |
| 669 | (break))) | |
| 670 | (if attribute | |
| 671 | (setf *attribute-sort* attribute) | |
| 672 | (with-output-panic-message () | |
| 673 | (princ "Panic: could not find sort Attribute") | |
| 674 | (break))) | |
| 675 | (if attribute-list | |
| 676 | (progn (setf *attribute-list-sort* attribute-list) | |
| 677 | (setf *attribute-list-aux-variable* | |
| 678 | (make-variable-term *attribute-list-sort* | |
| 679 | '|Attr_Aux|))) | |
| 680 | (with-output-panic-message () | |
| 681 | (princ "could not find sort Attributes") | |
| 682 | (break))) | |
| 683 | (let ((attr-constructor (find-method-in av-pair | |
| 684 | '("_" "=" "_") | |
| 685 | (list *attribute-id-sort* | |
| 686 | *attr-value-sort*) | |
| 687 | *attribute-sort*)) | |
| 688 | (atlist-constructor (find-method-in av-pair | |
| 689 | '("_" "," "_") | |
| 690 | (list *attribute-list-sort* | |
| 691 | *attribute-list-sort*) | |
| 692 | *attribute-list-sort*))) | |
| 693 | (if attr-constructor | |
| 694 | (setf *attribute-constructor* attr-constructor) | |
| 695 | (with-output-panic-message () | |
| 696 | (princ "could not find attribute constructor!") | |
| 697 | (break))) | |
| 698 | (if atlist-constructor | |
| 699 | (setf *attribute-list-constructor* atlist-constructor) | |
| 700 | (with-output-panic-message () | |
| 701 | (princ "could not find attribute list constructor!") | |
| 702 | (break)))) | |
| 703 | ) | |
| 704 | (with-output-panic-message () | |
| 705 | (princ "could not find module AVPAIR"))) | |
| 653 | (let ((attrid (find-sort-in av-pair "AttrId")) | |
| 654 | (attrval (find-sort-in av-pair "AttrValue")) | |
| 655 | (attribute (find-sort-in av-pair "Attribute")) | |
| 656 | (attribute-list (find-sort-in av-pair "Attributes"))) | |
| 657 | (if attrid | |
| 658 | (setf *attribute-id-sort* attrid) | |
| 659 | (with-output-panic-message () | |
| 660 | (princ "Panic: could not find sort AttrId") | |
| 661 | (break))) | |
| 662 | (if attrval | |
| 663 | (setf *attr-value-sort* attrval) | |
| 664 | (with-output-panic-message () | |
| 665 | (princ "Panic: counld not find sort AttrValue") | |
| 666 | (break))) | |
| 667 | (if attribute | |
| 668 | (setf *attribute-sort* attribute) | |
| 669 | (with-output-panic-message () | |
| 670 | (princ "Panic: could not find sort Attribute") | |
| 671 | (break))) | |
| 672 | (if attribute-list | |
| 673 | (progn (setf *attribute-list-sort* attribute-list) | |
| 674 | (setf *attribute-list-aux-variable* | |
| 675 | (make-variable-term *attribute-list-sort* | |
| 676 | '|Attr_Aux|))) | |
| 677 | (with-output-panic-message () | |
| 678 | (princ "could not find sort Attributes") | |
| 679 | (break))) | |
| 680 | (let ((attr-constructor (find-method-in av-pair | |
| 681 | '("_" "=" "_") | |
| 682 | (list *attribute-id-sort* | |
| 683 | *attr-value-sort*) | |
| 684 | *attribute-sort*)) | |
| 685 | (atlist-constructor (find-method-in av-pair | |
| 686 | '("_" "," "_") | |
| 687 | (list *attribute-list-sort* | |
| 688 | *attribute-list-sort*) | |
| 689 | *attribute-list-sort*))) | |
| 690 | (if attr-constructor | |
| 691 | (setf *attribute-constructor* attr-constructor) | |
| 692 | (with-output-panic-message () | |
| 693 | (princ "could not find attribute constructor!") | |
| 694 | (break))) | |
| 695 | (if atlist-constructor | |
| 696 | (setf *attribute-list-constructor* atlist-constructor) | |
| 697 | (with-output-panic-message () | |
| 698 | (princ "could not find attribute list constructor!") | |
| 699 | (break)))) | |
| 700 | ) | |
| 701 | (with-output-panic-message () | |
| 702 | (princ "could not find module AVPAIR"))) | |
| 706 | 703 | (if rs |
| 707 | (let ((rinst (find-sort-in rs "RecordInstance")) | |
| 708 | (rid (find-sort-in rs "RecordId")) | |
| 709 | (constr nil) | |
| 710 | void) | |
| 711 | (if rinst | |
| 712 | (setf *record-instance-sort* rinst) | |
| 713 | (with-output-panic-message () | |
| 714 | (princ "could not find RecordInstance sort!!"))) | |
| 715 | (if rid | |
| 716 | (setf *record-id-sort* rid) | |
| 717 | (error "Panic: could not find sort RecordId")) | |
| 718 | (setf constr (find-method-in rs | |
| 719 | '("_" "{" "_" "}") | |
| 720 | (list *record-id-sort* | |
| 721 | *attribute-list-sort*) | |
| 722 | *record-instance-sort*)) | |
| 723 | (if constr | |
| 724 | (progn (setf *record-constructor-method* constr) | |
| 725 | (setf *record-constructor-op* | |
| 726 | (method-operator constr (module-opinfo-table rs)))) | |
| 727 | (error "Panic: could not find record constructor!")) | |
| 728 | (setf void (find-method-in rs '("*VoidRecord*") nil *record-instance-sort*)) | |
| 729 | (if void | |
| 730 | (setf *void-record* | |
| 731 | (make-applform-simple *record-instance-sort* void)) | |
| 732 | (error "Panic: could not find void record operator.")) | |
| 733 | ) | |
| 734 | (error "Panic: could not find module RECORD-STRUCTURE")) | |
| 704 | (let ((rinst (find-sort-in rs "RecordInstance")) | |
| 705 | (rid (find-sort-in rs "RecordId")) | |
| 706 | (constr nil) | |
| 707 | void) | |
| 708 | (if rinst | |
| 709 | (setf *record-instance-sort* rinst) | |
| 710 | (with-output-panic-message () | |
| 711 | (princ "could not find RecordInstance sort!!"))) | |
| 712 | (if rid | |
| 713 | (setf *record-id-sort* rid) | |
| 714 | (error "Panic: could not find sort RecordId")) | |
| 715 | (setf constr (find-method-in rs | |
| 716 | '("_" "{" "_" "}") | |
| 717 | (list *record-id-sort* | |
| 718 | *attribute-list-sort*) | |
| 719 | *record-instance-sort*)) | |
| 720 | (if constr | |
| 721 | (progn (setf *record-constructor-method* constr) | |
| 722 | (setf *record-constructor-op* | |
| 723 | (method-operator constr (module-opinfo-table rs)))) | |
| 724 | (error "Panic: could not find record constructor!")) | |
| 725 | (setf void (find-method-in rs '("*VoidRecord*") nil *record-instance-sort*)) | |
| 726 | (if void | |
| 727 | (setf *void-record* | |
| 728 | (make-applform-simple *record-instance-sort* void)) | |
| 729 | (error "Panic: could not find void record operator.")) | |
| 730 | ) | |
| 731 | (error "Panic: could not find module RECORD-STRUCTURE")) | |
| 735 | 732 | (if ob |
| 736 | (let ((obj (find-sort-in ob "Object")) | |
| 737 | (cid (find-sort-in ob "ClassId")) | |
| 738 | (msg (find-sort-in ob "Message")) | |
| 739 | ref | |
| 740 | void | |
| 741 | constr) | |
| 742 | (if obj | |
| 743 | (setq *object-sort* obj) | |
| 744 | (error "Panic: could not find sort Object")) | |
| 745 | (if cid | |
| 746 | (setf *class-id-sort* cid) | |
| 747 | (error "Panic: could not find sort ClassId")) | |
| 748 | (if msg | |
| 749 | (setf *message-sort* msg) | |
| 750 | (error "Panic: could not find sort Message")) | |
| 751 | (setf void (find-method-in ob '("*VoidObject*") nil *object-sort*)) | |
| 752 | (if void | |
| 753 | (setf *void-object* | |
| 754 | (make-applform-simple *object-sort* void)) | |
| 755 | (error "Panic: could not find void object operator.")) | |
| 756 | (setf ref (find-method-in ob | |
| 757 | '("<" "_" ":" "_" ">") | |
| 758 | (list *object-identifier-sort* | |
| 759 | *class-id-sort*) | |
| 760 | *object-sort*)) | |
| 761 | (if ref | |
| 762 | (setf *object-reference-method* ref) | |
| 763 | (error "Panic: could not find object reference method.")) | |
| 764 | (setf constr (find-method-in ob | |
| 765 | '("<" "_" ":" "_" "|" "_" ">") | |
| 766 | (list *object-identifier-sort* | |
| 767 | *class-id-sort* | |
| 768 | *attribute-list-sort*) | |
| 769 | *object-sort*)) | |
| 770 | (if constr | |
| 771 | (progn (setf *object-constructor-method* constr) | |
| 772 | (setf *object-constructor-op* | |
| 773 | (method-operator constr (module-opinfo-table ob)))) | |
| 774 | (error "Panic: could not find object constructor method.")) | |
| 775 | ) | |
| 776 | (error "Panic: could not find module OBJECT")) | |
| 733 | (let ((obj (find-sort-in ob "Object")) | |
| 734 | (cid (find-sort-in ob "ClassId")) | |
| 735 | (msg (find-sort-in ob "Message")) | |
| 736 | ref | |
| 737 | void | |
| 738 | constr) | |
| 739 | (if obj | |
| 740 | (setq *object-sort* obj) | |
| 741 | (error "Panic: could not find sort Object")) | |
| 742 | (if cid | |
| 743 | (setf *class-id-sort* cid) | |
| 744 | (error "Panic: could not find sort ClassId")) | |
| 745 | (if msg | |
| 746 | (setf *message-sort* msg) | |
| 747 | (error "Panic: could not find sort Message")) | |
| 748 | (setf void (find-method-in ob '("*VoidObject*") nil *object-sort*)) | |
| 749 | (if void | |
| 750 | (setf *void-object* | |
| 751 | (make-applform-simple *object-sort* void)) | |
| 752 | (error "Panic: could not find void object operator.")) | |
| 753 | (setf ref (find-method-in ob | |
| 754 | '("<" "_" ":" "_" ">") | |
| 755 | (list *object-identifier-sort* | |
| 756 | *class-id-sort*) | |
| 757 | *object-sort*)) | |
| 758 | (if ref | |
| 759 | (setf *object-reference-method* ref) | |
| 760 | (error "Panic: could not find object reference method.")) | |
| 761 | (setf constr (find-method-in ob | |
| 762 | '("<" "_" ":" "_" "|" "_" ">") | |
| 763 | (list *object-identifier-sort* | |
| 764 | *class-id-sort* | |
| 765 | *attribute-list-sort*) | |
| 766 | *object-sort*)) | |
| 767 | (if constr | |
| 768 | (progn (setf *object-constructor-method* constr) | |
| 769 | (setf *object-constructor-op* | |
| 770 | (method-operator constr (module-opinfo-table ob)))) | |
| 771 | (error "Panic: could not find object constructor method.")) | |
| 772 | ) | |
| 773 | (error "Panic: could not find module OBJECT")) | |
| 777 | 774 | (if con |
| 778 | (let ((config (find-sort-in con "Configuration"))) | |
| 779 | (if config | |
| 780 | (setf *configuration-sort* config) | |
| 781 | (error "Panic: could not find sort Configuration"))) | |
| 782 | (error "Panic: could not find module STATE-CONFIGURATION")) | |
| 775 | (let ((config (find-sort-in con "Configuration"))) | |
| 776 | (if config | |
| 777 | (setf *configuration-sort* config) | |
| 778 | (error "Panic: could not find sort Configuration"))) | |
| 779 | (error "Panic: could not find module STATE-CONFIGURATION")) | |
| 783 | 780 | (if acz-con |
| 784 | (let ((acz-config (find-sort-in acz-con "ACZ-Configuration"))) | |
| 785 | (if acz-config | |
| 786 | (setf *acz-configuration-sort* acz-config) | |
| 787 | (error "Panic: could not find sort ACZ-Configuration"))) | |
| 788 | (error "Panic: could not find module ACZ-CONFIGURATION")))) | |
| 781 | (let ((acz-config (find-sort-in acz-con "ACZ-Configuration"))) | |
| 782 | (if acz-config | |
| 783 | (setf *acz-configuration-sort* acz-config) | |
| 784 | (error "Panic: could not find sort ACZ-Configuration"))) | |
| 785 | (error "Panic: could not find module ACZ-CONFIGURATION")))) | |
| 789 | 786 | |
| 790 | 787 | ;;; EOF |
| 0 | 0 | ;;;-*-Mode:LISP; Package: CHAOS; Base:10; Syntax:Common-lisp -*- |
| 1 | 1 | ;;; |
| 2 | ;;; Copyright (c) 2000-2014, Toshimi Sawada. All rights reserved. | |
| 2 | ;;; Copyright (c) 2000-2015, Toshimi Sawada. All rights reserved. | |
| 3 | 3 | ;;; |
| 4 | 4 | ;;; Redistribution and use in source and binary forms, with or without |
| 5 | 5 | ;;; modification, are permitted provided that the following conditions |
| 27 | 27 | ;;; |
| 28 | 28 | (in-package :chaos) |
| 29 | 29 | #|============================================================================= |
| 30 | System:CHAOS | |
| 31 | Module:cafein | |
| 32 | File:apply-rule.lisp | |
| 30 | System:CHAOS | |
| 31 | Module:cafein | |
| 32 | File:apply-rule.lisp | |
| 33 | 33 | =============================================================================|# |
| 34 | 34 | #-:chaos-debug |
| 35 | 35 | (declaim (optimize (speed 3) (safety 0) #-GCL (debug 0))) |
| 49 | 49 | ;;; |
| 50 | 50 | (defun apply-rule (rule term) |
| 51 | 51 | (declare (type axiom rule) |
| 52 | (type term term) | |
| 53 | (values (or null t))) | |
| 52 | (type term term) | |
| 53 | (values (or null t))) | |
| 54 | 54 | (let ((is-applied nil)) |
| 55 | 55 | (tagbody |
| 56 | 56 | (when (rule-is-rule rule) |
| 57 | (if *rewrite-exec-mode* | |
| 58 | (go do-apply) | |
| 59 | (return-from apply-rule nil))) | |
| 57 | (if *rewrite-exec-mode* | |
| 58 | (go do-apply) | |
| 59 | (return-from apply-rule nil))) | |
| 60 | 60 | ;; rule is equation |
| 61 | 61 | (when (and (not *cexec-normalize*) |
| 62 | (term-is-applform? term) | |
| 63 | (method-has-trans-rule (term-head term))) | |
| 64 | (return-from apply-rule nil)) | |
| 62 | (term-is-applform? term) | |
| 63 | (method-has-trans-rule (term-head term))) | |
| 64 | (return-from apply-rule nil)) | |
| 65 | 65 | ;;---- |
| 66 | 66 | do-apply |
| 67 | 67 | ;;---- |
| 71 | 71 | |
| 72 | 72 | ;; then there may be some extensions. |
| 73 | 73 | (when (and (not is-applied) (term-is-applform? term)) |
| 74 | (let ((top (term-method term))) | |
| 75 | (declare (type method top)) | |
| 76 | (unless (let ((val (axiom-kind rule))) | |
| 77 | (and val | |
| 78 | (not (eq :id-theorem val)) | |
| 79 | (not (eq :idem-theory val)))) | |
| 80 | (when (method-is-associative top) | |
| 81 | (if (method-is-commutative top) | |
| 82 | (setq is-applied | |
| 83 | (or (apply-AC-extension rule term top) | |
| 84 | is-applied)) | |
| 85 | ;; the operator is only associative, | |
| 86 | (setq is-applied | |
| 87 | (or (apply-A-extensions rule term top) | |
| 88 | is-applied)) | |
| 89 | ))))) | |
| 74 | (let ((top (term-method term))) | |
| 75 | (declare (type method top)) | |
| 76 | (unless (let ((val (axiom-kind rule))) | |
| 77 | (and val | |
| 78 | (not (eq :id-theorem val)) | |
| 79 | (not (eq :idem-theory val)))) | |
| 80 | (when (method-is-associative top) | |
| 81 | (if (method-is-commutative top) | |
| 82 | (setq is-applied | |
| 83 | (or (apply-AC-extension rule term top) | |
| 84 | is-applied)) | |
| 85 | ;; the operator is only associative, | |
| 86 | (setq is-applied | |
| 87 | (or (apply-A-extensions rule term top) | |
| 88 | is-applied)) | |
| 89 | ))))) | |
| 90 | 90 | ) |
| 91 | 91 | ;; return t iff the rule is applied. |
| 92 | 92 | is-applied)) |
| 103 | 103 | #-gcl |
| 104 | 104 | (defun term-replace-dd-simple (old new) |
| 105 | 105 | (declare (type term old new) |
| 106 | (values term)) | |
| 106 | (values term)) | |
| 107 | 107 | (incf *rule-count*) |
| 108 | 108 | (term-replace old new)) |
| 109 | 109 | |
| 114 | 114 | |
| 115 | 115 | (defmacro beh-context-ok? (rule) |
| 116 | 116 | ` (if *rewrite-semantic-reduce* |
| 117 | (if (axiom-is-behavioural ,rule) | |
| 118 | (check-beh-context) | |
| 119 | t) | |
| 120 | t)) | |
| 117 | (if (axiom-is-behavioural ,rule) | |
| 118 | (check-beh-context) | |
| 119 | t) | |
| 120 | t)) | |
| 121 | 121 | |
| 122 | 122 | (defun apply-one-rule-simple (rule term) |
| 123 | 123 | (declare (type axiom rule) |
| 124 | (type term term) | |
| 125 | (values (or null t))) | |
| 124 | (type term term) | |
| 125 | (values (or null t))) | |
| 126 | 126 | (declare (inline term-replace-dd-simple)) |
| 127 | 127 | ;; |
| 128 | 128 | (block the-end |
| 129 | 129 | (let* ((condition nil) |
| 130 | next-match-method | |
| 131 | (*self* term)) | |
| 130 | next-match-method | |
| 131 | (*self* term)) | |
| 132 | 132 | (multiple-value-bind (global-state subst no-match E-equal) |
| 133 | (funcall (rule-first-match-method rule) (rule-lhs rule) term) | |
| 134 | (incf $$matches) | |
| 135 | (when no-match (return-from the-end nil)) | |
| 136 | ||
| 137 | ;; | |
| 138 | (unless (beh-context-ok? rule) | |
| 139 | (return-from the-end nil)) | |
| 140 | ;; | |
| 141 | ;; technical assignation related to substitution-image. | |
| 142 | (when E-equal (setq subst nil)) | |
| 143 | ||
| 144 | ;; match success ------------------------------------- | |
| 145 | ;; then, the condition must be checked | |
| 146 | (block try-rule | |
| 147 | (catch 'rule-failure | |
| 148 | ;; | |
| 149 | (when (and (is-true? (setq condition (rule-condition rule))) | |
| 150 | (null (rule-id-condition rule))) | |
| 151 | ;; there is no condition -- | |
| 152 | ;; rewrite term. | |
| 153 | (term-replace-dd-simple | |
| 154 | term | |
| 155 | ;; note that the computation of the substitution | |
| 156 | ;; made a copy of the rhs. | |
| 157 | (substitution-image-simplifying subst | |
| 158 | (rule-rhs rule))) | |
| 159 | (return-from the-end t)))) | |
| 160 | ||
| 161 | ;; if the condition is not trivial, we enter in a loop | |
| 162 | ;; where one try to find a match such that the condition | |
| 163 | ;; is satisfied. | |
| 164 | (setf next-match-method (rule-next-match-method rule)) | |
| 165 | (loop (when no-match (return)) | |
| 166 | (unless (beh-context-ok? rule) | |
| 167 | (return-from the-end nil)) | |
| 168 | (block try-rule | |
| 169 | (catch 'rule-failure | |
| 170 | (if (and (or (null (rule-id-condition rule)) | |
| 171 | (rule-eval-id-condition subst | |
| 172 | (rule-id-condition rule))) | |
| 173 | (is-true? | |
| 174 | (let (($$cond (substitution-image subst condition)) | |
| 175 | (*rewrite-exec-mode* | |
| 176 | (if *rewrite-exec-condition* | |
| 177 | *rewrite-exec-mode* | |
| 178 | nil))) | |
| 179 | ;; no simplyfing since probably wouldn't pay | |
| 180 | (if *rewrite-semantic-reduce* | |
| 181 | (normalize-term-with-bcontext $$cond) | |
| 182 | (normalize-term $$cond)) | |
| 183 | $$cond))) | |
| 184 | ;; the condition is satisfied | |
| 185 | (progn | |
| 186 | (term-replace-dd-simple | |
| 187 | term | |
| 188 | (substitution-image-simplifying subst | |
| 189 | (rule-rhs rule))) | |
| 190 | (return-from the-end t)) | |
| 191 | nil))) | |
| 192 | ||
| 193 | ;; else, try another ... | |
| 194 | (multiple-value-setq (global-state subst no-match) | |
| 195 | (progn | |
| 196 | (incf $$matches) | |
| 197 | (funcall next-match-method global-state) | |
| 198 | )) | |
| 199 | ||
| 200 | );; end loop | |
| 201 | ||
| 202 | ;; In this case there is no match at all and the rule does not apply. | |
| 203 | (return-from the-end nil))))) | |
| 133 | (funcall (rule-first-match-method rule) (rule-lhs rule) term) | |
| 134 | (incf $$matches) | |
| 135 | (when no-match (return-from the-end nil)) | |
| 136 | ||
| 137 | ;; | |
| 138 | (unless (beh-context-ok? rule) | |
| 139 | (return-from the-end nil)) | |
| 140 | ;; | |
| 141 | ;; technical assignation related to substitution-image. | |
| 142 | (when E-equal (setq subst nil)) | |
| 143 | ||
| 144 | ;; match success ------------------------------------- | |
| 145 | ;; then, the condition must be checked | |
| 146 | (block try-rule | |
| 147 | (catch 'rule-failure | |
| 148 | ;; | |
| 149 | (when (and (is-true? (setq condition (rule-condition rule))) | |
| 150 | (null (rule-id-condition rule))) | |
| 151 | ;; there is no condition -- | |
| 152 | ;; rewrite term. | |
| 153 | (term-replace-dd-simple | |
| 154 | term | |
| 155 | ;; note that the computation of the substitution | |
| 156 | ;; made a copy of the rhs. | |
| 157 | (substitution-image-simplifying subst | |
| 158 | (rule-rhs rule))) | |
| 159 | (return-from the-end t)))) | |
| 160 | ||
| 161 | ;; if the condition is not trivial, we enter in a loop | |
| 162 | ;; where one try to find a match such that the condition | |
| 163 | ;; is satisfied. | |
| 164 | (setf next-match-method (rule-next-match-method rule)) | |
| 165 | (loop (when no-match (return)) | |
| 166 | (unless (beh-context-ok? rule) | |
| 167 | (return-from the-end nil)) | |
| 168 | (block try-rule | |
| 169 | (catch 'rule-failure | |
| 170 | (if (and (or (null (rule-id-condition rule)) | |
| 171 | (rule-eval-id-condition subst | |
| 172 | (rule-id-condition rule))) | |
| 173 | (is-true? | |
| 174 | (let (($$cond (substitution-image subst condition)) | |
| 175 | (*rewrite-exec-mode* | |
| 176 | (if *rewrite-exec-condition* | |
| 177 | *rewrite-exec-mode* | |
| 178 | nil))) | |
| 179 | ;; no simplyfing since probably wouldn't pay | |
| 180 | (if *rewrite-semantic-reduce* | |
| 181 | (normalize-term-with-bcontext $$cond) | |
| 182 | (normalize-term $$cond)) | |
| 183 | $$cond))) | |
| 184 | ;; the condition is satisfied | |
| 185 | (progn | |
| 186 | (term-replace-dd-simple | |
| 187 | term | |
| 188 | (substitution-image-simplifying subst | |
| 189 | (rule-rhs rule))) | |
| 190 | (return-from the-end t)) | |
| 191 | nil))) | |
| 192 | ||
| 193 | ;; else, try another ... | |
| 194 | (multiple-value-setq (global-state subst no-match) | |
| 195 | (progn | |
| 196 | (incf $$matches) | |
| 197 | (funcall next-match-method global-state) | |
| 198 | )) | |
| 199 | ||
| 200 | );; end loop | |
| 201 | ||
| 202 | ;; In this case there is no match at all and the rule does not apply. | |
| 203 | (return-from the-end nil))))) | |
| 204 | 204 | |
| 205 | 205 | ;;; INIT |
| 206 | 206 | (eval-when (:execute :load-toplevel) |
| 207 | 207 | (setf (symbol-function 'apply-one-rule) |
| 208 | (symbol-function 'apply-one-rule-simple))) | |
| 208 | (symbol-function 'apply-one-rule-simple))) | |
| 209 | 209 | |
| 210 | 210 | ;;; APPLY-A-EXTENSIONS : rule term method -> Bool |
| 211 | 211 | ;;;----------------------------------------------------------------------------- |
| 213 | 213 | ;;; |
| 214 | 214 | (defun apply-A-extensions (rule term top) |
| 215 | 215 | (declare (type axiom rule) |
| 216 | (type term term) | |
| 217 | (type method top) | |
| 218 | (values (or null t))) | |
| 216 | (type term term) | |
| 217 | (type method top) | |
| 218 | (values (or null t))) | |
| 219 | 219 | ;; (declare (optimize (speed 3) (safety 0))) |
| 220 | 220 | (let ((listext (!axiom-a-extensions rule)) |
| 221 | (a-ext nil) | |
| 222 | (is-applied nil)) | |
| 221 | (a-ext nil) | |
| 222 | (is-applied nil)) | |
| 223 | 223 | (when (null listext) |
| 224 | 224 | ;; then need to pre-compute the extensions and store then |
| 225 | 225 | (setq listext (compute-A-extensions rule top))) |
| 230 | 230 | (when (setq a-ext (car listext)) |
| 231 | 231 | ;; the second extension exists |
| 232 | 232 | (setq is-applied (or (apply-one-rule a-ext term) |
| 233 | is-applied))) | |
| 233 | is-applied))) | |
| 234 | 234 | (setq listext (cdr listext)) |
| 235 | 235 | (when (setq a-ext (car listext)) |
| 236 | 236 | ;; the third extension exists |
| 237 | 237 | (setq is-applied (or (apply-one-rule a-ext term) |
| 238 | is-applied))) | |
| 238 | is-applied))) | |
| 239 | 239 | ;; |
| 240 | 240 | is-applied)) |
| 241 | 241 | |
| 245 | 245 | ;;; |
| 246 | 246 | (defun apply-AC-extension (rule term top) |
| 247 | 247 | (declare (type axiom rule) |
| 248 | (type term term) | |
| 249 | (type method top) | |
| 250 | (values (or null t))) | |
| 248 | (type term term) | |
| 249 | (type method top) | |
| 250 | (values (or null t))) | |
| 251 | 251 | (let ((listext (give-AC-extension rule)) |
| 252 | (is-applied nil)) | |
| 252 | (is-applied nil)) | |
| 253 | 253 | (when (car listext) |
| 254 | 254 | ;; the extension exists |
| 255 | 255 | (setq is-applied (apply-one-rule (car listext) term))) |
| 260 | 260 | ;;; really not not want to use normalize -- perhaps could use normal expressions. |
| 261 | 261 | (defun rule-eval-id-condition (subst cond) |
| 262 | 262 | (declare (type list subst cond) |
| 263 | (values (or null t))) | |
| 263 | (values (or null t))) | |
| 264 | 264 | (cond ((eq 'and (car cond)) |
| 265 | (dolist (sc (cdr cond) t) | |
| 266 | (unless (rule-eval-id-condition subst sc) (return nil)))) | |
| 267 | ((eq 'not-equal (car cond)) | |
| 268 | (not (term-is-similar? | |
| 269 | (rule-eval-term subst (cadr cond)) | |
| 270 | (rule-eval-term subst (caddr cond))))) | |
| 271 | ((eq 'equal (car cond)) | |
| 272 | (term-is-similar? | |
| 273 | (rule-eval-term subst (cadr cond)) | |
| 274 | (rule-eval-term subst (caddr cond)))) | |
| 275 | ((eq 'or (car cond)) | |
| 276 | (dolist (sc (cdr cond) nil) | |
| 277 | (when (rule-eval-id-condition subst sc) (return t)))) | |
| 278 | ((eq 'not (car cond)) | |
| 279 | (not (rule-eval-id-condition subst (cadr cond)))) | |
| 280 | ((eq 'xor (car cond)) ;@@ remove? | |
| 281 | (let ((res nil)) | |
| 282 | (dolist (sc (cdr cond)) | |
| 283 | (setq res (if (rule-eval-id-condition subst sc) (not res) res))) | |
| 284 | res)) | |
| 285 | (t (break "rule-eval-id-condition: illegal condition")) | |
| 286 | )) | |
| 265 | (dolist (sc (cdr cond) t) | |
| 266 | (unless (rule-eval-id-condition subst sc) (return nil)))) | |
| 267 | ((eq 'not-equal (car cond)) | |
| 268 | (not (term-is-similar? | |
| 269 | (rule-eval-term subst (cadr cond)) | |
| 270 | (rule-eval-term subst (caddr cond))))) | |
| 271 | ((eq 'equal (car cond)) | |
| 272 | (term-is-similar? | |
| 273 | (rule-eval-term subst (cadr cond)) | |
| 274 | (rule-eval-term subst (caddr cond)))) | |
| 275 | ((eq 'or (car cond)) | |
| 276 | (dolist (sc (cdr cond) nil) | |
| 277 | (when (rule-eval-id-condition subst sc) (return t)))) | |
| 278 | ((eq 'not (car cond)) | |
| 279 | (not (rule-eval-id-condition subst (cadr cond)))) | |
| 280 | ((eq 'xor (car cond)) ;@@ remove? | |
| 281 | (let ((res nil)) | |
| 282 | (dolist (sc (cdr cond)) | |
| 283 | (setq res (if (rule-eval-id-condition subst sc) (not res) res))) | |
| 284 | res)) | |
| 285 | (t (break "rule-eval-id-condition: illegal condition")) | |
| 286 | )) | |
| 287 | 287 | |
| 288 | 288 | ;;; RULE-EVAL-TERM : teta term -> term' |
| 289 | 289 | ;;; |
| 290 | 290 | (defun rule-eval-term (teta term) |
| 291 | 291 | (declare (type list teta) |
| 292 | (type term term) | |
| 293 | (values list)) | |
| 292 | (type term term) | |
| 293 | (values list)) | |
| 294 | 294 | (macrolet ((assoc% (_x _y) |
| 295 | `(let ((*_lst ,_y)) | |
| 296 | (loop | |
| 297 | (when (null *_lst) (return nil)) | |
| 298 | (when (eq ,_x (caar *_lst)) (return (car *_lst))) | |
| 299 | (setq *_lst (cdr *_lst)))))) | |
| 295 | `(let ((*_lst ,_y)) | |
| 296 | (loop | |
| 297 | (when (null *_lst) (return nil)) | |
| 298 | (when (eq ,_x (caar *_lst)) (return (car *_lst))) | |
| 299 | (setq *_lst (cdr *_lst)))))) | |
| 300 | 300 | (cond ((term-is-variable? term) |
| 301 | (let ((im (cdr (assoc% term teta)))) | |
| 302 | (if im;; i.e. im = teta(term) | |
| 303 | im | |
| 304 | ;; if variable doesn't have a binding, it evaluates to itself | |
| 305 | term))) | |
| 306 | (t term)))) | |
| 301 | (let ((im (cdr (assoc% term teta)))) | |
| 302 | (if im;; i.e. im = teta(term) | |
| 303 | im | |
| 304 | ;; if variable doesn't have a binding, it evaluates to itself | |
| 305 | term))) | |
| 306 | (t term)))) | |
| 307 | 307 | |
| 308 | 308 | ;;; EOF |
| 0 | 0 | ;;;-*-Mode:LISP; Package: CHAOS; Base:10; Syntax:Common-lisp -*- |
| 1 | 1 | ;;; |
| 2 | ;;; Copyright (c) 2000-2014, Toshimi Sawada. All rights reserved. | |
| 2 | ;;; Copyright (c) 2000-2015, Toshimi Sawada. All rights reserved. | |
| 3 | 3 | ;;; |
| 4 | 4 | ;;; Redistribution and use in source and binary forms, with or without |
| 5 | 5 | ;;; modification, are permitted provided that the following conditions |
| 27 | 27 | ;;; |
| 28 | 28 | (in-package :chaos) |
| 29 | 29 | #|============================================================================= |
| 30 | System:CHAOS | |
| 31 | Module:cafein | |
| 32 | File:cafein-top.lisp | |
| 30 | System:CHAOS | |
| 31 | Module:cafein | |
| 32 | File:cafein-top.lisp | |
| 33 | 33 | =============================================================================|# |
| 34 | 34 | |
| 35 | 35 | ;;;============================================================================= |
| 36 | ;;; CafeIn Termrewriting system top-level | |
| 36 | ;;; CafeIn Termrewriting system top-level | |
| 37 | 37 | ;;;============================================================================= |
| 38 | 38 | |
| 39 | 39 | ;;; CafeIn COMMANDS |
| 40 | 40 | (defvar *cafein-commands* nil) |
| 41 | 41 | (eval-when (:execute :load-toplevel) |
| 42 | 42 | (setq *cafein-commands* |
| 43 | '((top-commands | |
| 44 | (:one-of | |
| 45 | ((:+ match unify) (:seq-of :term) to (:seq-of :term) |.|) | |
| 46 | (parse (:if-present in :modexp |:|) (:seq-of :term) |.|) | |
| 47 | ((:+ lisp ev eval evq lispq) | |
| 48 | (:call (read))) | |
| 49 | ((:+ show sh set select describe desc) ; do | |
| 50 | (:seq-of :top-opname)) | |
| 51 | (#\^D) | |
| 52 | (eof) | |
| 53 | ((:+ quit q)) | |
| 54 | ;; theorem proving stuff. | |
| 55 | (start :term |.|) | |
| 56 | ;; apply | |
| 57 | (apply (:one-of-default | |
| 58 | (:symbol (:upto | |
| 59 | (within at) | |
| 60 | (:optional with :symbol | |
| 61 | = (:upto (|,| within at) :term) | |
| 62 | :append | |
| 63 | (:seq-of |,| :symbol | |
| 64 | = (:upto (|,| within at) :term)))) | |
| 65 | (:+ within at) | |
| 66 | (:one-of | |
| 67 | ((:+ top term subterm)) | |
| 68 | ((:+ |(| |{| |[|) | |
| 69 | :unread | |
| 70 | ((:! Selector)) | |
| 71 | (:seq-of of ((:! Selector))) | |
| 72 | |.|))) | |
| 73 | (?))) | |
| 74 | ;; | |
| 75 | (choose (:one-of | |
| 76 | ((:+ top term subterm)) | |
| 77 | ((:+ |(| |{| |[|) | |
| 78 | :unread | |
| 79 | ((:! Selector)) | |
| 80 | (:seq-of of ((:! Selector))) | |
| 81 | |.|))) | |
| 43 | '((top-commands | |
| 44 | (:one-of | |
| 45 | ((:+ match unify) (:seq-of :term) to (:seq-of :term) |.|) | |
| 46 | (parse (:if-present in :modexp |:|) (:seq-of :term) |.|) | |
| 47 | ((:+ lisp ev eval evq lispq) | |
| 48 | (:call (read))) | |
| 49 | ((:+ show sh set select describe desc) ; do | |
| 50 | (:seq-of :top-opname)) | |
| 51 | (#\^D) | |
| 52 | (eof) | |
| 53 | ((:+ quit q)) | |
| 54 | ;; theorem proving stuff. | |
| 55 | (start :term |.|) | |
| 56 | ;; apply | |
| 57 | (apply (:one-of-default | |
| 58 | (:symbol (:upto | |
| 59 | (within at) | |
| 60 | (:optional with :symbol | |
| 61 | = (:upto (|,| within at) :term) | |
| 62 | :append | |
| 63 | (:seq-of |,| :symbol | |
| 64 | = (:upto (|,| within at) :term)))) | |
| 65 | (:+ within at) | |
| 66 | (:one-of | |
| 67 | ((:+ top term subterm)) | |
| 68 | ((:+ |(| |{| |[|) | |
| 69 | :unread | |
| 70 | ((:! Selector)) | |
| 71 | (:seq-of of ((:! Selector))) | |
| 72 | |.|))) | |
| 73 | (?))) | |
| 74 | ;; | |
| 75 | (choose (:one-of | |
| 76 | ((:+ top term subterm)) | |
| 77 | ((:+ |(| |{| |[|) | |
| 78 | :unread | |
| 79 | ((:! Selector)) | |
| 80 | (:seq-of of ((:! Selector))) | |
| 81 | |.|))) | |
| 82 | 82 | |
| 83 | (find (:+ rule -rule +rule rules -rules +rules)) | |
| 84 | (cd :symbol) | |
| 85 | #-(or GCL LUCID CMU) (ls :symbol) | |
| 86 | #+(or GCL LUCID CMU) (ls :top-term) | |
| 87 | (pwd) | |
| 88 | (! :top-term) | |
| 89 | (?) | |
| 90 | )) | |
| 91 | (Selector | |
| 92 | (:one-of | |
| 93 | ;; (term) (top) (subterm) | |
| 94 | (|{| :int :append (:seq-of |,| :int) |}|) | |
| 95 | (|(| (:seq-of :int) |)|) | |
| 96 | (\[ :int (:optional |..| :int) \]))) | |
| 97 | ))) | |
| 83 | (find (:+ rule -rule +rule rules -rules +rules)) | |
| 84 | (cd :symbol) | |
| 85 | #-(or GCL LUCID CMU) (ls :symbol) | |
| 86 | #+(or GCL LUCID CMU) (ls :top-term) | |
| 87 | (pwd) | |
| 88 | (! :top-term) | |
| 89 | (?) | |
| 90 | )) | |
| 91 | (Selector | |
| 92 | (:one-of | |
| 93 | ;; (term) (top) (subterm) | |
| 94 | (|{| :int :append (:seq-of |,| :int) |}|) | |
| 95 | (|(| (:seq-of :int) |)|) | |
| 96 | (\[ :int (:optional |..| :int) \]))) | |
| 97 | ))) | |
| 98 | 98 | |
| 99 | 99 | (defun cafein-parse () |
| 100 | 100 | (reader 'top-commands *cafein-commands*)) |
| 0 | 0 | ;;;-*- Mode:LISP; Package: CHAOS; Base:10; Syntax:Common-lisp -*- |
| 1 | 1 | ;;; |
| 2 | ;;; Copyright (c) 2000-2014, Toshimi Sawada. All rights reserved. | |
| 2 | ;;; Copyright (c) 2000-2015, Toshimi Sawada. All rights reserved. | |
| 3 | 3 | ;;; |
| 4 | 4 | ;;; Redistribution and use in source and binary forms, with or without |
| 5 | 5 | ;;; modification, are permitted provided that the following conditions |
| 27 | 27 | ;;; |
| 28 | 28 | (in-package :chaos) |
| 29 | 29 | #|============================================================================= |
| 30 | System:CHAOS | |
| 31 | Module:cafein | |
| 32 | File:cbred.lisp | |
| 30 | System:CHAOS | |
| 31 | Module:cafein | |
| 32 | File:cbred.lisp | |
| 33 | 33 | =============================================================================|# |
| 34 | 34 | #-:chaos-debug |
| 35 | 35 | (declaim (optimize (speed 3) (safety 1) #-GCL (debug 0))) |
| 42 | 42 | |
| 43 | 43 | ;;; GLOBALS |
| 44 | 44 | (declaim (special *cobasis* |
| 45 | *cobasis-ops* | |
| 46 | *co-rules*)) | |
| 45 | *cobasis-ops* | |
| 46 | *co-rules*)) | |
| 47 | 47 | (defvar *cobasis* nil) |
| 48 | 48 | (defvar *cobasis-ops* nil) |
| 49 | 49 | (defvar *co-rules* nil) |
| 53 | 53 | |
| 54 | 54 | (defun make-cobasis-pattern (op) |
| 55 | 55 | (let ((hidden-vars nil) |
| 56 | (pattern nil)) | |
| 56 | (pattern nil)) | |
| 57 | 57 | (setq pattern |
| 58 | 58 | (make-term-with-sort-check |
| 59 | 59 | op |
| 60 | 60 | (mapcar #'(lambda (s) |
| 61 | (if (sort-is-hidden s) | |
| 62 | (let ((hvar (make-variable-term s | |
| 63 | (gensym "_H")))) | |
| 64 | (push hvar hidden-vars) | |
| 65 | hvar) | |
| 66 | (make-variable-term s | |
| 67 | (gensym "_V")))) | |
| 68 | (method-arity op)))) | |
| 61 | (if (sort-is-hidden s) | |
| 62 | (let ((hvar (make-variable-term s | |
| 63 | (gensym "_H")))) | |
| 64 | (push hvar hidden-vars) | |
| 65 | hvar) | |
| 66 | (make-variable-term s | |
| 67 | (gensym "_V")))) | |
| 68 | (method-arity op)))) | |
| 69 | 69 | (cons (nreverse hidden-vars) pattern) |
| 70 | 70 | )) |
| 71 | 71 | |
| 75 | 75 | (defun cbred-make-new-variable (var) |
| 76 | 76 | (let ((vnam (incf varnum))) |
| 77 | 77 | (if .cbred-new-variable-name. |
| 78 | (make-variable-term (variable-sort var) | |
| 79 | vnam | |
| 80 | vnam) | |
| 78 | (make-variable-term (variable-sort var) | |
| 79 | vnam | |
| 80 | vnam) | |
| 81 | 81 | (make-variable-term (variable-sort var) |
| 82 | vnam | |
| 83 | (variable-print-name var)) | |
| 82 | vnam | |
| 83 | (variable-print-name var)) | |
| 84 | 84 | ))) |
| 85 | 85 | ) |
| 86 | 86 | |
| 87 | 87 | (defun expand-goal-by-cob (pair cob) |
| 88 | 88 | (flet ((expand (term cob) |
| 89 | (let ((subst-vars (car cob)) | |
| 90 | (subst-pat (cdr cob)) | |
| 91 | (subst nil)) | |
| 92 | (dolist (v subst-vars) | |
| 93 | (when (sort<= (term-sort term) (term-sort v)) | |
| 94 | (push (cons v term) subst))) | |
| 95 | (apply-subst subst subst-pat)))) | |
| 89 | (let ((subst-vars (car cob)) | |
| 90 | (subst-pat (cdr cob)) | |
| 91 | (subst nil)) | |
| 92 | (dolist (v subst-vars) | |
| 93 | (when (sort<= (term-sort term) (term-sort v)) | |
| 94 | (push (cons v term) subst))) | |
| 95 | (apply-subst subst subst-pat)))) | |
| 96 | 96 | (let ((lhs (expand (car pair) cob)) |
| 97 | (rhs (expand (cdr pair) cob))) | |
| 97 | (rhs (expand (cdr pair) cob))) | |
| 98 | 98 | (let ((vars (append (term-variables lhs) |
| 99 | (term-variables rhs))) | |
| 100 | (subst nil)) | |
| 101 | (setq vars (delete-duplicates vars)) | |
| 102 | (dolist (v vars) | |
| 103 | (push (cons v (cbred-make-new-variable v)) | |
| 104 | subst)) | |
| 105 | (setq lhs (apply-subst subst lhs)) | |
| 106 | (setq rhs (apply-subst subst rhs)) | |
| 107 | (cons lhs rhs))) | |
| 99 | (term-variables rhs))) | |
| 100 | (subst nil)) | |
| 101 | (setq vars (delete-duplicates vars)) | |
| 102 | (dolist (v vars) | |
| 103 | (push (cons v (cbred-make-new-variable v)) | |
| 104 | subst)) | |
| 105 | (setq lhs (apply-subst subst lhs)) | |
| 106 | (setq rhs (apply-subst subst rhs)) | |
| 107 | (cons lhs rhs))) | |
| 108 | 108 | )) |
| 109 | 109 | |
| 110 | 110 | ;;; *CO-RULES* ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ |
| 112 | 112 | (defun apply-co-rules (target) |
| 113 | 113 | (let ((applied nil)) |
| 114 | 114 | (labels ((apply-it (term) |
| 115 | (when (term-is-applform? term) | |
| 116 | (unless (memq (term-head term) *cobasis-ops*) | |
| 117 | (dolist (sub (term-subterms term)) | |
| 118 | (apply-it sub))) | |
| 119 | (dolist (rule *co-rules*) | |
| 120 | #|| | |
| 121 | (format t "~%co-rule: ") | |
| 122 | (print-rule-internal rule) | |
| 123 | (format t "~%target: ") | |
| 124 | (term-print term) | |
| 125 | ||# | |
| 126 | (if (apply-one-rule rule term) | |
| 127 | (pushnew (car (rule-labels rule)) applied))) | |
| 128 | ))) | |
| 115 | (when (term-is-applform? term) | |
| 116 | (unless (memq (term-head term) *cobasis-ops*) | |
| 117 | (dolist (sub (term-subterms term)) | |
| 118 | (apply-it sub))) | |
| 119 | (dolist (rule *co-rules*) | |
| 120 | #|| | |
| 121 | (format t "~%co-rule: ") | |
| 122 | (print-rule-internal rule) | |
| 123 | (format t "~%target: ") | |
| 124 | (term-print term) | |
| 125 | ||# | |
| 126 | (if (apply-one-rule rule term) | |
| 127 | (pushnew (car (rule-labels rule)) applied))) | |
| 128 | ))) | |
| 129 | 129 | (apply-it (car target)) |
| 130 | 130 | (apply-it (cdr target)) |
| 131 | 131 | |
| 132 | 132 | (when applied |
| 133 | (rewrite* (car target)) | |
| 134 | (rewrite* (cdr target))) | |
| 133 | (rewrite* (car target)) | |
| 134 | (rewrite* (cdr target))) | |
| 135 | 135 | |
| 136 | 136 | (if (term-equational-equal (car target) |
| 137 | (cdr target)) | |
| 138 | (values t (nreverse applied)) | |
| 139 | (values nil (nreverse applied))) | |
| 137 | (cdr target)) | |
| 138 | (values t (nreverse applied)) | |
| 139 | (values nil (nreverse applied))) | |
| 140 | 140 | ))) |
| 141 | 141 | |
| 142 | 142 | ;;; ------------------------------- |
| 146 | 146 | (defun cbred-print-term-pair (pair &optional (stream *standard-output*)) |
| 147 | 147 | (let ((*standard-output* stream)) |
| 148 | 148 | (let* ((.file-col. (file-column stream)) |
| 149 | (*print-indent* (if (= 0 .file-col.) | |
| 150 | (+ 4 *print-indent*) | |
| 151 | .file-col.)) | |
| 152 | (.printed-vars-so-far. nil)) | |
| 149 | (*print-indent* (if (= 0 .file-col.) | |
| 150 | (+ 4 *print-indent*) | |
| 151 | .file-col.)) | |
| 152 | (.printed-vars-so-far. nil)) | |
| 153 | 153 | (setq .printed-vars-so-far. |
| 154 | (term-print (car pair))) | |
| 154 | (term-print (car pair))) | |
| 155 | 155 | (setq .file-col. (file-column stream)) |
| 156 | 156 | (if (print-check 0 .file-col.) |
| 157 | (princ "== ") | |
| 158 | (princ " == ")) | |
| 157 | (princ "== ") | |
| 158 | (princ " == ")) | |
| 159 | 159 | (setq .file-col. (file-column stream)) |
| 160 | 160 | (if (not (= 0 .file-col.)) |
| 161 | (setq *print-indent* .file-col.)) | |
| 161 | (setq *print-indent* .file-col.)) | |
| 162 | 162 | (term-print (cdr pair)) |
| 163 | 163 | ))) |
| 164 | 164 | |
| 172 | 172 | (defun cbred-goal (pair) |
| 173 | 173 | (let ((rule-count *rule-count*)) |
| 174 | 174 | (let ((lhs (rewrite* (car pair))) |
| 175 | (rhs (rewrite* (cdr pair)))) | |
| 175 | (rhs (rewrite* (cdr pair)))) | |
| 176 | 176 | (if (term-equational-equal lhs rhs) |
| 177 | (values t lhs) | |
| 178 | (values nil (not (= rule-count *rule-count*))) | |
| 177 | (values t lhs) | |
| 178 | (values nil (not (= rule-count *rule-count*))) | |
| 179 | 179 | )))) |
| 180 | 180 | |
| 181 | 181 | ;;; |
| 184 | 184 | (return-from find-occ (values occr num-if))) |
| 185 | 185 | ;; |
| 186 | 186 | (if (and (term-is-applform? term) |
| 187 | (eq (term-head term) *bool-if*)) | |
| 187 | (eq (term-head term) *bool-if*)) | |
| 188 | 188 | (multiple-value-bind (occr1 num-if-1) |
| 189 | (find-occ (term-arg-2 term) predicate occr (1+ num-if)) | |
| 190 | (multiple-value-bind (occr2 num-if-2) | |
| 191 | (find-occ (term-arg-3 term) predicate occr (1+ num-if)) | |
| 192 | (if (listp occr1) | |
| 193 | (if (listp occr2) | |
| 194 | (if (<= (length occr1) (length occr2)) | |
| 195 | (values occr2 num-if-2) | |
| 196 | (values occr1 num-if-1)) | |
| 197 | (values occr1 num-if-1)) | |
| 198 | (if (listp occr2) | |
| 199 | (values occr2 num-if-2) | |
| 200 | (values :no (1+ num-if)))))) | |
| 189 | (find-occ (term-arg-2 term) predicate occr (1+ num-if)) | |
| 190 | (multiple-value-bind (occr2 num-if-2) | |
| 191 | (find-occ (term-arg-3 term) predicate occr (1+ num-if)) | |
| 192 | (if (listp occr1) | |
| 193 | (if (listp occr2) | |
| 194 | (if (<= (length occr1) (length occr2)) | |
| 195 | (values occr2 num-if-2) | |
| 196 | (values occr1 num-if-1)) | |
| 197 | (values occr1 num-if-1)) | |
| 198 | (if (listp occr2) | |
| 199 | (values occr2 num-if-2) | |
| 200 | (values :no (1+ num-if)))))) | |
| 201 | 201 | (if (not (term-is-applform? term)) |
| 202 | (values :no num-if) | |
| 202 | (values :no num-if) | |
| 203 | 203 | (progn |
| 204 | (dotimes (x (length (term-subterms term))) | |
| 205 | (multiple-value-bind (res new-num-if) | |
| 206 | (find-occ (term-arg-n term x) | |
| 207 | predicate | |
| 208 | (cons x occr) | |
| 209 | num-if) | |
| 210 | (if (listp res) | |
| 211 | (return-from find-occ (values res new-num-if))))) | |
| 212 | (values :no num-if)) | |
| 204 | (dotimes (x (length (term-subterms term))) | |
| 205 | (multiple-value-bind (res new-num-if) | |
| 206 | (find-occ (term-arg-n term x) | |
| 207 | predicate | |
| 208 | (cons x occr) | |
| 209 | num-if) | |
| 210 | (if (listp res) | |
| 211 | (return-from find-occ (values res new-num-if))))) | |
| 212 | (values :no num-if)) | |
| 213 | 213 | ))) |
| 214 | 214 | |
| 215 | 215 | #|| |
| 216 | 216 | (defun cbred-orient-rule (pair) |
| 217 | 217 | (let ((lhs (car pair)) |
| 218 | (rhs (cdr pair))) | |
| 218 | (rhs (cdr pair))) | |
| 219 | 219 | (return-from cbred-orient-rule (values lhs rhs)) |
| 220 | 220 | (let ((occ (find-occ lhs #'(lambda (x) |
| 221 | (and (sort-is-hidden (term-sort x)) | |
| 222 | (not (memq (term-head x) | |
| 223 | *cobasis-ops*)))) | |
| 224 | nil))) | |
| 221 | (and (sort-is-hidden (term-sort x)) | |
| 222 | (not (memq (term-head x) | |
| 223 | *cobasis-ops*)))) | |
| 224 | nil))) | |
| 225 | 225 | (unless (listp occ) (return-from cbred-orient-rule nil)) |
| 226 | 226 | (let ((context lhs) |
| 227 | (head nil)) | |
| 228 | (dolist (c (reverse occ)) | |
| 229 | (setq context (term-arg-n context c))) | |
| 230 | (setq head (term-head context)) | |
| 231 | (let ((rocc (find-occ rhs #'(lambda (x) | |
| 232 | (and (term-is-applform? x) | |
| 233 | (method-is-of-same-operator | |
| 234 | head | |
| 235 | (term-head x)))) | |
| 236 | nil))) | |
| 237 | (if (or (not (listp rocc)) | |
| 238 | (>= (length occ) (length rocc))) | |
| 239 | (values lhs rhs) | |
| 240 | (values rhs lhs)) | |
| 241 | )) | |
| 227 | (head nil)) | |
| 228 | (dolist (c (reverse occ)) | |
| 229 | (setq context (term-arg-n context c))) | |
| 230 | (setq head (term-head context)) | |
| 231 | (let ((rocc (find-occ rhs #'(lambda (x) | |
| 232 | (and (term-is-applform? x) | |
| 233 | (method-is-of-same-operator | |
| 234 | head | |
| 235 | (term-head x)))) | |
| 236 | nil))) | |
| 237 | (if (or (not (listp rocc)) | |
| 238 | (>= (length occ) (length rocc))) | |
| 239 | (values lhs rhs) | |
| 240 | (values rhs lhs)) | |
| 241 | )) | |
| 242 | 242 | ))) |
| 243 | 243 | ||# |
| 244 | 244 | |
| 246 | 246 | (defun cbred-orient-rule (pair) |
| 247 | 247 | (if (featurep :bigpink) |
| 248 | 248 | (pn-orient-term-pair *current-module* |
| 249 | pair) | |
| 249 | pair) | |
| 250 | 250 | (values (car pair) (cdr pair)))) |
| 251 | 251 | |
| 252 | 252 | #-:allegro |
| 258 | 258 | (cbred-orient-rule pair) |
| 259 | 259 | (unless lhs |
| 260 | 260 | (with-output-panic-message () |
| 261 | (let ((.printed-vars-so-far. nil)) | |
| 262 | (princ "could not find any hidden context.") | |
| 263 | (print-next) | |
| 264 | (princ "this should not happen") | |
| 265 | (print-next) | |
| 266 | (setq .printed-vars-so-far. (term-print (car pair))) | |
| 267 | (print-next) | |
| 268 | (term-print (cdr pair))))) | |
| 261 | (let ((.printed-vars-so-far. nil)) | |
| 262 | (princ "could not find any hidden context.") | |
| 263 | (print-next) | |
| 264 | (princ "this should not happen") | |
| 265 | (print-next) | |
| 266 | (setq .printed-vars-so-far. (term-print (car pair))) | |
| 267 | (print-next) | |
| 268 | (term-print (cdr pair))))) | |
| 269 | 269 | (let ((new-crule (make-rule :lhs lhs |
| 270 | :rhs rhs | |
| 271 | :condition *bool-true* | |
| 272 | :labels (list (next-crule-label)) | |
| 273 | :behavioural t | |
| 274 | :type :cbred-circle))) | |
| 270 | :rhs rhs | |
| 271 | :condition *bool-true* | |
| 272 | :labels (list (next-crule-label)) | |
| 273 | :behavioural t | |
| 274 | :type :cbred-circle))) | |
| 275 | 275 | |
| 276 | 276 | (setq *co-rules* |
| 277 | (nconc *co-rules* (list new-crule))) | |
| 277 | (nconc *co-rules* (list new-crule))) | |
| 278 | 278 | ;; (push new-crule *co-rules*) |
| 279 | 279 | (when *cbred-trace-flag* |
| 280 | (with-output-simple-msg () | |
| 281 | (princ " add rule: ") | |
| 282 | (print-rule-internal new-crule))) | |
| 280 | (with-output-simple-msg () | |
| 281 | (princ " add rule: ") | |
| 282 | (print-rule-internal new-crule))) | |
| 283 | 283 | ))) |
| 284 | 284 | |
| 285 | 285 | (defun term-contains-beh-context (term) |
| 286 | 286 | (or (sort-is-hidden (term-sort term)) |
| 287 | 287 | (and (term-is-applform? term) |
| 288 | (some #'(lambda (x) (term-contains-beh-context x)) | |
| 289 | (term-subterms term))))) | |
| 288 | (some #'(lambda (x) (term-contains-beh-context x)) | |
| 289 | (term-subterms term))))) | |
| 290 | 290 | |
| 291 | 291 | (defun cbred-deduce (pair) |
| 292 | 292 | (let ((next-goals nil)) |
| 293 | 293 | (dolist (cob *cobasis*) |
| 294 | 294 | (block next |
| 295 | (let ((target (expand-goal-by-cob pair cob))) | |
| 296 | (when *cbred-trace-flag* | |
| 297 | (with-output-simple-msg () | |
| 298 | (let ((.printed-vars-so-far. nil)) | |
| 299 | (princ "---------------------------------------") | |
| 300 | (print-next) | |
| 301 | (princ "Target: ") | |
| 302 | (cbred-print-term-pair target)))) | |
| 303 | (multiple-value-bind (ok? reduced) | |
| 304 | (cbred-goal target) | |
| 305 | (when ok? | |
| 306 | (when *cbred-trace-flag* | |
| 307 | (with-output-simple-msg () | |
| 308 | (princ " reduced: true") | |
| 309 | (print-next) | |
| 310 | (princ "nf: ") | |
| 311 | (term-print reduced))) | |
| 312 | (return-from next nil)) | |
| 313 | (when reduced | |
| 314 | (when *cbred-trace-flag* | |
| 315 | (let ((.printed-vars-so-far. nil)) | |
| 316 | (with-output-simple-msg () | |
| 317 | (princ " reduced: ") | |
| 318 | (cbred-print-term-pair target))))) | |
| 319 | ;; try deduce with *co-rules* | |
| 320 | (multiple-value-bind (ok? applied) | |
| 321 | (apply-co-rules target) | |
| 322 | (when ok? | |
| 323 | (when *cbred-trace-flag* | |
| 324 | (with-output-simple-msg () | |
| 325 | (format t " deduced~a: true" applied) | |
| 326 | (print-next) | |
| 327 | (princ "nf: ") | |
| 328 | (term-print (car target)))) | |
| 329 | (return-from next nil)) | |
| 330 | ;; | |
| 331 | #|| | |
| 332 | (when (and (not (term-contains-beh-context (car target))) | |
| 333 | (not (term-contains-beh-context (cdr target)))) | |
| 334 | ;; failure | |
| 335 | (throw ':fail nil)) | |
| 336 | ||# | |
| 337 | (when (or (not (sort-is-hidden (term-sort (car target)))) | |
| 338 | (and (memq (term-head (car target)) *cobasis-ops*) | |
| 339 | (memq (term-head (cdr target)) *cobasis-ops*))) | |
| 340 | (throw ':fail nil)) | |
| 341 | ;; ng | |
| 342 | (when applied | |
| 343 | (when *cbred-trace-flag* | |
| 344 | (let ((.printed-vars-so-far. nil)) | |
| 345 | (with-output-simple-msg () | |
| 346 | (format t " deduced~a: " applied) | |
| 347 | (cbred-print-term-pair target))))) | |
| 348 | ;; | |
| 349 | (unless (or reduced applied) | |
| 350 | (when *cbred-trace-flag* | |
| 351 | (with-output-chaos-warning () | |
| 352 | (princ "!! no rules were applied.") | |
| 353 | (print-next))) | |
| 354 | (throw ':fail nil)) | |
| 355 | (add-new-crule target) | |
| 356 | (push target next-goals))) | |
| 357 | ))) | |
| 295 | (let ((target (expand-goal-by-cob pair cob))) | |
| 296 | (when *cbred-trace-flag* | |
| 297 | (with-output-simple-msg () | |
| 298 | (let ((.printed-vars-so-far. nil)) | |
| 299 | (princ "---------------------------------------") | |
| 300 | (print-next) | |
| 301 | (princ "Target: ") | |
| 302 | (cbred-print-term-pair target)))) | |
| 303 | (multiple-value-bind (ok? reduced) | |
| 304 | (cbred-goal target) | |
| 305 | (when ok? | |
| 306 | (when *cbred-trace-flag* | |
| 307 | (with-output-simple-msg () | |
| 308 | (princ " reduced: true") | |
| 309 | (print-next) | |
| 310 | (princ "nf: ") | |
| 311 | (term-print reduced))) | |
| 312 | (return-from next nil)) | |
| 313 | (when reduced | |
| 314 | (when *cbred-trace-flag* | |
| 315 | (let ((.printed-vars-so-far. nil)) | |
| 316 | (with-output-simple-msg () | |
| 317 | (princ " reduced: ") | |
| 318 | (cbred-print-term-pair target))))) | |
| 319 | ;; try deduce with *co-rules* | |
| 320 | (multiple-value-bind (ok? applied) | |
| 321 | (apply-co-rules target) | |
| 322 | (when ok? | |
| 323 | (when *cbred-trace-flag* | |
| 324 | (with-output-simple-msg () | |
| 325 | (format t " deduced~a: true" applied) | |
| 326 | (print-next) | |
| 327 | (princ "nf: ") | |
| 328 | (term-print (car target)))) | |
| 329 | (return-from next nil)) | |
| 330 | ;; | |
| 331 | #|| | |
| 332 | (when (and (not (term-contains-beh-context (car target))) | |
| 333 | (not (term-contains-beh-context (cdr target)))) | |
| 334 | ;; failure | |
| 335 | (throw ':fail nil)) | |
| 336 | ||# | |
| 337 | (when (or (not (sort-is-hidden (term-sort (car target)))) | |
| 338 | (and (memq (term-head (car target)) *cobasis-ops*) | |
| 339 | (memq (term-head (cdr target)) *cobasis-ops*))) | |
| 340 | (throw ':fail nil)) | |
| 341 | ;; ng | |
| 342 | (when applied | |
| 343 | (when *cbred-trace-flag* | |
| 344 | (let ((.printed-vars-so-far. nil)) | |
| 345 | (with-output-simple-msg () | |
| 346 | (format t " deduced~a: " applied) | |
| 347 | (cbred-print-term-pair target))))) | |
| 348 | ;; | |
| 349 | (unless (or reduced applied) | |
| 350 | (when *cbred-trace-flag* | |
| 351 | (with-output-chaos-warning () | |
| 352 | (princ "!! no rules were applied.") | |
| 353 | (print-next))) | |
| 354 | (throw ':fail nil)) | |
| 355 | (add-new-crule target) | |
| 356 | (push target next-goals))) | |
| 357 | ))) | |
| 358 | 358 | ;; done |
| 359 | 359 | next-goals |
| 360 | 360 | )) |
| 365 | 365 | (with-in-module (module) |
| 366 | 366 | (reset-crule-label) |
| 367 | 367 | (let ((lhs-sort (term-sort lhs)) |
| 368 | (rhs-sort (term-sort rhs)) | |
| 369 | (sort nil) | |
| 370 | (**print-var-sort** nil)) | |
| 368 | (rhs-sort (term-sort rhs)) | |
| 369 | (sort nil) | |
| 370 | (**print-var-sort** nil)) | |
| 371 | 371 | #|| |
| 372 | 372 | (unless (and (sort-is-hidden lhs-sort) |
| 373 | (sort-is-hidden rhs-sort)) | |
| 374 | (with-output-chaos-error ('invalid-sort) | |
| 375 | (princ "cbred: terms must be of hidden sort."))) | |
| 373 | (sort-is-hidden rhs-sort)) | |
| 374 | (with-output-chaos-error ('invalid-sort) | |
| 375 | (princ "cbred: terms must be of hidden sort."))) | |
| 376 | 376 | ||# |
| 377 | 377 | (if (sort<= lhs-sort rhs-sort) |
| 378 | (setq sort rhs-sort) | |
| 379 | (if (sort< rhs-sort lhs-sort) | |
| 380 | (setq sort lhs-sort) | |
| 381 | (with-output-chaos-error ('invalid-terms) | |
| 382 | (princ "cbred: pair of terms must of same sort family.")))) | |
| 378 | (setq sort rhs-sort) | |
| 379 | (if (sort< rhs-sort lhs-sort) | |
| 380 | (setq sort lhs-sort) | |
| 381 | (with-output-chaos-error ('invalid-terms) | |
| 382 | (princ "cbred: pair of terms must of same sort family.")))) | |
| 383 | 383 | ;; |
| 384 | 384 | (let ((goals (list (cons lhs rhs))) |
| 385 | (*co-rules* nil) | |
| 386 | (*cobasis* nil) | |
| 387 | (*cobasis-ops* nil) | |
| 388 | (*cbred-trace-flag* $$trace-rewrite) | |
| 389 | (ok? nil)) | |
| 390 | (declare (special *cbred-trace-flag*) | |
| 391 | (special *co-rules* *cobasis* *cobasis-ops*)) | |
| 392 | ;; use own tracer | |
| 393 | (when *cbred-trace-flag* | |
| 394 | (trace-off)) | |
| 395 | (dolist (cob (module-cobasis *current-module*)) | |
| 396 | (when (some #'(lambda (s) (sort<= sort s)) | |
| 397 | (method-arity cob)) | |
| 398 | (push (make-cobasis-pattern cob) *cobasis*) | |
| 399 | (push cob *cobasis-ops*))) | |
| 400 | (setq *cobasis* (nreverse *cobasis*)) | |
| 401 | (setq *cobasis-ops* (nreverse *cobasis-ops*)) | |
| 402 | ;; | |
| 403 | (when *cbred-trace-flag* | |
| 404 | (with-output-simple-msg () | |
| 405 | (princ "** Cobasis:") | |
| 406 | (dolist (op *cobasis-ops*) | |
| 407 | (print-next) | |
| 408 | (print-chaos-object op)) | |
| 409 | (print-next) | |
| 410 | (princ "-------------------------------------") | |
| 411 | )) | |
| 412 | ;; | |
| 413 | (multiple-value-bind (ok? reduced) | |
| 414 | (cbred-goal (car goals)) | |
| 415 | (declare (ignore reduced)) | |
| 416 | (when *cbred-trace-flag* | |
| 417 | (let ((.printed-vars-so-far. nil)) | |
| 418 | (with-output-simple-msg () | |
| 419 | (princ " reduced to: ") | |
| 420 | (cbred-print-term-pair (car goals))))) | |
| 421 | (when ok? | |
| 422 | (when *cbred-trace-flag* | |
| 423 | (trace-on)) | |
| 424 | (return-from do-cbred t))) | |
| 425 | ;; | |
| 426 | (add-new-crule (car goals)) | |
| 427 | ;; | |
| 428 | ;; do the real work | |
| 429 | ;; | |
| 430 | (setq ok? | |
| 431 | (catch ':fail | |
| 432 | (loop | |
| 433 | (unless goals (return t)) | |
| 434 | (let ((new-goals nil)) | |
| 435 | (dolist (pair goals) | |
| 436 | (setq new-goals | |
| 437 | (nconc new-goals | |
| 438 | (cbred-deduce pair)))) | |
| 439 | (setq goals new-goals)) | |
| 440 | ))) | |
| 441 | (when *cbred-trace-flag* | |
| 442 | (trace-on)) | |
| 443 | (values ok? goals) | |
| 444 | ) | |
| 385 | (*co-rules* nil) | |
| 386 | (*cobasis* nil) | |
| 387 | (*cobasis-ops* nil) | |
| 388 | (*cbred-trace-flag* $$trace-rewrite) | |
| 389 | (ok? nil)) | |
| 390 | (declare (special *cbred-trace-flag*) | |
| 391 | (special *co-rules* *cobasis* *cobasis-ops*)) | |
| 392 | ;; use own tracer | |
| 393 | (when *cbred-trace-flag* | |
| 394 | (trace-off)) | |
| 395 | (dolist (cob (module-cobasis *current-module*)) | |
| 396 | (when (some #'(lambda (s) (sort<= sort s)) | |
| 397 | (method-arity cob)) | |
| 398 | (push (make-cobasis-pattern cob) *cobasis*) | |
| 399 | (push cob *cobasis-ops*))) | |
| 400 | (setq *cobasis* (nreverse *cobasis*)) | |
| 401 | (setq *cobasis-ops* (nreverse *cobasis-ops*)) | |
| 402 | ;; | |
| 403 | (when *cbred-trace-flag* | |
| 404 | (with-output-simple-msg () | |
| 405 | (princ "** Cobasis:") | |
| 406 | (dolist (op *cobasis-ops*) | |
| 407 | (print-next) | |
| 408 | (print-chaos-object op)) | |
| 409 | (print-next) | |
| 410 | (princ "-------------------------------------") | |
| 411 | )) | |
| 412 | ;; | |
| 413 | (multiple-value-bind (ok? reduced) | |
| 414 | (cbred-goal (car goals)) | |
| 415 | (declare (ignore reduced)) | |
| 416 | (when *cbred-trace-flag* | |
| 417 | (let ((.printed-vars-so-far. nil)) | |
| 418 | (with-output-simple-msg () | |
| 419 | (princ " reduced to: ") | |
| 420 | (cbred-print-term-pair (car goals))))) | |
| 421 | (when ok? | |
| 422 | (when *cbred-trace-flag* | |
| 423 | (trace-on)) | |
| 424 | (return-from do-cbred t))) | |
| 425 | ;; | |
| 426 | (add-new-crule (car goals)) | |
| 427 | ;; | |
| 428 | ;; do the real work | |
| 429 | ;; | |
| 430 | (setq ok? | |
| 431 | (catch ':fail | |
| 432 | (loop | |
| 433 | (unless goals (return t)) | |
| 434 | (let ((new-goals nil)) | |
| 435 | (dolist (pair goals) | |
| 436 | (setq new-goals | |
| 437 | (nconc new-goals | |
| 438 | (cbred-deduce pair)))) | |
| 439 | (setq goals new-goals)) | |
| 440 | ))) | |
| 441 | (when *cbred-trace-flag* | |
| 442 | (trace-on)) | |
| 443 | (values ok? goals) | |
| 444 | ) | |
| 445 | 445 | ) |
| 446 | 446 | ) |
| 447 | 447 | ) |
| 0 | 0 | ;;;-*-Mode:LISP; Package: CHAOS; Base:10; Syntax:Common-lisp -*- |
| 1 | 1 | ;;; |
| 2 | ;;; Copyright (c) 2000-2014, Toshimi Sawada. All rights reserved. | |
| 2 | ;;; Copyright (c) 2000-2015, Toshimi Sawada. All rights reserved. | |
| 3 | 3 | ;;; |
| 4 | 4 | ;;; Redistribution and use in source and binary forms, with or without |
| 5 | 5 | ;;; modification, are permitted provided that the following conditions |
| 27 | 27 | ;;; |
| 28 | 28 | (in-package :chaos) |
| 29 | 29 | #|============================================================================= |
| 30 | System:CHAOS | |
| 31 | Module:cafein | |
| 32 | File:rdebug.lisp | |
| 30 | System:CHAOS | |
| 31 | Module:cafein | |
| 32 | File:rdebug.lisp | |
| 33 | 33 | =============================================================================|# |
| 34 | 34 | #-:chaos-debug |
| 35 | 35 | (declaim (optimize (speed 3) (safety 0) #-GCL (debug 0))) |
| 37 | 37 | (declaim (optimize (speed 1) (safety 3) #-GCL (debug 3))) |
| 38 | 38 | |
| 39 | 39 | ;;;***************************************************************************** |
| 40 | ;;; REWRITING WITH TRACE, STEP | |
| 40 | ;;; REWRITING WITH TRACE, STEP | |
| 41 | 41 | ;;;***************************************************************************** |
| 42 | 42 | |
| 43 | 43 | ;;; APPLY-ONE-RULE-DBG |
| 56 | 56 | |
| 57 | 57 | (defun cafein-pattern-match (pat term) |
| 58 | 58 | (declare (type term pat term) |
| 59 | (values (or null t))) | |
| 59 | (values (or null t))) | |
| 60 | 60 | (if (term-is-variable? pat) |
| 61 | 61 | (if (sort<= (term-sort term) (variable-sort pat) |
| 62 | (module-sort-order *current-module*)) | |
| 63 | term | |
| 64 | nil) | |
| 62 | (module-sort-order *current-module*)) | |
| 63 | term | |
| 64 | nil) | |
| 65 | 65 | (if (term-is-lisp-form? pat) |
| 66 | nil | |
| 67 | (multiple-value-bind (gs sub no-match eeq) | |
| 68 | (first-match pat term) | |
| 69 | (declare (ignore gs sub eeq)) | |
| 70 | (unless no-match | |
| 71 | (return-from cafein-pattern-match term)) | |
| 72 | (if (term-is-application-form? term) | |
| 73 | (dolist (sub (term-subterms term) nil) | |
| 74 | (let ((match (cafein-pattern-match pat sub))) | |
| 75 | (when match | |
| 76 | (return-from cafein-pattern-match match)))) | |
| 77 | nil) | |
| 78 | nil)))) | |
| 79 | ||
| 66 | nil | |
| 67 | (multiple-value-bind (gs sub no-match eeq) | |
| 68 | (first-match pat term) | |
| 69 | (declare (ignore gs sub eeq)) | |
| 70 | (unless no-match | |
| 71 | (return-from cafein-pattern-match term)) | |
| 72 | (if (term-is-application-form? term) | |
| 73 | (dolist (sub (term-subterms term) nil) | |
| 74 | (let ((match (cafein-pattern-match pat sub))) | |
| 75 | (when match | |
| 76 | (return-from cafein-pattern-match match)))) | |
| 77 | nil) | |
| 78 | nil)))) | |
| 79 | ||
| 80 | 80 | (defvar *matched-to-stop-pattern* nil) |
| 81 | 81 | |
| 82 | 82 | (defun check-stop-pattern (term) |
| 83 | 83 | (declare (type term term) |
| 84 | (values (or null t))) | |
| 84 | (values (or null t))) | |
| 85 | 85 | (when *rewrite-stop-pattern* |
| 86 | 86 | (when (eq term *matched-to-stop-pattern*) |
| 87 | 87 | (return-from check-stop-pattern nil)) |
| 88 | 88 | (let ((matched (cafein-pattern-match *rewrite-stop-pattern* term))) |
| 89 | 89 | (if matched |
| 90 | (let ((*standard-output* *trace-output*)) | |
| 91 | (setq *matched-to-stop-pattern* term) | |
| 92 | (if (eq matched term) | |
| 93 | (progn | |
| 94 | (format t "~&>> term matches to stop pattern: ") | |
| 95 | (let ((*print-indent* (+ *print-indent* 8))) | |
| 96 | (term-print *rewrite-stop-pattern*)) | |
| 97 | (format t "~&<< will stop rewriting") | |
| 98 | ) | |
| 99 | (progn | |
| 100 | (format t "~&>> subterm : ") | |
| 101 | (let ((*print-indent* (+ *print-indent* 8))) | |
| 102 | (term-print matched)) | |
| 103 | (format t "~& of term : ") | |
| 104 | (let ((*print-indent* (+ *print-indent* 8))) | |
| 105 | (term-print $$term)) | |
| 106 | (format t "~& matches to stop pattern: ") | |
| 107 | (let ((*print-indent* (+ *print-indent* 8))) | |
| 108 | (term-print *rewrite-stop-pattern*)) | |
| 109 | (format t "~&<< will stop rewriting") | |
| 110 | )) | |
| 111 | (force-output)) | |
| 112 | ;; | |
| 113 | (unless *rewrite-stepping* | |
| 114 | (setq *matched-to-stop-pattern* nil)))))) | |
| 115 | ||
| 90 | (let ((*standard-output* *trace-output*)) | |
| 91 | (setq *matched-to-stop-pattern* term) | |
| 92 | (if (eq matched term) | |
| 93 | (progn | |
| 94 | (format t "~&>> term matches to stop pattern: ") | |
| 95 | (let ((*print-indent* (+ *print-indent* 8))) | |
| 96 | (term-print *rewrite-stop-pattern*)) | |
| 97 | (format t "~&<< will stop rewriting") | |
| 98 | ) | |
| 99 | (progn | |
| 100 | (format t "~&>> subterm : ") | |
| 101 | (let ((*print-indent* (+ *print-indent* 8))) | |
| 102 | (term-print matched)) | |
| 103 | (format t "~& of term : ") | |
| 104 | (let ((*print-indent* (+ *print-indent* 8))) | |
| 105 | (term-print $$term)) | |
| 106 | (format t "~& matches to stop pattern: ") | |
| 107 | (let ((*print-indent* (+ *print-indent* 8))) | |
| 108 | (term-print *rewrite-stop-pattern*)) | |
| 109 | (format t "~&<< will stop rewriting") | |
| 110 | )) | |
| 111 | (force-output)) | |
| 112 | ;; | |
| 113 | (unless *rewrite-stepping* | |
| 114 | (setq *matched-to-stop-pattern* nil)))))) | |
| 115 | ||
| 116 | 116 | (defun apply-one-rule-dbg (rule term) |
| 117 | 117 | (declare (type axiom rule) |
| 118 | (type term term) | |
| 119 | (values (or null t)) | |
| 120 | ) | |
| 118 | (type term term) | |
| 119 | (values (or null t)) | |
| 120 | ) | |
| 121 | 121 | ;; check stop pattern |
| 122 | 122 | (check-stop-pattern term) |
| 123 | 123 | ;; apply rule |
| 124 | 124 | (setq *cafein-current-rule* rule) |
| 125 | 125 | (if (block the-end |
| 126 | (let* ((condition nil) | |
| 127 | cur-trial | |
| 128 | next-match-method | |
| 129 | (*trace-level* (1+ *trace-level*)) | |
| 130 | (*print-indent* *print-indent*) | |
| 131 | (*self* term)) | |
| 132 | (multiple-value-bind (global-state subst no-match E-equal) | |
| 133 | (funcall (rule-first-match-method rule) (rule-lhs rule) term) | |
| 134 | (incf $$matches) | |
| 135 | (setq *cafein-current-subst* subst) | |
| 136 | (when no-match (return-from the-end nil)) | |
| 137 | ||
| 138 | ;; | |
| 139 | (unless (beh-context-ok? rule) | |
| 140 | (return-from the-end nil)) | |
| 141 | ||
| 142 | ;; technical assignation related to substitution-image. | |
| 143 | (when E-equal (setq subst nil)) | |
| 144 | ||
| 145 | ;; match success ------------------------------------- | |
| 146 | ;; then, the condition must be checked | |
| 147 | (block try-rule | |
| 148 | (catch 'rule-failure | |
| 149 | (when (and (is-true? (setq condition (rule-condition rule))) | |
| 150 | (null (rule-id-condition rule))) | |
| 151 | ;; there is no condition -- | |
| 152 | ;; rewrite term. | |
| 153 | (when (or $$trace-rewrite | |
| 154 | (rule-trace-flag rule)) | |
| 155 | (let ((*print-with-sort* t)) | |
| 156 | (print-trace-in) | |
| 157 | (princ "rule: ") | |
| 158 | (let ((*print-indent* (+ 2 *print-indent*))) | |
| 159 | (print-axiom-brief rule)) | |
| 160 | (let ((*print-indent* (+ 4 *print-indent*))) | |
| 161 | (print-next) | |
| 162 | (print-substitution subst)) | |
| 163 | )) | |
| 164 | (term-replace-dd-dbg | |
| 165 | term | |
| 166 | ;; note that the computation of the substitution | |
| 167 | ;; made a copy of the rhs. | |
| 168 | (substitution-image-simplifying subst | |
| 169 | (rule-rhs rule))) | |
| 170 | (return-from the-end t)))) | |
| 171 | ||
| 172 | ;; if the condition is not trivial, we enter in a loop | |
| 173 | ;; where one try to find a match such that the condition | |
| 174 | ;; is satisfied. | |
| 175 | (setf next-match-method (rule-next-match-method rule)) | |
| 176 | (loop (when no-match | |
| 177 | (when (or $$trace-rewrite | |
| 178 | (rule-trace-flag rule)) | |
| 179 | (print-trace-in) | |
| 180 | (format t "rewrite rule exhausted (#~D)" cur-trial) | |
| 181 | (force-output)) | |
| 182 | (return)) | |
| 183 | ;; | |
| 184 | (unless (beh-context-ok? rule) | |
| 185 | (return-from the-end nil)) | |
| 186 | ;; | |
| 187 | (setq *cafein-current-subst* subst) | |
| 188 | ;; | |
| 189 | (when (or $$trace-rewrite | |
| 190 | (rule-trace-flag rule)) | |
| 191 | (let ((*print-with-sort* t)) | |
| 192 | (setq cur-trial $$trials) | |
| 193 | (incf $$trials) | |
| 194 | (print-trace-in) | |
| 195 | (format t "apply trial #~D" cur-trial) | |
| 196 | (print-next) | |
| 197 | (princ "-- rule: ") | |
| 198 | (let ((*print-indent* (+ 2 *print-indent*))) | |
| 199 | (print-axiom-brief rule)) | |
| 200 | (let ((*print-indent* (+ 4 *print-indent*))) | |
| 201 | (print-next) | |
| 202 | (print-substitution subst)) | |
| 203 | (force-output))) | |
| 204 | (block try-rule | |
| 205 | (catch 'rule-failure | |
| 206 | (if (and (or (null (rule-id-condition rule)) | |
| 207 | (rule-eval-id-condition subst | |
| 208 | (rule-id-condition rule))) | |
| 209 | (is-true? | |
| 210 | (let (($$cond (substitution-image subst condition)) | |
| 211 | (*rewrite-exec-mode* | |
| 212 | (if *rewrite-exec-condition* | |
| 213 | *rewrite-exec-mode* | |
| 214 | nil))) | |
| 215 | ;; no simplyfing since probably wouldn't pay | |
| 216 | (if *rewrite-semantic-reduce* | |
| 217 | (normalize-term-with-bcontext $$cond) | |
| 218 | (normalize-term $$cond)) | |
| 219 | $$cond))) | |
| 220 | ;; the condition is satisfied | |
| 221 | (progn | |
| 222 | (when (or $$trace-rewrite | |
| 223 | (rule-trace-flag rule)) | |
| 224 | (print-trace-in) | |
| 225 | (format t "match success #~D" cur-trial)) | |
| 226 | (term-replace-dd-dbg | |
| 227 | term | |
| 228 | (substitution-image-simplifying subst | |
| 229 | (rule-rhs rule))) | |
| 230 | (return-from the-end t)) | |
| 231 | nil))) | |
| 232 | ||
| 233 | ;; else, try another ... | |
| 234 | (multiple-value-setq (global-state subst no-match) | |
| 235 | (progn | |
| 236 | (incf $$matches) | |
| 237 | (funcall next-match-method global-state) | |
| 238 | )) | |
| 239 | ||
| 240 | );; end loop | |
| 241 | ||
| 242 | ;; In this case there is no match at all and the rule does not apply. | |
| 243 | (return-from the-end nil)))) | |
| 126 | (let* ((condition nil) | |
| 127 | cur-trial | |
| 128 | next-match-method | |
| 129 | (*trace-level* (1+ *trace-level*)) | |
| 130 | (*print-indent* *print-indent*) | |
| 131 | (*self* term)) | |
| 132 | (multiple-value-bind (global-state subst no-match E-equal) | |
| 133 | (funcall (rule-first-match-method rule) (rule-lhs rule) term) | |
| 134 | (incf $$matches) | |
| 135 | (setq *cafein-current-subst* subst) | |
| 136 | (when no-match (return-from the-end nil)) | |
| 137 | ||
| 138 | ;; | |
| 139 | (unless (beh-context-ok? rule) | |
| 140 | (return-from the-end nil)) | |
| 141 | ||
| 142 | ;; technical assignation related to substitution-image. | |
| 143 | (when E-equal (setq subst nil)) | |
| 144 | ||
| 145 | ;; match success ------------------------------------- | |
| 146 | ;; then, the condition must be checked | |
| 147 | (block try-rule | |
| 148 | (catch 'rule-failure | |
| 149 | (when (and (is-true? (setq condition (rule-condition rule))) | |
| 150 | (null (rule-id-condition rule))) | |
| 151 | ;; there is no condition -- | |
| 152 | ;; rewrite term. | |
| 153 | (when (or $$trace-rewrite | |
| 154 | (rule-trace-flag rule)) | |
| 155 | (let ((*print-with-sort* t)) | |
| 156 | (print-trace-in) | |
| 157 | (princ "rule: ") | |
| 158 | (let ((*print-indent* (+ 2 *print-indent*))) | |
| 159 | (print-axiom-brief rule)) | |
| 160 | (let ((*print-indent* (+ 4 *print-indent*))) | |
| 161 | (print-next) | |
| 162 | (print-substitution subst)) | |
| 163 | )) | |
| 164 | (term-replace-dd-dbg | |
| 165 | term | |
| 166 | ;; note that the computation of the substitution | |
| 167 | ;; made a copy of the rhs. | |
| 168 | (substitution-image-simplifying subst | |
| 169 | (rule-rhs rule))) | |
| 170 | (return-from the-end t)))) | |
| 171 | ||
| 172 | ;; if the condition is not trivial, we enter in a loop | |
| 173 | ;; where one try to find a match such that the condition | |
| 174 | ;; is satisfied. | |
| 175 | (setf next-match-method (rule-next-match-method rule)) | |
| 176 | (loop (when no-match | |
| 177 | (when (or $$trace-rewrite | |
| 178 | (rule-trace-flag rule)) | |
| 179 | (print-trace-in) | |
| 180 | (format t "rewrite rule exhausted (#~D)" cur-trial) | |
| 181 | (force-output)) | |
| 182 | (return)) | |
| 183 | ;; | |
| 184 | (unless (beh-context-ok? rule) | |
| 185 | (return-from the-end nil)) | |
| 186 | ;; | |
| 187 | (setq *cafein-current-subst* subst) | |
| 188 | ;; | |
| 189 | (when (or $$trace-rewrite | |
| 190 | (rule-trace-flag rule)) | |
| 191 | (let ((*print-with-sort* t)) | |
| 192 | (setq cur-trial $$trials) | |
| 193 | (incf $$trials) | |
| 194 | (print-trace-in) | |
| 195 | (format t "apply trial #~D" cur-trial) | |
| 196 | (print-next) | |
| 197 | (princ "-- rule: ") | |
| 198 | (let ((*print-indent* (+ 2 *print-indent*))) | |
| 199 | (print-axiom-brief rule)) | |
| 200 | (let ((*print-indent* (+ 4 *print-indent*))) | |
| 201 | (print-next) | |
| 202 | (print-substitution subst)) | |
| 203 | (force-output))) | |
| 204 | (block try-rule | |
| 205 | (catch 'rule-failure | |
| 206 | (if (and (or (null (rule-id-condition rule)) | |
| 207 | (rule-eval-id-condition subst | |
| 208 | (rule-id-condition rule))) | |
| 209 | (is-true? | |
| 210 | (let (($$cond (substitution-image subst condition)) | |
| 211 | (*rewrite-exec-mode* | |
| 212 | (if *rewrite-exec-condition* | |
| 213 | *rewrite-exec-mode* | |
| 214 | nil))) | |
| 215 | ;; no simplyfing since probably wouldn't pay | |
| 216 | (if *rewrite-semantic-reduce* | |
| 217 | (normalize-term-with-bcontext $$cond) | |
| 218 | (normalize-term $$cond)) | |
| 219 | $$cond))) | |
| 220 | ;; the condition is satisfied | |
| 221 | (progn | |
| 222 | (when (or $$trace-rewrite | |
| 223 | (rule-trace-flag rule)) | |
| 224 | (print-trace-in) | |
| 225 | (format t "match success #~D" cur-trial)) | |
| 226 | (term-replace-dd-dbg | |
| 227 | term | |
| 228 | (substitution-image-simplifying subst | |
| 229 | (rule-rhs rule))) | |
| 230 | (return-from the-end t)) | |
| 231 | nil))) | |
| 232 | ||
| 233 | ;; else, try another ... | |
| 234 | (multiple-value-setq (global-state subst no-match) | |
| 235 | (progn | |
| 236 | (incf $$matches) | |
| 237 | (funcall next-match-method global-state) | |
| 238 | )) | |
| 239 | ||
| 240 | );; end loop | |
| 241 | ||
| 242 | ;; In this case there is no match at all and the rule does not apply. | |
| 243 | (return-from the-end nil)))) | |
| 244 | 244 | ;; applied a rule. |
| 245 | 245 | t |
| 246 | 246 | ;; else no rule was applied |
| 247 | 247 | (if *matched-to-stop-pattern* |
| 248 | (if *rewrite-stepping* | |
| 249 | nil | |
| 250 | (progn | |
| 251 | (setq *matched-to-stop-pattern* nil) | |
| 252 | (throw 'rewrite-abort $$term))) | |
| 253 | nil) | |
| 248 | (if *rewrite-stepping* | |
| 249 | nil | |
| 250 | (progn | |
| 251 | (setq *matched-to-stop-pattern* nil) | |
| 252 | (throw 'rewrite-abort $$term))) | |
| 253 | nil) | |
| 254 | 254 | )) |
| 255 | 255 | |
| 256 | 256 | (defun term-replace-dd-dbg (old new) |
| 257 | 257 | (declare (type term old new) |
| 258 | (values term)) | |
| 258 | (values term)) | |
| 259 | 259 | ;; |
| 260 | 260 | (incf *rule-count*) |
| 261 | 261 | |
| 270 | 270 | |
| 271 | 271 | ;; Trace output |
| 272 | 272 | (when (or $$trace-rewrite |
| 273 | (rule-trace-flag *cafein-current-rule*)) | |
| 273 | (rule-trace-flag *cafein-current-rule*)) | |
| 274 | 274 | (let ((*print-with-sort* t)) |
| 275 | 275 | (print-trace-out) |
| 276 | 276 | (let ((*print-indent* (+ 4 *print-indent*))) |
| 277 | (term-print old) | |
| 278 | (print-check 0 5) | |
| 279 | (princ " --> ") | |
| 280 | ;; (print-check) | |
| 281 | (term-print new)) | |
| 277 | (term-print old) | |
| 278 | (print-check 0 5) | |
| 279 | (princ " --> ") | |
| 280 | ;; (print-check) | |
| 281 | (term-print new)) | |
| 282 | 282 | (unless $$trace-rewrite-whole (terpri)))) |
| 283 | 283 | ;; trace whole |
| 284 | 284 | (if $$trace-rewrite-whole |
| 285 | 285 | (let ((*print-with-sort* t) |
| 286 | (*fancy-print* t)) | |
| 287 | (if $$cond | |
| 288 | (progn | |
| 289 | (format t "~&[~a(cond)]: " *rule-count*) | |
| 290 | (let ((*print-indent* (+ 2 *print-indent*))) | |
| 291 | (term-print $$cond) | |
| 292 | (print-next) | |
| 293 | (let ((res (term-replace old new))) | |
| 294 | (print-check 0 5) | |
| 295 | (princ " --> ") | |
| 296 | (let ((*print-indent* (+ 2 *print-indent*))) | |
| 297 | ;; (print-check) | |
| 298 | (term-print $$cond)) | |
| 299 | res))) | |
| 300 | (progn | |
| 301 | (format t "~&[~a]: " *rule-count*) | |
| 302 | (let ((*print-indent* (+ 2 *print-indent*))) | |
| 303 | (term-print $$term)) | |
| 304 | (print-next) | |
| 305 | (let ((res (term-replace old new))) | |
| 306 | (print-check 0 5) | |
| 307 | (princ "---> ") | |
| 308 | (let ((*print-indent* (+ 2 *print-indent*))) | |
| 309 | ;; (print-check) | |
| 310 | (term-print $$term)) | |
| 311 | res)))) | |
| 286 | (*fancy-print* t)) | |
| 287 | (if $$cond | |
| 288 | (progn | |
| 289 | (format t "~&[~a(cond)]: " *rule-count*) | |
| 290 | (let ((*print-indent* (+ 2 *print-indent*))) | |
| 291 | (term-print $$cond) | |
| 292 | (print-next) | |
| 293 | (let ((res (term-replace old new))) | |
| 294 | (print-check 0 5) | |
| 295 | (princ " --> ") | |
| 296 | (let ((*print-indent* (+ 2 *print-indent*))) | |
| 297 | ;; (print-check) | |
| 298 | (term-print $$cond)) | |
| 299 | res))) | |
| 300 | (progn | |
| 301 | (format t "~&[~a]: " *rule-count*) | |
| 302 | (let ((*print-indent* (+ 2 *print-indent*))) | |
| 303 | (term-print $$term)) | |
| 304 | (print-next) | |
| 305 | (let ((res (term-replace old new))) | |
| 306 | (print-check 0 5) | |
| 307 | (princ "---> ") | |
| 308 | (let ((*print-indent* (+ 2 *print-indent*))) | |
| 309 | ;; (print-check) | |
| 310 | (term-print $$term)) | |
| 311 | res)))) | |
| 312 | 312 | (term-replace old new)) |
| 313 | 313 | ;; |
| 314 | 314 | ;; check rewrite count limit |
| 315 | 315 | (when (and *rewrite-count-limit* |
| 316 | (<= *rewrite-count-limit* *rule-count*)) | |
| 316 | (<= *rewrite-count-limit* *rule-count*)) | |
| 317 | 317 | (format *error-output* "~&>> aborting rewrite due to rewrite count limit (= ~d) <<" |
| 318 | *rewrite-count-limit*) | |
| 318 | *rewrite-count-limit*) | |
| 319 | 319 | (throw 'rewrite-abort $$term)) |
| 320 | 320 | ;; |
| 321 | 321 | $$term) |
| 355 | 355 | |
| 356 | 356 | (defun cafein-stepper (term &optional new-term) |
| 357 | 357 | (declare (ignore new-term) |
| 358 | (type term term) | |
| 359 | (values t)) | |
| 358 | (type term term) | |
| 359 | (values t)) | |
| 360 | 360 | ;; first check stop pattern or steps to be done.... |
| 361 | 361 | (if *matched-to-stop-pattern* |
| 362 | 362 | (progn |
| 363 | (setq *matched-to-stop-pattern* nil) | |
| 364 | (setq *steps-to-be-done* nil) | |
| 365 | (with-output-simple-msg () | |
| 366 | (princ ">> stop because matches stop pattern."))) | |
| 363 | (setq *matched-to-stop-pattern* nil) | |
| 364 | (setq *steps-to-be-done* nil) | |
| 365 | (with-output-simple-msg () | |
| 366 | (princ ">> stop because matches stop pattern."))) | |
| 367 | 367 | (progn |
| 368 | (when *steps-to-be-done* | |
| 369 | (decf (the fixnum *steps-to-be-done*))) | |
| 370 | (when (and *steps-to-be-done* (> (the fixnum *steps-to-be-done*) 0)) | |
| 371 | (return-from cafein-stepper nil)) | |
| 372 | (unless *steps-to-be-done* (return-from cafein-stepper nil)))) | |
| 368 | (when *steps-to-be-done* | |
| 369 | (decf (the fixnum *steps-to-be-done*))) | |
| 370 | (when (and *steps-to-be-done* (> (the fixnum *steps-to-be-done*) 0)) | |
| 371 | (return-from cafein-stepper nil)) | |
| 372 | (unless *steps-to-be-done* (return-from cafein-stepper nil)))) | |
| 373 | 373 | ;; |
| 374 | 374 | ;; print current term |
| 375 | 375 | (format t "~&>> stepper term: ") |
| 379 | 379 | (loop |
| 380 | 380 | (block next-loop |
| 381 | 381 | (with-chaos-top-error () |
| 382 | (with-chaos-error () | |
| 383 | (let ((inp (get-step-command))) | |
| 384 | (unless (listp inp) (return-from next-loop)) | |
| 385 | ;; QUIT | |
| 386 | (when (member (car inp) '("eof" "q" ":q" "quit" ":quit" eof) :test #'equal) | |
| 387 | (step-off) | |
| 388 | (return-from cafein-stepper nil)) | |
| 389 | ;; | |
| 390 | (let* ((key (car inp)) | |
| 391 | (proc (find-if #'(lambda (elt) | |
| 392 | (member key (car elt) :test #'equal)) | |
| 393 | cafein-stepper-procs))) | |
| 394 | (if proc | |
| 395 | (funcall (cdr proc) inp) | |
| 396 | (progn | |
| 397 | (with-output-chaos-warning () | |
| 398 | (format t "unknow step command ~a." inp) | |
| 399 | (print-next) | |
| 400 | (format t "type :? for help.")))))))))))) | |
| 382 | (with-chaos-error () | |
| 383 | (let ((inp (get-step-command))) | |
| 384 | (unless (listp inp) (return-from next-loop)) | |
| 385 | ;; QUIT | |
| 386 | (when (member (car inp) '("eof" "q" ":q" "quit" ":quit" eof) :test #'equal) | |
| 387 | (step-off) | |
| 388 | (return-from cafein-stepper nil)) | |
| 389 | ;; | |
| 390 | (let* ((key (car inp)) | |
| 391 | (proc (find-if #'(lambda (elt) | |
| 392 | (member key (car elt) :test #'equal)) | |
| 393 | cafein-stepper-procs))) | |
| 394 | (if proc | |
| 395 | (funcall (cdr proc) inp) | |
| 396 | (progn | |
| 397 | (with-output-chaos-warning () | |
| 398 | (format t "unknow step command ~a." inp) | |
| 399 | (print-next) | |
| 400 | (format t "type :? for help.")))))))))))) | |
| 401 | 401 | |
| 402 | 402 | (defvar *step-commands* nil) |
| 403 | 403 | |
| 404 | 404 | (defun get-step-command () |
| 405 | 405 | (let ((.reader-ch. 'space) |
| 406 | (*reader-input* *reader-void*) | |
| 407 | (*old-context* nil) | |
| 408 | (top-level? (at-top-level))) | |
| 406 | (*reader-input* *reader-void*) | |
| 407 | (*old-context* nil) | |
| 408 | (top-level? (at-top-level))) | |
| 409 | 409 | (with-chaos-top-error () |
| 410 | 410 | (with-chaos-error () |
| 411 | (when top-level? | |
| 412 | (format t "~&STEP[~D]? " *rule-count*) | |
| 413 | (force-output)) | |
| 414 | (reader 'step-commands *step-commands*))))) | |
| 411 | (when top-level? | |
| 412 | (format t "~&STEP[~D]? " *rule-count*) | |
| 413 | (force-output)) | |
| 414 | (reader 'step-commands *step-commands*))))) | |
| 415 | 415 | |
| 416 | 416 | (eval-when (:execute :load-toplevel) |
| 417 | 417 | (setq *step-commands* |
| 418 | '((step-commands | |
| 419 | (:one-of | |
| 420 | ||
| 421 | ;; end of step (just stop now). | |
| 422 | #-CMU (#\^D) | |
| 423 | #+CMU (#\) | |
| 424 | (eof) | |
| 425 | ((:+ q |:q|)) | |
| 426 | ||
| 427 | ;; continue rewriting and exit from stepping mode. | |
| 428 | ((:+ c |:c| continue |:continue|)) | |
| 429 | ||
| 430 | ;; stop pattern | |
| 431 | ((:+ stop |:stop|) :top-term) | |
| 432 | ||
| 433 | ;; rewrite limit | |
| 434 | ((:+ rwt rewrite |:rwt| |:rewrite|) :symbol) | |
| 435 | ||
| 436 | ;; step to next | |
| 437 | ((:+ n |:n| next |:next|)) | |
| 438 | ||
| 439 | ;; step N step | |
| 440 | ((:+ g go |:g| |:go|) :int) | |
| 441 | ||
| 442 | ;; abort | |
| 443 | ((:+ a |:a| abort |:abort|)) | |
| 444 | ||
| 445 | ;; show infos | |
| 446 | ((:+ r |:r| |:rule| rule)) | |
| 447 | ((:+ s |:s| subst |:subst|)) | |
| 448 | ((:+ p |:p| pattern |:pattern|)) | |
| 449 | ((:+ l |:l| limit |:limit|)) | |
| 450 | ||
| 451 | ;; some useful top level commands | |
| 452 | ((:+ match unify) (:seq-of :term) to (:seq-of :term) |.|) | |
| 453 | ((:+ lisp ev eval evq lispq) | |
| 454 | (:call (read))) | |
| 455 | ((:+ show sh set describe desc) | |
| 456 | (:seq-of :top-opname)) | |
| 457 | ;; | |
| 458 | (cd :symbol) | |
| 459 | #-(or GCL LUCID CMU) (ls :symbol) | |
| 460 | #+(or GCL LUCID CMU) (ls :top-term) | |
| 461 | (pwd) | |
| 462 | (! :top-term) | |
| 463 | ((+ ? |:?| |:h| h |:help| help)) | |
| 464 | )) | |
| 465 | (Selector | |
| 466 | (:one-of | |
| 467 | ;; (term) (top) (subterm) | |
| 468 | (|{| :int :append (:seq-of |,| :int) |}|) | |
| 469 | (|(| (:seq-of :int) |)|) | |
| 470 | (\[ :int (:optional |..| :int) \]))) | |
| 471 | ))) | |
| 472 | ||
| 418 | '((step-commands | |
| 419 | (:one-of | |
| 420 | ||
| 421 | ;; end of step (just stop now). | |
| 422 | #-CMU (#\^D) | |
| 423 | #+CMU (#\) | |
| 424 | (eof) | |
| 425 | ((:+ q |:q|)) | |
| 426 | ||
| 427 | ;; continue rewriting and exit from stepping mode. | |
| 428 | ((:+ c |:c| continue |:continue|)) | |
| 429 | ||
| 430 | ;; stop pattern | |
| 431 | ((:+ stop |:stop|) :top-term) | |
| 432 | ||
| 433 | ;; rewrite limit | |
| 434 | ((:+ rwt rewrite |:rwt| |:rewrite|) :symbol) | |
| 435 | ||
| 436 | ;; step to next | |
| 437 | ((:+ n |:n| next |:next|)) | |
| 438 | ||
| 439 | ;; step N step | |
| 440 | ((:+ g go |:g| |:go|) :int) | |
| 441 | ||
| 442 | ;; abort | |
| 443 | ((:+ a |:a| abort |:abort|)) | |
| 444 | ||
| 445 | ;; show infos | |
| 446 | ((:+ r |:r| |:rule| rule)) | |
| 447 | ((:+ s |:s| subst |:subst|)) | |
| 448 | ((:+ p |:p| pattern |:pattern|)) | |
| 449 | ((:+ l |:l| limit |:limit|)) | |
| 450 | ||
| 451 | ;; some useful top level commands | |
| 452 | ((:+ match unify) (:seq-of :term) to (:seq-of :term) |.|) | |
| 453 | ((:+ lisp ev eval evq lispq) | |
| 454 | (:call (read))) | |
| 455 | ((:+ show sh set describe desc) | |
| 456 | (:seq-of :top-opname)) | |
| 457 | ;; | |
| 458 | (cd :symbol) | |
| 459 | #-(or GCL LUCID CMU) (ls :symbol) | |
| 460 | #+(or GCL LUCID CMU) (ls :top-term) | |
| 461 | (pwd) | |
| 462 | (! :top-term) | |
| 463 | ((+ ? |:?| |:h| h |:help| help)) | |
| 464 | )) | |
| 465 | (Selector | |
| 466 | (:one-of | |
| 467 | ;; (term) (top) (subterm) | |
| 468 | (|{| :int :append (:seq-of |,| :int) |}|) | |
| 469 | (|(| (:seq-of :int) |)|) | |
| 470 | (\[ :int (:optional |..| :int) \]))) | |
| 471 | ))) | |
| 472 | ||
| 473 | 473 | ;;; REWRITE COUNT LIMIT |
| 474 | 474 | ;;; ("rwt" <number>) |
| 475 | 475 | ;;; |
| 476 | 476 | (defun cafein-rewrite-count-limit-proc (inp) |
| 477 | 477 | (declare (type list inp) |
| 478 | (values t)) | |
| 478 | (values t)) | |
| 479 | 479 | (let ((count (cadr inp))) |
| 480 | 480 | (if (member count '("off" "none" ".") :test #'equal) |
| 481 | (eval-ast (%rewrite-count* 'off)) | |
| 482 | (eval-ast (%rewrite-count* count))))) | |
| 481 | (eval-ast (%rewrite-count* 'off)) | |
| 482 | (eval-ast (%rewrite-count* count))))) | |
| 483 | 483 | |
| 484 | 484 | ;;; STOP AT PATTERN |
| 485 | 485 | ;;; ("stop" <term> ".") |
| 522 | 522 | (declare (ignore inp)) |
| 523 | 523 | ;; (format t "~&[current rewrite rule]: ") |
| 524 | 524 | (let ((*fancy-print* nil) |
| 525 | (*print-with-sort* t)) | |
| 525 | (*print-with-sort* t)) | |
| 526 | 526 | (print-chaos-object *cafein-current-rule*))) |
| 527 | 527 | |
| 528 | 528 | ;;; SHOW SUBST |
| 568 | 568 | (declare (ignore ignore)) |
| 569 | 569 | (print-next) |
| 570 | 570 | (format t "[rewrite limit]: ~a" (if *rewrite-count-limit* |
| 571 | *rewrite-count-limit* | |
| 572 | "not specified."))) | |
| 571 | *rewrite-count-limit* | |
| 572 | "not specified."))) | |
| 573 | 573 | |
| 574 | 574 | (defun cafein-show-stop-pattern (&rest ignore) |
| 575 | 575 | (declare (ignore ignore)) |
| 577 | 577 | (format t "[stop pattern]: ") |
| 578 | 578 | (if *rewrite-stop-pattern* |
| 579 | 579 | (let ((*fancy-print* nil) |
| 580 | (*print-with-sort* t)) | |
| 581 | (term-print *rewrite-stop-pattern*)) | |
| 580 | (*print-with-sort* t)) | |
| 581 | (term-print *rewrite-stop-pattern*)) | |
| 582 | 582 | (princ "not specified."))) |
| 583 | ||
| 583 | ||
| 584 | 584 | ;;; EOF |
| 0 | ;;;-*- Mode:LISP; Package: CHAOS; Base:10; Syntax:Common-lisp -*- | |
| 1 | ;;; | |
| 2 | ;;; Copyright (c) 2000-2015, Toshimi Sawada. All rights reserved. | |
| 3 | ;;; | |
| 4 | ;;; Redistribution and use in source and binary forms, with or without | |
| 5 | ;;; modification, are permitted provided that the following conditions | |
| 6 | ;;; are met: | |
| 7 | ;;; | |
| 8 | ;;; * Redistributions of source code must retain the above copyright | |
| 9 | ;;; notice, this list of conditions and the following disclaimer. | |
| 10 | ;;; | |
| 11 | ;;; * Redistributions in binary form must reproduce the above | |
| 12 | ;;; copyright notice, this list of conditions and the following | |
| 13 | ;;; disclaimer in the documentation and/or other materials | |
| 14 | ;;; provided with the distribution. | |
| 15 | ;;; | |
| 16 | ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED | |
| 17 | ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED | |
| 18 | ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE | |
| 19 | ;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY | |
| 20 | ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL | |
| 21 | ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE | |
| 22 | ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS | |
| 23 | ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, | |
| 24 | ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING | |
| 25 | ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS | |
| 26 | ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. | |
| 27 | ;;; | |
| 28 | (in-package :chaos) | |
| 29 | #|============================================================================= | |
| 30 | System:CHAOS | |
| 31 | Module:cafein | |
| 32 | File:reducer.lisp | |
| 33 | =============================================================================|# | |
| 34 | #-:chaos-debug | |
| 35 | (declaim (optimize (speed 3) (safety 1) #-GCL (debug 0))) | |
| 36 | #+:chaos-debug | |
| 37 | (declaim (optimize (speed 1) (safety 3) #-GCL (debug 3))) | |
| 38 | ||
| 39 | ||
| 40 | ;;; ======== | |
| 41 | ;;; REDUCER | |
| 42 | ;;; provides term rewriting eclosed within computing environment. | |
| 43 | ;;; ======== | |
| 44 | (declaim (inline begin-parse end-parse time-for-parsing-in-seconds | |
| 45 | begin-rewrite end-rewrite time-for-rewriting-in-seconds | |
| 46 | number-metches number-rewritings number-memo-hits | |
| 47 | clear-rewriting-fc prepare-term reset-rewrite-counters | |
| 48 | prepare-reduction-env reducer reducer-no-stat)) | |
| 49 | ||
| 50 | ||
| 51 | (let ((*m-pattern-subst* nil) | |
| 52 | (.rwl-context-stack. nil) | |
| 53 | (.rwl-states-so-far. 0) | |
| 54 | (*rewrite-exec-mode* nil) | |
| 55 | (*rewrite-semantic-reduce* nil) | |
| 56 | ($$mod nil) | |
| 57 | (*steps-to-be-done* 0) | |
| 58 | ($$matches 0) | |
| 59 | (*perform-on-demand-reduction* nil) | |
| 60 | (*rule-count* 0) | |
| 61 | (*term-memo-hash-hit* 0) | |
| 62 | ($$term nil) | |
| 63 | ($$term-context nil) | |
| 64 | ($$cond nil) | |
| 65 | ($$target-term nil) | |
| 66 | ($$norm nil) | |
| 67 | (*do-empty-match* nil) | |
| 68 | (parse-begin-time 0) | |
| 69 | (time-for-parsing 0.0) | |
| 70 | (rewrite-begin-time 0) | |
| 71 | (time-for-rewriting 0.0)) | |
| 72 | (declare (special *m-pattern-subst* | |
| 73 | .rwl-context-stack. | |
| 74 | .rwl-states-so-far. | |
| 75 | *rewrite-exec-mode* | |
| 76 | *rewrite-semantic-reduce* | |
| 77 | $$mod | |
| 78 | *steps-to-be-done* | |
| 79 | $$matches | |
| 80 | *perforom-on-demand-reduction* | |
| 81 | *rule-count* | |
| 82 | *term-memo-hash-hit* | |
| 83 | $$target-term | |
| 84 | $$term | |
| 85 | $$term-context | |
| 86 | $$cond | |
| 87 | $$target-term | |
| 88 | $$norm | |
| 89 | *do-empty-match*)) | |
| 90 | (declare (type (or null t) *perform-on-demand-reduction* *do-empty-match*) | |
| 91 | (type fixnum *steps-to-be-done* $$matches *rule-count* .rwl-states-so-far. | |
| 92 | *term-memo-hash-hit*) | |
| 93 | (type list *m-pattern-subst* .rwl-context-stack.) | |
| 94 | (type (or null module) $$mod) | |
| 95 | (type integer parse-begin-time rewrite-begin-time) | |
| 96 | (type float time-for-parsing time-for-rewriting)) | |
| 97 | ||
| 98 | (defun reset-parse-time () | |
| 99 | (setf time-for-parsing 0.0)) | |
| 100 | ||
| 101 | (defun begin-parse () | |
| 102 | (setf parse-begin-time (get-internal-run-time))) | |
| 103 | ||
| 104 | (defun end-parse () | |
| 105 | (setf time-for-parsing (elapsed-time-in-seconds parse-begin-time | |
| 106 | (get-internal-run-time)))) | |
| 107 | ||
| 108 | (defun time-for-parsing-in-seconds () | |
| 109 | time-for-parsing) | |
| 110 | ||
| 111 | (defun begin-rewrite () | |
| 112 | (setf rewrite-begin-time (get-internal-run-time))) | |
| 113 | ||
| 114 | (defun end-rewrite () | |
| 115 | (setf time-for-rewriting (elapsed-time-in-seconds rewrite-begin-time | |
| 116 | (get-internal-run-time)))) | |
| 117 | ||
| 118 | (defun time-for-rewriting-in-seconds () | |
| 119 | time-for-rewriting) | |
| 120 | ||
| 121 | (defun number-matches () | |
| 122 | $$matches) | |
| 123 | ||
| 124 | (defun number-rewritings () | |
| 125 | *rule-count*) | |
| 126 | ||
| 127 | (defun number-memo-hits () | |
| 128 | *term-memo-hash-hit*) | |
| 129 | ||
| 130 | ;; | |
| 131 | (defun clear-rewriting-fc (module mode) | |
| 132 | (setf *m-pattern-subst* nil | |
| 133 | .rwl-context-stack. nil | |
| 134 | .rwl-sch-context. nil | |
| 135 | .rwl-states-so-far. 0 | |
| 136 | *steps-to-be-done* 1 | |
| 137 | *do-empty-match* nil | |
| 138 | *rewrite-exec-mode* (or (eq mode :exec) (eq mode :exec+)) | |
| 139 | *rewrite-semantic-reduce* (and (eq mode :red) | |
| 140 | (module-has-behavioural-axioms module)))) | |
| 141 | ||
| 142 | ;; prepare-term | |
| 143 | ;; NOTE: this always record the time cosumed for parsing the given term. | |
| 144 | (defun prepare-term (pre-term module) | |
| 145 | (declare (type module module)) | |
| 146 | ;; be ready for parsing | |
| 147 | (prepare-for-parsing module) | |
| 148 | (reset-parse-time) | |
| 149 | ;; setup target term | |
| 150 | (if (termp pre-term) | |
| 151 | (setq $$target-term pre-term) | |
| 152 | ;; not yet parsed term | |
| 153 | (progn | |
| 154 | (begin-parse) | |
| 155 | (let* ((*parse-variables* nil) | |
| 156 | (target-term (simple-parse module pre-term *cosmos*))) | |
| 157 | (end-parse) | |
| 158 | (when (or (null (term-sort target-term)) | |
| 159 | (sort<= (term-sort target-term) *syntax-err-sort* *chaos-sort-order*)) | |
| 160 | (with-output-chaos-error ('invalid-target-term) | |
| 161 | (format t "Could not parse the reduction target ~s" pre-term))) | |
| 162 | (setq $$target-term target-term)))) | |
| 163 | ;; setup $$term | |
| 164 | (reset-target-term $$target-term module module) | |
| 165 | $$target-term) | |
| 166 | ||
| 167 | ;; reset-rewrite-counters | |
| 168 | ;; initialize rewriting counters. | |
| 169 | (defun reset-rewrite-counters () | |
| 170 | (setf $$matches 0 | |
| 171 | *rule-count* 0 | |
| 172 | *term-memo-hash-hit* 0)) | |
| 173 | ||
| 174 | ;; reset-term-memo-table | |
| 175 | (defun reset-term-memo-table (module) | |
| 176 | (unless (eq module (get-context-module t)) | |
| 177 | (clear-term-memo-table *term-memo-table*))) | |
| 178 | ||
| 179 | ;; prepare-reduction-env | |
| 180 | ;; all-in-one proc for setting up environment variables for rewriting, | |
| 181 | ;; returns evaluated 'context-module'. | |
| 182 | (defun prepare-reduction-env (term context-module mode stat-reset) | |
| 183 | (let ((module (if (module-p context-module) | |
| 184 | context-module | |
| 185 | ;; we got a module expression | |
| 186 | (eval-modexp context-module)))) | |
| 187 | (unless (module-p module) | |
| 188 | (with-output-chaos-error ('invalid-context) | |
| 189 | (format t "Invalid context module ~s" context-module))) | |
| 190 | ;; initialize term memo iff proposed rewring context is different from the current one. | |
| 191 | (reset-term-memo-table module) | |
| 192 | ;; setup target term | |
| 193 | (prepare-term term module) | |
| 194 | ;; reset statistics | |
| 195 | (when stat-reset (reset-rewrite-counters)) | |
| 196 | ;; set up various flags and counters used in rewriting process | |
| 197 | (clear-rewriting-fc module mode) | |
| 198 | ;; returns the evaluated context module | |
| 199 | module)) | |
| 200 | ||
| 201 | ;; generate-statistics-form | |
| 202 | (defun generate-statistics-form () | |
| 203 | (let ((stat-form "")) | |
| 204 | (declare (type string stat-form)) | |
| 205 | (setq stat-form | |
| 206 | (format nil "(~a sec for parse, ~a sec for ~d rewrites + ~d matches" | |
| 207 | (format nil "~,4f" (time-for-parsing-in-seconds)) | |
| 208 | (format nil "~,4f" (time-for-rewriting-in-seconds)) | |
| 209 | (number-rewritings) | |
| 210 | (number-matches))) | |
| 211 | (concatenate 'string stat-form | |
| 212 | (if (zerop (number-memo-hits)) | |
| 213 | ")" | |
| 214 | (format nil ", ~d memo hits)" (number-memo-hits)))))) | |
| 215 | ||
| 216 | (defun generate-statistics-form-rewriting-only () | |
| 217 | (let ((stat-form "")) | |
| 218 | (declare (type string stat-form)) | |
| 219 | (setf stat-form | |
| 220 | (format nil "(consumed ~a sec, including ~d rewrites + ~d matches" | |
| 221 | (format nil "~,4f" (time-for-rewriting-in-seconds)) | |
| 222 | (number-rewritings) | |
| 223 | (number-matches))) | |
| 224 | (concatenate 'string stat-form | |
| 225 | (if (zerop (number-memo-hits)) | |
| 226 | ")" | |
| 227 | (format nil ", ~d memo hits)" (number-memo-hits)))))) | |
| 228 | ||
| 229 | ;; REDUCER | |
| 230 | ;; perform reduction | |
| 231 | (defun reducer (term context-module rewrite-mode) | |
| 232 | (with-in-module ((prepare-reduction-env term context-module rewrite-mode t)) | |
| 233 | ;; be ready for rewriting | |
| 234 | (!setup-reduction *current-module*) | |
| 235 | ;; now start | |
| 236 | (begin-rewrite) | |
| 237 | ;; do the reduction | |
| 238 | (catch 'rewrite-abort | |
| 239 | (if *rewrite-exec-mode* | |
| 240 | (rewrite-exec $$target-term *current-module* rewrite-mode) | |
| 241 | (rewrite $$target-term *current-module* rewrite-mode))) | |
| 242 | (end-rewrite) | |
| 243 | $$term)) | |
| 244 | ||
| 245 | ;; REDUCER-NO-STAT | |
| 246 | ;; perform reduction, but does not maintain statistical data | |
| 247 | ;; caller is responsible for calling | |
| 248 | ;; (reset-rewrite-counters)-(begin-rewrite)-(end-rewrite) | |
| 249 | (defun reducer-no-stat (term context-module rewrite-mode) | |
| 250 | (with-in-module ((prepare-reduction-env term context-module rewrite-mode nil)) | |
| 251 | ;; be ready for rewriting | |
| 252 | (!setup-reduction *current-module*) | |
| 253 | (catch 'rewrite-abort | |
| 254 | (if *rewrite-exec-mode* | |
| 255 | (rewrite-exec $$target-term *current-module* rewrite-mode) | |
| 256 | (rewrite $$target-term *current-module* rewrite-mode)))) | |
| 257 | $$term) | |
| 258 | ||
| 259 | (defun simplify-on-top (term context-module) | |
| 260 | (declare (type term term) | |
| 261 | (values t)) | |
| 262 | (with-in-module ((prepare-reduction-env term context-module :red nil)) | |
| 263 | (catch 'rewrite-abort | |
| 264 | (if (term-is-application-form? term) | |
| 265 | (apply-rules-with-different-top term | |
| 266 | (method-rules-with-different-top | |
| 267 | (term-method term))) | |
| 268 | term)))) | |
| 269 | ) | |
| 270 | ||
| 271 | ||
| 272 | ;;; EOF | |
| 273 | ||
| 274 |
| 0 | 0 | ;;;-*- Mode:LISP; Package: CHAOS; Base:10; Syntax:Common-lisp -*- |
| 1 | 1 | ;;; |
| 2 | ;;; Copyright (c) 2000-2014, Toshimi Sawada. All rights reserved. | |
| 2 | ;;; Copyright (c) 2000-2015, Toshimi Sawada. All rights reserved. | |
| 3 | 3 | ;;; |
| 4 | 4 | ;;; Redistribution and use in source and binary forms, with or without |
| 5 | 5 | ;;; modification, are permitted provided that the following conditions |
| 27 | 27 | ;;; |
| 28 | 28 | (in-package :chaos) |
| 29 | 29 | #|============================================================================= |
| 30 | System:CHAOS | |
| 31 | Module:cafein | |
| 32 | File:rengine.lisp | |
| 30 | System:CHAOS | |
| 31 | Module:cafein | |
| 32 | File:rengine.lisp | |
| 33 | 33 | =============================================================================|# |
| 34 | 34 | #-:chaos-debug |
| 35 | 35 | (declaim (optimize (speed 3) (safety 1) #-GCL (debug 0))) |
| 57 | 57 | #-GCL (declaim (inline term-hash-equal)) |
| 58 | 58 | #-(or GCL CMU) |
| 59 | 59 | (defun term-hash-equal (x) |
| 60 | (logand term-hash-mask (sxhash x))) | |
| 60 | (logand term-hash-mask (sxhash x))) | |
| 61 | 61 | #+CMU |
| 62 | 62 | (defun term-hash-equal (x) |
| 63 | (sxhash x)) | |
| 64 | #+GCL | |
| 63 | (sxhash x)) | |
| 64 | #+GCL | |
| 65 | 65 | (si:define-inline-function term-hash-equal (x) (sxhash x)) |
| 66 | 66 | |
| 67 | 67 | #+GCL |
| 102 | 102 | ;; (declare (type term-hash-key x y)) |
| 103 | 103 | (the term-hash-key (logand term-hash-mask (logand term-hash-mask (+ x y))))) |
| 104 | 104 | |
| 105 | ;#+GCL | |
| 106 | ;(si:define-inline-function term-hash-comb (x y) | |
| 107 | ; (make-and term-hash-mask (+ x y))) | |
| 105 | ;#+GCL | |
| 106 | ;(si:define-inline-function term-hash-comb (x y) | |
| 107 | ; (make-and term-hash-mask (+ x y))) | |
| 108 | 108 | |
| 109 | 109 | ;;; #+GCL |
| 110 | 110 | ;;; (si:define-inline-function term-hash-comb (x y) |
| 117 | 117 | ;;; (defvar *on-term-hash-debug* nil) |
| 118 | 118 | |
| 119 | 119 | (defstruct term-hash |
| 120 | (size term-hash-size :type (unsigned-byte 14) :read-only t) | |
| 121 | (table nil :type (or null simple-array)) ) | |
| 120 | (size term-hash-size :type (unsigned-byte 14) :read-only t) | |
| 121 | (table nil :type (or null simple-array)) ) | |
| 122 | 122 | |
| 123 | 123 | (defun hash-term (term) |
| 124 | 124 | (cond ((term-is-applform? term) |
| 125 | (let ((res (sxhash (the symbol (method-id-symbol (term-head term)))))) | |
| 126 | (dolist (subterm (term-subterms term)) | |
| 127 | (setq res (term-hash-comb res (hash-term subterm)))) | |
| 128 | res)) | |
| 129 | ((term-is-builtin-constant? term) | |
| 130 | (term-hash-comb (sxhash (the symbol (sort-id (term-sort term)))) | |
| 131 | (term-hash-equal (term-builtin-value term)))) | |
| 132 | ((term-is-variable? term) (term-hash-eq term)))) | |
| 125 | (let ((res (sxhash (the symbol (method-id-symbol (term-head term)))))) | |
| 126 | (dolist (subterm (term-subterms term)) | |
| 127 | (setq res (term-hash-comb res (hash-term subterm)))) | |
| 128 | res)) | |
| 129 | ((term-is-builtin-constant? term) | |
| 130 | (term-hash-comb (sxhash (the symbol (sort-id (term-sort term)))) | |
| 131 | (term-hash-equal (term-builtin-value term)))) | |
| 132 | ((term-is-variable? term) (term-hash-eq term)))) | |
| 133 | 133 | |
| 134 | 134 | (defun dump-term-hash (term-hash &optional (size term-hash-size)) |
| 135 | (dotimes (x size) | |
| 136 | (let ((ent (svref term-hash x))) | |
| 137 | (when ent | |
| 138 | (format t "~%[~3d]: ~d entrie(s)" x (length ent)) | |
| 139 | (dotimes (y (length ent)) | |
| 140 | (let ((e (nth y ent))) | |
| 141 | (format t "~%(~d)" y) | |
| 142 | (let ((*print-indent* (+ 2 *print-indent*))) | |
| 143 | (term-print (car e)) | |
| 144 | (print-next) | |
| 145 | (princ "==>") | |
| 146 | (print-next) | |
| 147 | (term-print (cdr e))))))))) | |
| 135 | (dotimes (x size) | |
| 136 | (let ((ent (svref term-hash x))) | |
| 137 | (when ent | |
| 138 | (format t "~%[~3d]: ~d entrie(s)" x (length ent)) | |
| 139 | (dotimes (y (length ent)) | |
| 140 | (let ((e (nth y ent))) | |
| 141 | (format t "~%(~d)" y) | |
| 142 | (let ((*print-indent* (+ 2 *print-indent*))) | |
| 143 | (term-print (car e)) | |
| 144 | (print-next) | |
| 145 | (princ "==>") | |
| 146 | (print-next) | |
| 147 | (term-print (cdr e))))))))) | |
| 148 | 148 | |
| 149 | 149 | #-GCL |
| 150 | 150 | (declaim (inline get-hashed-term)) |
| 164 | 164 | (#-GCL defun #+GCL si:define-inline-function |
| 165 | 165 | set-hashed-term (term term-hash value) |
| 166 | 166 | (let ((val (hash-term term))) |
| 167 | (let ((ind (mod val term-hash-size))) | |
| 168 | (let ((ent (svref term-hash ind))) | |
| 169 | (let ((pr (assoc term ent :test #'term-is-similar?))) | |
| 170 | (if pr (rplacd pr value) | |
| 171 | (setf (svref term-hash ind) (cons (cons term value) ent))) ))))) | |
| 167 | (let ((ind (mod val term-hash-size))) | |
| 168 | (let ((ent (svref term-hash ind))) | |
| 169 | (let ((pr (assoc term ent :test #'term-is-similar?))) | |
| 170 | (if pr (rplacd pr value) | |
| 171 | (setf (svref term-hash ind) (cons (cons term value) ent))) ))))) | |
| 172 | 172 | |
| 173 | 173 | ;;; *TERM-MEMO-TABLE* |
| 174 | 174 | |
| 198 | 198 | (defun set-term-color-top (term) |
| 199 | 199 | (if (not *beh-rewrite*) |
| 200 | 200 | (if (sort-is-hidden (term-sort term)) |
| 201 | (set-term-color term :red) | |
| 202 | (set-term-color term)) | |
| 201 | (set-term-color term :red) | |
| 202 | (set-term-color term)) | |
| 203 | 203 | (set-term-color term))) |
| 204 | 204 | |
| 205 | 205 | (defun set-term-color (term &optional red?) |
| 206 | 206 | (labels ((set-color (term set-red) |
| 207 | (if set-red | |
| 208 | (progn | |
| 209 | (term-set-red term) | |
| 210 | (when (term-is-applform? term) | |
| 211 | (dolist (sub (term-subterms term)) | |
| 212 | (when (sort-is-hidden (term-sort sub)) | |
| 213 | (set-color sub :red))))) | |
| 214 | (when (term-is-applform? term) | |
| 215 | (let* ((head (term-head term)) | |
| 216 | (is-beh-coh-context | |
| 217 | (or (method-is-behavioural head) | |
| 218 | (method-is-coherent head) | |
| 219 | (eq head *beh-eq-pred*) ; =b= | |
| 220 | (eq head *beh-equal*) ; =*= | |
| 221 | (and *beh-rewrite* | |
| 222 | (or (eq head *bool-equal*) ; == | |
| 223 | (eq head *bool-nonequal*) ; =/= | |
| 224 | )))) | |
| 225 | (i-am-red nil)) | |
| 226 | (dolist (sub (term-subterms term)) | |
| 227 | (if (sort-is-hidden (term-sort sub)) | |
| 228 | (if is-beh-coh-context | |
| 229 | (progn | |
| 230 | (set-color sub nil)) | |
| 231 | (progn | |
| 232 | (setq i-am-red t) | |
| 233 | (set-color sub :red))) | |
| 234 | ;; | |
| 235 | (set-color sub nil))) | |
| 236 | (if i-am-red | |
| 237 | (term-set-red term) | |
| 238 | (term-set-green term))))) | |
| 239 | )) ; end labels | |
| 207 | (if set-red | |
| 208 | (progn | |
| 209 | (term-set-red term) | |
| 210 | (when (term-is-applform? term) | |
| 211 | (dolist (sub (term-subterms term)) | |
| 212 | (when (sort-is-hidden (term-sort sub)) | |
| 213 | (set-color sub :red))))) | |
| 214 | (when (term-is-applform? term) | |
| 215 | (let* ((head (term-head term)) | |
| 216 | (is-beh-coh-context | |
| 217 | (or (method-is-behavioural head) | |
| 218 | (method-is-coherent head) | |
| 219 | (eq head *beh-eq-pred*) ; =b= | |
| 220 | (eq head *beh-equal*) ; =*= | |
| 221 | (and *beh-rewrite* | |
| 222 | (or (eq head *bool-equal*) ; == | |
| 223 | (eq head *bool-nonequal*) ; =/= | |
| 224 | )))) | |
| 225 | (i-am-red nil)) | |
| 226 | (dolist (sub (term-subterms term)) | |
| 227 | (if (sort-is-hidden (term-sort sub)) | |
| 228 | (if is-beh-coh-context | |
| 229 | (progn | |
| 230 | (set-color sub nil)) | |
| 231 | (progn | |
| 232 | (setq i-am-red t) | |
| 233 | (set-color sub :red))) | |
| 234 | ;; | |
| 235 | (set-color sub nil))) | |
| 236 | (if i-am-red | |
| 237 | (term-set-red term) | |
| 238 | (term-set-green term))))) | |
| 239 | )) ; end labels | |
| 240 | 240 | ;; |
| 241 | 241 | (unless (or *beh-rewrite* *rewrite-semantic-reduce*) |
| 242 | 242 | (return-from set-term-color term)) |
| 250 | 250 | |
| 251 | 251 | ;;; CHECK BEHAVIOURAL CONTEXT |
| 252 | 252 | |
| 253 | #|| | |
| 254 | (defun check-beh-context (rule target-term) | |
| 255 | (declare (ignore rule)) | |
| 256 | (or (not (term-is-red target-term)) | |
| 257 | (and *beh-rewrite* | |
| 258 | (eq $$term target-term)))) | |
| 259 | ||
| 260 | 253 | (defmacro beh-context-ok? (rule term) |
| 261 | 254 | `(if (axiom-is-behavioural ,rule) |
| 262 | (check-beh-context ,rule ,term) | |
| 263 | t)) | |
| 264 | ||
| 265 | ||# | |
| 266 | ||
| 267 | (defmacro beh-context-ok? (rule term) | |
| 268 | `(if (axiom-is-behavioural ,rule) | |
| 269 | (or (not (term-is-red ,term)) | |
| 270 | (and *beh-rewrite* | |
| 271 | (eq $$term ,term))) | |
| 255 | (or (not (term-is-red ,term)) | |
| 256 | (and *beh-rewrite* | |
| 257 | (eq $$term ,term))) | |
| 272 | 258 | t)) |
| 273 | 259 | |
| 274 | 260 | (declaim (inline apply-rules-with-same-top apply-rules-with-different-top)) |
| 275 | 261 | |
| 276 | 262 | ;;; ---------------------------------------- |
| 277 | 263 | ;;; BASIC PROCS for REWRITE RULE APPLICATION |
| 278 | ||
| 279 | (defmacro term-replace-with-memo (old new) | |
| 280 | (once-only (old new) | |
| 281 | ` (if (and (not (term-is-builtin-constant? ,old)) | |
| 282 | (or *always-memo* | |
| 283 | (method-has-memo (term-head ,old)))) | |
| 284 | (progn | |
| 285 | (set-hashed-term (simple-copy-term ,old) *term-memo-table* ,new) | |
| 286 | (term-replace ,old ,new)) | |
| 287 | (term-replace ,old ,new)))) | |
| 264 | (defvar *memo-debug* nil) | |
| 288 | 265 | |
| 289 | 266 | (declaim (inline term-replace-dd-simple)) |
| 290 | 267 | #-gcl |
| 291 | 268 | (defun term-replace-dd-simple (old new) |
| 292 | 269 | (declare (type term old new) |
| 293 | (values term-body)) | |
| 270 | (values term-body)) | |
| 294 | 271 | (incf *rule-count*) |
| 295 | 272 | (term-replace old new)) |
| 296 | 273 | |
| 299 | 276 | (incf *rule-count*) |
| 300 | 277 | (term-replace old new)) |
| 301 | 278 | |
| 302 | #|| | |
| 303 | (defun apply-one-rule-simple (rule term) | |
| 304 | (declare (type axiom rule) | |
| 305 | (type term term) | |
| 306 | (values (or null t))) | |
| 307 | #|| | |
| 308 | (when (rule-non-exec rule) | |
| 309 | (return-from apply-one-rule-simple nil)) | |
| 310 | ||# | |
| 311 | ;; ________ | |
| 312 | #|| | |
| 313 | (when (and *rewrite-debug* (err-sort-p (term-sort term))) | |
| 314 | (format t "~&..ERR_TERM: ") | |
| 315 | (term-print-with-sort term)) | |
| 316 | ||# | |
| 317 | ;; ________ | |
| 318 | (setq *cafein-current-rule* rule) | |
| 319 | ;; | |
| 320 | (let ((applied nil)) | |
| 321 | (setq applied | |
| 322 | (block the-end | |
| 323 | (let* ((condition nil) | |
| 324 | (next-match-method nil) | |
| 325 | (*self* term) | |
| 326 | (builtin-failure nil)) | |
| 327 | #|| | |
| 328 | (when *m-pattern-subst* | |
| 329 | (term-replace-dd-simple | |
| 330 | term | |
| 331 | (set-term-color | |
| 332 | (substitution-image-simplifying *m-pattern-subst* | |
| 333 | term | |
| 334 | (rule-need-copy rule)))) | |
| 335 | (when *rewrite-debug* | |
| 336 | (format t "~&[applied *m-pattern-subst*]") | |
| 337 | (print-substitution *m-pattern-subst*) | |
| 338 | (format t "--> ") | |
| 339 | (term-print-with-sort term))) | |
| 340 | ||# | |
| 341 | (multiple-value-bind (global-state subst no-match E-equal) | |
| 342 | (funcall (rule-first-match-method rule) (rule-lhs rule) term) | |
| 343 | (incf $$matches) | |
| 344 | (when no-match (return-from the-end nil)) | |
| 345 | ||
| 346 | ;; check behavioural context. | |
| 347 | (unless (beh-context-ok? rule term) | |
| 348 | (return-from the-end nil)) | |
| 349 | ||
| 350 | ;; technical assignation related to substitution-image. | |
| 351 | (when E-equal (setq subst nil)) | |
| 352 | ||
| 353 | ;; match success | |
| 354 | ;; check the rule condition: | |
| 355 | (setq condition (rule-condition rule)) | |
| 356 | (when (and (is-true? condition) | |
| 357 | (null (rule-id-condition rule))) | |
| 358 | ;; no condition, i.e. condition = true | |
| 359 | (setq builtin-failure | |
| 360 | (catch 'rule-failure | |
| 361 | (progn | |
| 362 | ;; there is no condition -- | |
| 363 | ;; rewrite term. | |
| 364 | (term-replace-dd-simple | |
| 365 | term | |
| 366 | ;; NOTE that the computation of the substitution | |
| 367 | ;; made a copy of the rhs. | |
| 368 | ;; NOTE also, subst... may throw 'rule-failure | |
| 369 | ;; with non-nil value meaning failure of applying built-in rule. | |
| 370 | (set-term-color | |
| 371 | (substitution-image-simplifying subst | |
| 372 | (rule-rhs rule) | |
| 373 | (rule-need-copy rule)))) | |
| 374 | ;; return with success | |
| 375 | (return-from the-end t))))) | |
| 376 | ;; | |
| 377 | (setq next-match-method (rule-next-match-method rule)) | |
| 378 | ;; | |
| 379 | (when builtin-failure | |
| 380 | ;; this means that the term contains some variables: | |
| 381 | ;; if we are lucky, we may find a successful match. | |
| 382 | (loop | |
| 383 | (multiple-value-setq (global-state subst no-match) | |
| 384 | (progn | |
| 385 | (incf $$matches) | |
| 386 | (funcall next-match-method global-state))) | |
| 387 | (when no-match | |
| 388 | ;; no hope | |
| 389 | (return-from the-end nil)) | |
| 390 | ;; | |
| 391 | ;; ok try another case: | |
| 392 | (catch 'rule-failure | |
| 393 | (term-replace-dd-simple | |
| 394 | term | |
| 395 | (set-term-color | |
| 396 | (substitution-image-simplifying subst | |
| 397 | (rule-rhs rule) | |
| 398 | (rule-need-copy rule)))) | |
| 399 | ;; good! | |
| 400 | (return-from the-end t)))) | |
| 401 | ||
| 402 | ;; this is the case for non-simple condition: | |
| 403 | ;; if the condition is not trivial, we enter in a loop | |
| 404 | ;; where one try to find a match such that the condition | |
| 405 | ;; is satisfied. | |
| 406 | ;; (setq next-match-method (rule-next-match-method rule)) | |
| 407 | (loop | |
| 408 | (when (and *condition-trial-limit* | |
| 409 | (> $$trials *condition-trial-limit*)) | |
| 410 | (with-output-chaos-warning () | |
| 411 | (format t "~&Infinite loop? Evaluating rule condition, exceeds trial limit: ~d" $$trials) | |
| 412 | (format t "~%terminates rewriting: ") | |
| 413 | (term-print $$term)) | |
| 414 | (chaos-error 'too-deep)) | |
| 415 | ;; | |
| 416 | (catch 'rule-failure | |
| 417 | (when (and (or (null (rule-id-condition rule)) | |
| 418 | (rule-eval-id-condition subst | |
| 419 | (rule-id-condition rule))) | |
| 420 | (is-true? (let (($$cond (set-term-color | |
| 421 | (substitution-image-cp subst condition))) | |
| 422 | (*rewrite-exec-mode* | |
| 423 | (if *rewrite-exec-condition* | |
| 424 | *rewrite-exec-mode* | |
| 425 | nil)) | |
| 426 | ($$trials (1+ $$trials))) | |
| 427 | ;; | |
| 428 | (when *rewrite-debug* | |
| 429 | (princ "[COND] ") | |
| 430 | (term-print $$cond)) | |
| 431 | ;; no simplyfing since probably wouldn't pay | |
| 432 | (normalize-term $$cond) | |
| 433 | ;; := | |
| 434 | ;;#|| | |
| 435 | (when *m-pattern-subst* | |
| 436 | (setq subst (append *m-pattern-subst* subst)) | |
| 437 | (when *rewrite-debug* | |
| 438 | (format t "~&[subst+] ") | |
| 439 | (print-substitution subst) | |
| 440 | (format t "~&[subst-updated] ") | |
| 441 | (print-substitution subst))) | |
| 442 | ;;||# | |
| 443 | ;; | |
| 444 | $$cond))) | |
| 445 | ;; the condition is satisfied | |
| 446 | (progn | |
| 447 | #|| | |
| 448 | (when *m-pattern-subst* | |
| 449 | (setq subst (append *m-pattern-subst* subst)) | |
| 450 | (when *rewrite-debug* | |
| 451 | (format t "~&[m+s4] ") | |
| 452 | (print-substitution subst))) | |
| 453 | ||# | |
| 454 | (when *rewrite-debug* | |
| 455 | (format *error-output* "~&SUBST:") | |
| 456 | (print-substitution subst)) | |
| 457 | (term-replace-dd-simple | |
| 458 | term | |
| 459 | (set-term-color | |
| 460 | (substitution-image-simplifying subst | |
| 461 | (rule-rhs rule) | |
| 462 | (rule-need-copy rule)))) | |
| 463 | ;; successful return | |
| 464 | ;; (setq *m-pattern-subst* nil) | |
| 465 | (return-from the-end t)))) | |
| 466 | ;; else, try another ... | |
| 467 | (multiple-value-setq (global-state subst no-match) | |
| 468 | (progn | |
| 469 | (incf $$matches) | |
| 470 | (funcall next-match-method global-state))) | |
| 471 | ;; | |
| 472 | (when (or no-match | |
| 473 | (not (beh-context-ok? rule term))) | |
| 474 | (return-from the-end nil)) | |
| 475 | ) ; end loop | |
| 476 | )))) | |
| 477 | ;; | |
| 478 | (setq *m-pattern-subst* nil) | |
| 479 | applied)) | |
| 480 | ||# | |
| 279 | (declaim (special *m-pattern-subst* $$cond)) | |
| 280 | (defvar *m-pat-debug* nil) | |
| 481 | 281 | |
| 482 | 282 | (defun !apply-one-rule (rule term &aux (applied nil)) |
| 483 | 283 | (declare (type axiom rule) |
| 491 | 291 | |
| 492 | 292 | ;; apply rule |
| 493 | 293 | (setq *cafein-current-rule* rule) |
| 494 | ;; | |
| 294 | ;; before rewriting, check if := matching has been done in this context | |
| 495 | 295 | (when (and *m-pattern-subst* $$cond) |
| 496 | 296 | (let ((nt (set-term-color |
| 497 | (substitution-image-simplifying *m-pattern-subst* | |
| 498 | term | |
| 499 | (rule-need-copy rule))))) | |
| 297 | (substitution-image-simplifying *m-pattern-subst* | |
| 298 | term | |
| 299 | (rule-need-copy rule))))) | |
| 300 | ;; substitute variables in the current target with subst obtained by := match. | |
| 500 | 301 | (term-replace term nt) |
| 501 | (when *rewrite-debug* | |
| 502 | (format t "~&[applied *m-pattern-subst*]") | |
| 503 | (print-substitution *m-pattern-subst*) | |
| 504 | (format t "--> ") | |
| 505 | (term-print-with-sort term)))) | |
| 506 | ;; | |
| 507 | (setq applied | |
| 302 | (when *m-pat-debug* | |
| 303 | (format t "~&[applied *m-pattern-subst*]") | |
| 304 | (print-substitution *m-pattern-subst*) | |
| 305 | (format t "--> ") | |
| 306 | (term-print-with-sort term)))) | |
| 307 | ;; start rewriting | |
| 308 | (setq applied ; will be t iff a rewrite rule is applied | |
| 508 | 309 | (block the-end |
| 509 | 310 | (let* ((condition nil) |
| 510 | (cur-trial nil) | |
| 511 | (next-match-method nil) | |
| 512 | (*trace-level* (1+ *trace-level*)) | |
| 513 | (*print-indent* *print-indent*) | |
| 514 | (*self* term) | |
| 515 | (builtin-failure nil) | |
| 516 | (rhs-instance nil)) | |
| 517 | #|| | |
| 518 | (when *rewrite-debug* | |
| 519 | (format t "~&+rule-first-match-method=~a" (rule-first-match-method rule))) | |
| 520 | ||# | |
| 521 | (multiple-value-bind (global-state subst no-match E-equal) | |
| 522 | (funcall (rule-first-match-method rule) (rule-lhs rule) term) | |
| 523 | (incf $$matches) | |
| 524 | (setq *cafein-current-subst* subst) | |
| 525 | (when no-match (return-from the-end nil)) | |
| 526 | ;; | |
| 527 | (unless (beh-context-ok? rule term) | |
| 528 | (return-from the-end nil)) | |
| 529 | ||
| 530 | ;; technical assignation related to substitution-image. | |
| 531 | (when E-equal (setq subst nil)) | |
| 532 | ;; match success | |
| 533 | ;; then, the condition must be checked | |
| 534 | (setq condition (rule-condition rule)) | |
| 535 | (when (and (is-true? condition) | |
| 536 | (null (rule-id-condition rule))) | |
| 537 | (setq builtin-failure | |
| 538 | (catch 'rule-failure | |
| 539 | ;; there is no condition -- | |
| 540 | ;; rewrite term. | |
| 541 | (when (or $$trace-rewrite | |
| 542 | (rule-trace-flag rule)) | |
| 543 | (let ((*print-with-sort* t)) | |
| 544 | (print-trace-in) | |
| 545 | (princ "rule: ") | |
| 546 | (let ((*print-indent* (+ 2 *print-indent*))) | |
| 547 | (print-axiom-brief rule)) | |
| 548 | (let ((*print-indent* (+ 4 *print-indent*))) | |
| 549 | (print-next) | |
| 550 | (print-substitution subst)))) | |
| 551 | ;; note that the computation of the substitution | |
| 552 | ;; made a copy of the rhs. | |
| 553 | (setq rhs-instance (set-term-color | |
| 554 | (substitution-image-simplifying subst | |
| 555 | (rule-rhs rule) | |
| 556 | (rule-need-copy rule)))) | |
| 557 | (if .trace-or-step. | |
| 558 | (term-replace-dd-dbg term rhs-instance) | |
| 559 | (term-replace-dd-simple term rhs-instance)) | |
| 560 | (return-from the-end t)))) | |
| 561 | ;; | |
| 562 | (setq next-match-method (rule-next-match-method rule)) | |
| 563 | ;; | |
| 564 | (when builtin-failure | |
| 565 | ;; this means that the term contains some variables: | |
| 566 | ;; if we are lucky, we may find a successful match. | |
| 567 | (loop | |
| 568 | (when (or $$trace-rewrite | |
| 569 | (rule-trace-flag rule)) | |
| 570 | (with-output-msg () | |
| 571 | (format t "!! built in rule failed !!"))) | |
| 572 | ;; | |
| 573 | (multiple-value-setq (global-state subst no-match) | |
| 574 | (progn | |
| 575 | (incf $$matches) | |
| 576 | (funcall next-match-method global-state))) | |
| 577 | (when no-match | |
| 578 | ;; no hope | |
| 579 | (return-from the-end nil)) | |
| 580 | ;; | |
| 581 | (setq *cafein-current-subst* subst) | |
| 582 | (setq cur-trial $$trials) | |
| 583 | (when (or $$trace-rewrite | |
| 584 | (rule-trace-flag rule)) | |
| 585 | (let ((*print-with-sort* t)) | |
| 586 | (print-trace-in) | |
| 587 | (princ "-- rule: ") | |
| 588 | (let ((*print-indent* (+ 2 *print-indent*))) | |
| 589 | (print-axiom-brief rule)) | |
| 590 | (let ((*print-indent* (+ 4 *print-indent*))) | |
| 591 | (print-next) | |
| 592 | (print-substitution subst)) | |
| 593 | (force-output))) | |
| 594 | ;; | |
| 595 | (catch 'rule-failure | |
| 596 | (setq rhs-instance (set-term-color | |
| 597 | (substitution-image-simplifying subst | |
| 598 | (rule-rhs rule) | |
| 599 | (rule-need-copy rule)))) | |
| 600 | (if .trace-or-step. | |
| 601 | (term-replace-dd-dbg term rhs-instance) | |
| 602 | (term-replace-dd-simple term rhs-instance)) | |
| 603 | (return-from the-end t)))) | |
| 604 | ||
| 605 | ;; if the condition is not trivial, we enter in a loop | |
| 606 | ;; where one try to find a match such that the condition | |
| 607 | ;; is satisfied. | |
| 608 | (loop | |
| 609 | ;; | |
| 610 | (when (and *condition-trial-limit* | |
| 611 | (>= $$trials *condition-trial-limit*)) | |
| 612 | (with-output-chaos-warning () | |
| 613 | (format t "~&Infinite loop? Evaluating rule condition, exceeds trial limit ~d" $$trials) | |
| 614 | (format t "~%terminates rewriting: ") | |
| 615 | (term-print $$term)) | |
| 616 | (chaos-error 'too-deep)) | |
| 617 | ;; | |
| 618 | (setq *cafein-current-subst* subst) | |
| 619 | (setq cur-trial $$trials) | |
| 620 | ;; | |
| 621 | (when (or $$trace-rewrite | |
| 622 | (rule-trace-flag rule)) | |
| 623 | (let ((*print-with-sort* t)) | |
| 624 | (print-trace-in) | |
| 625 | (format t "apply trial #~D" cur-trial) | |
| 626 | (print-next) | |
| 627 | (princ "-- rule: ") | |
| 628 | (let ((*print-indent* (+ 2 *print-indent*))) | |
| 629 | (print-axiom-brief rule)) | |
| 630 | (let ((*print-indent* (+ 4 *print-indent*))) | |
| 631 | (print-next) | |
| 632 | (print-substitution subst)) | |
| 633 | (force-output))) | |
| 634 | (catch 'rule-failure | |
| 635 | (when (and (or (null (rule-id-condition rule)) | |
| 636 | (rule-eval-id-condition subst | |
| 637 | (rule-id-condition rule))) | |
| 638 | (is-true? | |
| 639 | (let (($$cond (set-term-color | |
| 640 | (substitution-image-cp subst condition))) | |
| 641 | (*rewrite-exec-mode* | |
| 642 | (if *rewrite-exec-condition* | |
| 643 | *rewrite-exec-mode* | |
| 644 | nil)) | |
| 645 | ($$trials (1+ $$trials))) | |
| 646 | ;; no simplyfing since probably wouldn't pay | |
| 647 | (normalize-term $$cond) | |
| 648 | ;; := | |
| 649 | (when *m-pattern-subst* | |
| 650 | (dolist (sub *m-pattern-subst*) | |
| 651 | (push sub subst)) | |
| 652 | (when *rewrite-debug* | |
| 653 | (format t "~&[subst-+] ") | |
| 654 | (print-substitution *m-pattern-subst*) | |
| 655 | (format t "~&[subst-updated] ") | |
| 656 | (print-substitution subst))) | |
| 657 | $$cond))) | |
| 658 | ;; the condition is satisfied | |
| 659 | (when (or $$trace-rewrite | |
| 660 | (rule-trace-flag rule)) | |
| 661 | (print-trace-in) | |
| 662 | (format t "match success #~D" cur-trial)) | |
| 663 | (setq rhs-instance (set-term-color | |
| 664 | (substitution-image-simplifying subst | |
| 665 | (rule-rhs rule) | |
| 666 | (rule-need-copy rule)))) | |
| 667 | (if .trace-or-step. | |
| 668 | (term-replace-dd-dbg term rhs-instance) | |
| 669 | (term-replace-dd-simple term rhs-instance)) | |
| 670 | (return-from the-end t))) | |
| 671 | ||
| 672 | ;; else, try another ... | |
| 673 | (multiple-value-setq (global-state subst no-match) | |
| 674 | (progn | |
| 675 | (incf $$matches) | |
| 676 | (funcall next-match-method global-state))) | |
| 677 | (when no-match | |
| 678 | (when (or $$trace-rewrite | |
| 679 | (rule-trace-flag rule)) | |
| 680 | (print-trace-in) | |
| 681 | (format t "rewrite rule exhausted (#~D)" cur-trial) | |
| 682 | (force-output)) | |
| 683 | (return)) | |
| 684 | ;; | |
| 685 | (unless (beh-context-ok? rule term) | |
| 686 | (return-from the-end nil)) | |
| 687 | ) ; end loop | |
| 688 | )))) ; end of main process | |
| 311 | (cur-trial nil) | |
| 312 | (next-match-method nil) | |
| 313 | (*trace-level* (1+ *trace-level*)) | |
| 314 | (*print-indent* *print-indent*) | |
| 315 | (*self* term) | |
| 316 | (builtin-failure nil) | |
| 317 | (rhs-instance nil)) | |
| 318 | (multiple-value-bind (global-state subst no-match E-equal) | |
| 319 | ;; first we find matching rewrite rule | |
| 320 | (funcall (or (rule-first-match-method rule) | |
| 321 | (progn | |
| 322 | (when *chaos-verbose* | |
| 323 | (with-output-chaos-warning () | |
| 324 | (format t "Internal, no 'matching-mehod' is assigned for:") | |
| 325 | (print-next) | |
| 326 | (print-axiom-brief rule))) | |
| 327 | (compute-rule-method rule) | |
| 328 | (rule-first-match-method rule))) | |
| 329 | (rule-lhs rule) | |
| 330 | term) | |
| 331 | ;; stat, count up number of matching trials | |
| 332 | (incf $$matches) | |
| 333 | (setq *cafein-current-subst* subst) ; I don't remember for what this is used | |
| 334 | ;; if matching fail no hope to rewriting. | |
| 335 | (when no-match (return-from the-end nil)) | |
| 336 | ;; | |
| 337 | (unless (beh-context-ok? rule term) | |
| 338 | (return-from the-end nil)) | |
| 339 | ||
| 340 | ;; technical assignation related to substitution-image. | |
| 341 | (when E-equal (setq subst nil)) | |
| 342 | ;; match success with LHS of the rewrite rule. | |
| 343 | ;; next we check condition part of the rewrite rule. | |
| 344 | (setq condition (rule-condition rule)) | |
| 345 | (when (and (is-true? condition) | |
| 346 | (null (rule-id-condition rule))) | |
| 347 | ;; the case of non-conditional rule. | |
| 348 | ;; we generate an instance of RHS of the rule. | |
| 349 | (setq builtin-failure ; will be t iff there occured an error | |
| 350 | ; in making instance of RHS with builtin lisp form. | |
| 351 | (catch 'rule-failure | |
| 352 | ;; there is no condition -- | |
| 353 | ;; rewrite term. | |
| 354 | ||
| 355 | ;; handle trace | |
| 356 | (when (or $$trace-rewrite | |
| 357 | (rule-trace-flag rule)) | |
| 358 | (let ((*print-with-sort* t)) | |
| 359 | (print-trace-in) | |
| 360 | (princ "rule: ") | |
| 361 | (let ((*print-indent* (+ 2 *print-indent*))) | |
| 362 | (print-axiom-brief rule)) | |
| 363 | (let ((*print-indent* (+ 4 *print-indent*))) | |
| 364 | (print-next) | |
| 365 | (print-substitution subst)))) | |
| 366 | ;; note that the computation of the substitution | |
| 367 | ;; made a copy of the rhs. | |
| 368 | (setq rhs-instance (set-term-color | |
| 369 | (substitution-image-simplifying subst | |
| 370 | (rule-rhs rule) | |
| 371 | (rule-need-copy rule)))) | |
| 372 | ;; rewrite the term with the instance of RHS. | |
| 373 | (if .trace-or-step. | |
| 374 | (term-replace-dd-dbg term rhs-instance) | |
| 375 | (term-replace-dd-simple term rhs-instance)) | |
| 376 | ;; successfull rewriting. | |
| 377 | (return-from the-end t)))) | |
| 378 | ||
| 379 | ;; We come here either catching an error with builtin rule | |
| 380 | ;; or, the target rewrite rule is conditional. | |
| 381 | ;; both case need trying different mathing if exists | |
| 382 | (setq next-match-method (rule-next-match-method rule)) | |
| 383 | (when builtin-failure | |
| 384 | ;; this means that the term contains some variables: | |
| 385 | ;; if we are lucky, we may find a successful match. | |
| 386 | (loop | |
| 387 | (when (or $$trace-rewrite | |
| 388 | (rule-trace-flag rule)) | |
| 389 | (with-output-msg () | |
| 390 | (format t "!! built in rule failed !!"))) | |
| 391 | ;; | |
| 392 | (multiple-value-setq (global-state subst no-match) | |
| 393 | (progn | |
| 394 | (incf $$matches) | |
| 395 | (funcall next-match-method global-state))) | |
| 396 | (when no-match | |
| 397 | ;; no more match, we failed | |
| 398 | (return-from the-end nil)) | |
| 399 | ;; found another match, try rewrite with this | |
| 400 | (setq *cafein-current-subst* subst) ; what is this... | |
| 401 | (setq cur-trial $$trials) | |
| 402 | (when (or $$trace-rewrite | |
| 403 | (rule-trace-flag rule)) | |
| 404 | (let ((*print-with-sort* t)) | |
| 405 | (print-trace-in) | |
| 406 | (princ "-- rule: ") | |
| 407 | (let ((*print-indent* (+ 2 *print-indent*))) | |
| 408 | (print-axiom-brief rule)) | |
| 409 | (let ((*print-indent* (+ 4 *print-indent*))) | |
| 410 | (print-next) | |
| 411 | (print-substitution subst)) | |
| 412 | (force-output))) | |
| 413 | ;; | |
| 414 | (catch 'rule-failure | |
| 415 | (setq rhs-instance (set-term-color | |
| 416 | (substitution-image-simplifying subst | |
| 417 | (rule-rhs rule) | |
| 418 | (rule-need-copy rule)))) | |
| 419 | (if .trace-or-step. | |
| 420 | (term-replace-dd-dbg term rhs-instance) | |
| 421 | (term-replace-dd-simple term rhs-instance)) | |
| 422 | (return-from the-end t)))) | |
| 423 | ||
| 424 | ;; here is the case of conditional rule. | |
| 425 | ;; if the condition is not trivial, we enter in a loop | |
| 426 | ;; where one try to find a match such that the condition | |
| 427 | ;; is satisfied. | |
| 428 | (loop | |
| 429 | ;; | |
| 430 | (when (and *condition-trial-limit* | |
| 431 | (>= $$trials *condition-trial-limit*)) | |
| 432 | (with-output-chaos-warning () | |
| 433 | (format t "~%Infinite loop? Evaluating rule condition, exceeds trial limit ~d" $$trials) | |
| 434 | (format t "~&terminates rewriting: ") | |
| 435 | (term-print $$term)) | |
| 436 | (chaos-error 'too-deep)) | |
| 437 | ;; | |
| 438 | (setq *cafein-current-subst* subst) | |
| 439 | (setq cur-trial $$trials) | |
| 440 | (when (= 1 cur-trial) (setq *m-pattern-subst* nil)) ; !! | |
| 441 | (when (or $$trace-rewrite | |
| 442 | (rule-trace-flag rule)) | |
| 443 | (let ((*print-with-sort* t)) | |
| 444 | (print-trace-in) | |
| 445 | (format t "apply trial #~D" cur-trial) | |
| 446 | (print-next) | |
| 447 | (princ "-- rule: ") | |
| 448 | (let ((*print-indent* (+ 2 *print-indent*))) | |
| 449 | (print-axiom-brief rule)) | |
| 450 | (let ((*print-indent* (+ 4 *print-indent*))) | |
| 451 | (print-next) | |
| 452 | (print-substitution subst)) | |
| 453 | (force-output))) | |
| 454 | (catch 'rule-failure | |
| 455 | (when (and (or (null (rule-id-condition rule)) | |
| 456 | (rule-eval-id-condition subst | |
| 457 | (rule-id-condition rule))) | |
| 458 | (is-true? | |
| 459 | (let (($$cond (set-term-color | |
| 460 | (substitution-image-cp subst condition))) | |
| 461 | (*rewrite-exec-mode* | |
| 462 | (if *rewrite-exec-condition* | |
| 463 | *rewrite-exec-mode* | |
| 464 | nil)) | |
| 465 | ($$trials (1+ $$trials))) | |
| 466 | ;; no simplyfing since probably wouldn't pay | |
| 467 | (normalize-term $$cond) | |
| 468 | ;; := | |
| 469 | (when *m-pattern-subst* | |
| 470 | (dolist (sub *m-pattern-subst*) | |
| 471 | (push sub subst)) | |
| 472 | (when *m-pat-debug* | |
| 473 | (format t "~%[subst-+] ") | |
| 474 | (print-substitution *m-pattern-subst*) | |
| 475 | (format t "~&[subst-updated] ") | |
| 476 | (print-substitution subst))) | |
| 477 | $$cond))) | |
| 478 | ;; the condition is satisfied | |
| 479 | (when (or $$trace-rewrite | |
| 480 | (rule-trace-flag rule)) | |
| 481 | (print-trace-in) | |
| 482 | (format t "match success #~D" cur-trial)) | |
| 483 | (setq rhs-instance (set-term-color | |
| 484 | (substitution-image-simplifying subst | |
| 485 | (rule-rhs rule) | |
| 486 | (rule-need-copy rule)))) | |
| 487 | (if .trace-or-step. | |
| 488 | (term-replace-dd-dbg term rhs-instance) | |
| 489 | (term-replace-dd-simple term rhs-instance)) | |
| 490 | (return-from the-end t))) | |
| 491 | ||
| 492 | ;; else, try another ... | |
| 493 | (multiple-value-setq (global-state subst no-match) | |
| 494 | (progn | |
| 495 | (incf $$matches) | |
| 496 | (funcall next-match-method global-state))) | |
| 497 | (when no-match | |
| 498 | (when (or $$trace-rewrite | |
| 499 | (rule-trace-flag rule)) | |
| 500 | (print-trace-in) | |
| 501 | (format t "rewrite rule exhausted (#~D)" cur-trial) | |
| 502 | (force-output)) | |
| 503 | (return)) | |
| 504 | ;; | |
| 505 | (unless (beh-context-ok? rule term) | |
| 506 | (return-from the-end nil)) | |
| 507 | ) ; end loop | |
| 508 | )))) ; end of main process | |
| 689 | 509 | ;; |
| 690 | 510 | (unless $$cond |
| 511 | ;; we reset := substitution | |
| 691 | 512 | (setq *m-pattern-subst* nil)) |
| 692 | 513 | ;; |
| 693 | 514 | (if applied |
| 703 | 524 | nil))) |
| 704 | 525 | |
| 705 | 526 | (defun term-replace-dd-dbg (old new) |
| 706 | (declare (type term old new) | |
| 707 | ;;(values term) | |
| 708 | ) | |
| 709 | ;; | |
| 527 | (declare (type term old new)) | |
| 528 | ;; stat number of rewriting | |
| 710 | 529 | (incf *rule-count*) |
| 711 | ||
| 530 | ;; check if given stop pattern was matched to the resultant term. | |
| 712 | 531 | (when *matched-to-stop-pattern* |
| 532 | ;; yes | |
| 713 | 533 | (unless *rewrite-stepping* |
| 714 | 534 | (setq *matched-to-stop-pattern* nil) |
| 715 | 535 | (throw 'rewrite-abort $$term))) |
| 727 | 547 | (term-print-with-sort old) |
| 728 | 548 | (print-check 0 5) |
| 729 | 549 | (princ " --> ") |
| 730 | ;; (print-check) | |
| 731 | 550 | (term-print-with-sort new)) |
| 732 | 551 | (unless $$trace-rewrite-whole (terpri)))) |
| 733 | 552 | ;; trace whole |
| 759 | 578 | ;; (print-check) |
| 760 | 579 | (term-print-with-sort $$term)) |
| 761 | 580 | res)))) |
| 581 | ;; after tracing, we finally rewrite the target | |
| 762 | 582 | (term-replace old new)) |
| 763 | ;; | |
| 764 | 583 | ;; check rewrite count limit |
| 765 | 584 | (when (and *rewrite-count-limit* |
| 766 | 585 | (<= *rewrite-count-limit* *rule-count*)) |
| 767 | (format *error-output* "~&>> aborting rewrite due to rewrite count limit (= ~d) <<" | |
| 586 | (format *error-output* "~%>> aborting rewrite due to rewrite count limit (= ~d) <<" | |
| 768 | 587 | *rewrite-count-limit*) |
| 769 | 588 | (throw 'rewrite-abort $$term)) |
| 770 | 589 | ;; |
| 771 | 590 | $$term) |
| 772 | ||
| 773 | ;;; | |
| 774 | ;;; | |
| 775 | ;;; | |
| 776 | #|| | |
| 777 | (defun apply-rules-with-same-top (term rule-ring) | |
| 778 | (declare (type term term) | |
| 779 | (type rule-ring rule-ring) | |
| 780 | (values (or null t))) | |
| 781 | (let ((rr-ring (rule-ring-ring rule-ring)) | |
| 782 | applied | |
| 783 | flg) | |
| 784 | (when rr-ring | |
| 785 | (loop (let ((rr-current rr-ring) | |
| 786 | (rr-mark rr-ring) | |
| 787 | rule) | |
| 788 | (setq applied nil) | |
| 789 | (loop (setq rule (car rr-current)) | |
| 790 | (when (apply-rule rule term) | |
| 791 | (setq applied (or applied t) | |
| 792 | rr-mark rr-current) | |
| 793 | (loop (unless (apply-rule rule term) (return nil)))) | |
| 794 | (setq rr-current (cdr rr-current)) | |
| 795 | (when (eq rr-current rr-mark) (return nil))) | |
| 796 | (setq flg nil) | |
| 797 | (dolist (sub (term-subterms term)) | |
| 798 | (setq flg (not (normalize-term sub))) | |
| 799 | (setq applied (or applied flg))) | |
| 800 | (unless applied (return-from apply-rules-with-same-top nil)) | |
| 801 | ))))) | |
| 802 | ||# | |
| 803 | 591 | |
| 804 | 592 | (defun apply-rules-with-same-top (term rule-ring) |
| 805 | 593 | (declare (type term term) |
| 811 | 599 | rule) |
| 812 | 600 | (loop |
| 813 | 601 | (setq rule (car rr-current)) |
| 814 | (when (apply-rule rule term) | |
| 815 | (setq rr-mark rr-current) | |
| 816 | (loop (unless (apply-rule rule term) (return nil)))) | |
| 817 | (setq rr-current (cdr rr-current)) | |
| 818 | (when (eq rr-current rr-mark) (return nil))))))) | |
| 819 | ||
| 820 | ;;; | |
| 821 | ;;; | |
| 602 | (unless (eq (axiom-kind rule) :bad-rule) | |
| 603 | (when (apply-rule rule term) | |
| 604 | (setq rr-mark rr-current) | |
| 605 | (loop (unless (apply-rule rule term) (return nil)))) | |
| 606 | (setq rr-current (cdr rr-current)) | |
| 607 | (when (eq rr-current rr-mark) (return nil)))))))) | |
| 608 | ||
| 822 | 609 | (defun apply-rules-with-different-top (term rules) |
| 823 | 610 | (declare (type term term) |
| 824 | 611 | (type list rules) |
| 825 | 612 | (values (or null t))) |
| 826 | 613 | (block the-end |
| 827 | 614 | (dolist (rule rules nil) |
| 828 | (when (apply-rule rule term) (return-from the-end t))))) | |
| 615 | (unless (eq (axiom-kind rule) :bad-rule) | |
| 616 | (when (apply-rule rule term) (return-from the-end t)))))) | |
| 829 | 617 | |
| 830 | 618 | (defun apply-rules (term strategy) |
| 831 | 619 | (declare (type term term) |
| 832 | 620 | (type list strategy) |
| 833 | 621 | (values (or null t))) |
| 834 | 622 | (labels ((apply-rules-internal () |
| 835 | (let ((top nil)) | |
| 836 | (unless (term-is-lowest-parsed? term) (update-lowest-parse term)) | |
| 837 | (setq top (term-head term)) | |
| 838 | ;; apply same top rules | |
| 839 | (apply-rules-with-same-top term (method-rules-with-same-top top)) | |
| 840 | ;; | |
| 841 | (if (not (eq top (term-head term))) | |
| 842 | (progn | |
| 843 | (mark-term-as-not-lowest-parsed term) | |
| 844 | (normalize-term term)) | |
| 845 | (if (apply-rules-with-different-top term | |
| 846 | (method-rules-with-different-top top)) | |
| 847 | (progn | |
| 848 | (mark-term-as-not-lowest-parsed term) | |
| 849 | (normalize-term term)) | |
| 850 | (reduce-term term (cdr strategy))))))) | |
| 623 | (let ((top nil)) | |
| 624 | ;; (unless (term-is-lowest-parsed? term) (update-lowest-parse term)) | |
| 625 | (setq top (term-head term)) | |
| 626 | ;; apply same top rules | |
| 627 | (apply-rules-with-same-top term (method-rules-with-same-top top)) | |
| 628 | (if (not (eq top (term-head term))) | |
| 629 | (progn | |
| 630 | (mark-term-as-not-lowest-parsed term) | |
| 631 | (normalize-term term)) | |
| 632 | (if (apply-rules-with-different-top term | |
| 633 | (method-rules-with-different-top top)) | |
| 634 | (progn | |
| 635 | (mark-term-as-not-lowest-parsed term) | |
| 636 | (normalize-term term)) | |
| 637 | (reduce-term term (cdr strategy))))))) | |
| 851 | 638 | ;; |
| 852 | 639 | (if *memo-rewrite* |
| 853 | 640 | ;; check memo |
| 1013 | 800 | (setq is-applied |
| 1014 | 801 | (or (apply-A-extensions rule term top) |
| 1015 | 802 | is-applied)) |
| 1016 | )))))) ; end tagbody | |
| 803 | )))))) ; end tagbody | |
| 1017 | 804 | ;; return t iff the rule is applied. |
| 1018 | 805 | is-applied)) |
| 1019 | 806 | |
| 1020 | (defun simplify-on-top (term) | |
| 1021 | (declare (type term term) | |
| 1022 | (values t)) | |
| 1023 | (if (term-is-application-form? term) | |
| 1024 | (apply-rules-with-different-top term | |
| 1025 | (method-rules-with-different-top | |
| 1026 | (term-method term))) | |
| 1027 | term)) | |
| 1028 | ||
| 1029 | ;;; | |
| 1030 | ;;; REWRITE ENGINE | |
| 807 | ;;; | |
| 808 | ;;; REWRITE ENGINE | |
| 1031 | 809 | ;;; |
| 1032 | 810 | |
| 1033 | 811 | ;;; the following procs assumes that the runtime environment is properly set: |
| 1038 | 816 | ;;; REWRITE : TERM -> TERM' ---------------------------------------------------- |
| 1039 | 817 | ;;;----------------------------------------------------------------------------- |
| 1040 | 818 | |
| 1041 | #|| | |
| 1042 | 819 | (defun reduce-term (term strategy) |
| 1043 | 820 | (declare (type term term) |
| 1044 | 821 | (type list strategy) |
| 1045 | 822 | (values (or null t))) |
| 1046 | ;; | |
| 1047 | (when *rewrite-debug* | |
| 1048 | (with-output-simple-msg () | |
| 1049 | (format t "[reduce-term](NF=~a,LP=~a): " (term-is-reduced? term) (term-is-lowest-parsed? term)) | |
| 1050 | (term-print-with-sort term) | |
| 1051 | (format t "~% strat = ~a" strategy))) | |
| 1052 | ;; | |
| 1053 | (let ((occ nil) | |
| 1054 | (top (term-head term)) | |
| 1055 | ;; (*cexec-target* nil) | |
| 1056 | ) | |
| 1057 | (cond ((null strategy) | |
| 1058 | ;; no strat, or exhausted. | |
| 1059 | (unless (term-is-lowest-parsed? term) | |
| 1060 | (update-lowest-parse term) | |
| 1061 | (unless (method= (term-method term) top) | |
| 1062 | (when *rewrite-debug* | |
| 1063 | (with-output-msg () | |
| 1064 | (format t "- resetting reduced flag ..."))) | |
| 1065 | (reset-reduced-flag term) | |
| 1066 | (return-from reduce-term (normalize-term term)))) | |
| 1067 | (unless (or *rewrite-semantic-reduce* | |
| 1068 | *beh-rewrite*) | |
| 1069 | (mark-term-as-reduced term))) | |
| 1070 | ||
| 1071 | ;; whole | |
| 1072 | ((= 0 (the fixnum (setf occ (car strategy)))) | |
| 1073 | (unless (term-is-reduced? term) | |
| 1074 | #|| | |
| 1075 | (when *parse-normalize* | |
| 1076 | (term-replace term | |
| 1077 | (right-associative-normal-form term))) | |
| 1078 | ||# | |
| 1079 | (apply-rules term strategy))) | |
| 1080 | ||
| 1081 | ;; explicit lazy | |
| 1082 | ((< (the fixnum occ) 0) | |
| 1083 | (let ((d-arg (term-arg-n term (1- (abs occ))))) | |
| 1084 | (unless (term-is-reduced? d-arg) (mark-term-as-on-demand d-arg)) | |
| 1085 | (reduce-term term (cdr strategy)))) | |
| 1086 | ||
| 1087 | ;; normal case, reduce specified subterm | |
| 1088 | (t (if (method-is-associative top) | |
| 1089 | (let ((list-subterms (list-assoc-subterms term top)) | |
| 1090 | (lp t)) | |
| 1091 | (dolist (x list-subterms) | |
| 1092 | (unless (normalize-term x) | |
| 1093 | (setq lp nil)) | |
| 1094 | ) | |
| 1095 | (unless lp ; nil | |
| 1096 | (update-lowest-parse term) | |
| 1097 | ) | |
| 1098 | (reduce-term term '(0))) | |
| 1099 | (progn | |
| 1100 | (unless (normalize-term (term-arg-n term (1- occ))) | |
| 1101 | (mark-term-as-not-lowest-parsed term)) | |
| 1102 | (reduce-term term (cdr strategy)))))))) | |
| 1103 | ||# | |
| 1104 | ||
| 1105 | (defun reduce-term (term strategy) | |
| 1106 | (declare (type term term) | |
| 1107 | (type list strategy) | |
| 1108 | (values (or null t))) | |
| 1109 | ;; | |
| 1110 | 823 | (when *rewrite-debug* |
| 1111 | 824 | (with-output-simple-msg () |
| 1112 | 825 | (format t "[reduce-term](NF=~a,LP=~a): " (term-is-reduced? term) (term-is-lowest-parsed? term)) |
| 1118 | 831 | (cond ((null strategy) |
| 1119 | 832 | ;; no strat, or exhausted. |
| 1120 | 833 | (unless (term-is-lowest-parsed? term) |
| 1121 | (update-lowest-parse term) | |
| 1122 | (unless (method= (term-method term) top) | |
| 1123 | (when *rewrite-debug* | |
| 1124 | (with-output-msg () | |
| 1125 | (format t "- resetting reduced flag ..."))) | |
| 834 | (multiple-value-bind (xterm assoc?) | |
| 835 | (update-lowest-parse term) | |
| 836 | (declare (ignore xterm)) | |
| 837 | (when (or assoc? | |
| 838 | (not (method= (term-method term) top))) | |
| 839 | (when *rewrite-debug* | |
| 840 | (with-output-msg () | |
| 841 | (format t "- resetting reduced flag ..."))) | |
| 1126 | 842 | (reset-reduced-flag term) |
| 1127 | (return-from reduce-term (normalize-term term)))) | |
| 843 | (return-from reduce-term (normalize-term term))))) | |
| 1128 | 844 | (unless (or *rewrite-semantic-reduce* |
| 1129 | 845 | *beh-rewrite*) |
| 1130 | 846 | (mark-term-as-reduced term))) |
| 1133 | 849 | ((= 0 (the fixnum (setf occ (car strategy)))) |
| 1134 | 850 | ;; (unless (term-is-reduced? term) |
| 1135 | 851 | (apply-rules term strategy)) |
| 1136 | ;; ) | |
| 852 | ;; ) | |
| 1137 | 853 | |
| 1138 | 854 | ;; explicit lazy |
| 1139 | 855 | ((< (the fixnum occ) 0) |
| 1143 | 859 | |
| 1144 | 860 | ;; normal case, reduce specified subterm |
| 1145 | 861 | (t (unless (normalize-term (term-arg-n term (1- occ))) |
| 1146 | (mark-term-as-not-lowest-parsed term)) | |
| 1147 | (reduce-term term (cdr strategy)))))) | |
| 862 | (mark-term-as-not-lowest-parsed term)) | |
| 863 | (reduce-term term (cdr strategy)))))) | |
| 1148 | 864 | |
| 1149 | 865 | ;;; THE TOP LEVEL ------------------------------------------------------------- |
| 1150 | 866 | ;;; term may be modified. |
| 1172 | 888 | (rwl-state-term |
| 1173 | 889 | (car (rwl-sch-context-answers .rwl-sch-context.)))) |
| 1174 | 890 | (with-output-chaos-error () |
| 1175 | (format t "PANIC!")) | |
| 1176 | )) | |
| 1177 | ) | |
| 1178 | ||
| 891 | (format t "PANIC!"))))) | |
| 1179 | 892 | (otherwise |
| 1180 | 893 | (setq $$trials 1) |
| 1181 | 894 | (when *memo-rewrite* |
| 1184 | 897 | (clear-term-memo-table *term-memo-table*)) |
| 1185 | 898 | (setq *memoized-module* module)) |
| 1186 | 899 | (let ((*trace-level* 0)) |
| 1187 | (setq $$matches 0) | |
| 1188 | (setq *term-memo-hash-hit* 0) | |
| 1189 | 900 | (with-in-module (module) |
| 1190 | 901 | (let ((*beh-rewrite* (and (not *rewrite-semantic-reduce*) |
| 1191 | 902 | (module-has-behavioural-axioms module)))) |
| 1192 | 903 | (declare (special *beh-rewrite*)) |
| 1193 | ;; | |
| 1194 | 904 | (set-term-color-top term) |
| 1195 | 905 | (normalize-term term)))))) |
| 1196 | 906 | term) |
| 1235 | 945 | (rwl-state-term |
| 1236 | 946 | (car (rwl-sch-context-answers .rwl-sch-context.)))) |
| 1237 | 947 | (with-output-chaos-error () |
| 1238 | (format t "PANIC!")) | |
| 1239 | )) | |
| 1240 | ) | |
| 1241 | ||
| 948 | (format t "PANIC!"))))) | |
| 1242 | 949 | (otherwise |
| 1243 | 950 | (setq $$trials 1) |
| 1244 | 951 | (when *memo-rewrite* |
| 1267 | 974 | ;; compute the normal form of "term" |
| 1268 | 975 | (reduce-term term strategy) |
| 1269 | 976 | (setq normal-form term) |
| 1270 | ;; store the normal form | |
| 1271 | 977 | (set-hashed-term term-nu *term-memo-table* normal-form)) |
| 1272 | 978 | normal-form)) |
| 1273 | 979 | |
| 1285 | 991 | (defun normalize-term (term) |
| 1286 | 992 | (declare (type term term) |
| 1287 | 993 | (values (or null t))) |
| 1288 | (unless (term-is-lowest-parsed? term) | |
| 1289 | (update-lowest-parse term)) | |
| 994 | ;; (unless (term-is-lowest-parsed? term) | |
| 995 | ;; (update-lowest-parse term)) | |
| 1290 | 996 | (when *rewrite-debug* |
| 1291 | 997 | (with-output-simple-msg () |
| 1292 | 998 | (format t "[normalize-term]:(NF=~A,LP=~A,OD=~A) " |
| 1293 | 999 | (term-is-reduced? term) |
| 1294 | (term-is-lowest-parsed? term) | |
| 1000 | (term-is-lowest-parsed? term) | |
| 1295 | 1001 | (term-is-on-demand? term)) |
| 1296 | 1002 | (term-print-with-sort term))) |
| 1297 | 1003 | (let ((strategy nil)) |
| 1325 | 1031 | ;;; |
| 1326 | 1032 | |
| 1327 | 1033 | ;;;***************************************************************************** |
| 1328 | ;;; REWRITING WITH TRACE, STEP | |
| 1034 | ;;; REWRITING WITH TRACE, STEP | |
| 1329 | 1035 | ;;;***************************************************************************** |
| 1330 | 1036 | |
| 1331 | 1037 | ;;; APPLY-ONE-RULE-DBG |
| 1335 | 1041 | ;;; |
| 1336 | 1042 | ;;; |
| 1337 | 1043 | (defun print-trace-in () |
| 1338 | (format *trace-output* "~&~d>[~a] " *trace-level* (1+ *rule-count*))) | |
| 1044 | (format *trace-output* "~%~d>[~a] " *trace-level* (1+ *rule-count*))) | |
| 1339 | 1045 | |
| 1340 | 1046 | (defun print-trace-out () |
| 1341 | (format *trace-output* "~&~d<[~a] " *trace-level* *rule-count*)) | |
| 1047 | (format *trace-output* "~%~d<[~a] " *trace-level* *rule-count*)) | |
| 1342 | 1048 | |
| 1343 | 1049 | (defun cafein-pattern-match (pat term) |
| 1344 | 1050 | (declare (type term pat term) |
| 1350 | 1056 | nil) |
| 1351 | 1057 | (if (term-is-lisp-form? pat) |
| 1352 | 1058 | nil |
| 1353 | (multiple-value-bind (gs sub no-match eeq) | |
| 1354 | (first-match pat term) | |
| 1355 | (declare (ignore gs sub eeq)) | |
| 1356 | (unless no-match | |
| 1357 | (return-from cafein-pattern-match term)) | |
| 1358 | (if (term-is-application-form? term) | |
| 1059 | (multiple-value-bind (gs sub no-match eeq) | |
| 1060 | (first-match pat term) | |
| 1061 | (declare (ignore gs sub eeq)) | |
| 1062 | (unless no-match | |
| 1063 | (return-from cafein-pattern-match term)) | |
| 1064 | (if (term-is-application-form? term) | |
| 1359 | 1065 | (dolist (sub (term-subterms term) nil) |
| 1360 | 1066 | (let ((match (cafein-pattern-match pat sub))) |
| 1361 | 1067 | (when match |
| 1362 | 1068 | (return-from cafein-pattern-match match)))) |
| 1363 | 1069 | nil) |
| 1364 | nil)))) | |
| 1070 | nil)))) | |
| 1365 | 1071 | |
| 1366 | 1072 | (defun check-stop-pattern (term) |
| 1367 | 1073 | (declare (type term term) |
| 1375 | 1081 | (setq *matched-to-stop-pattern* term) |
| 1376 | 1082 | (if (eq matched term) |
| 1377 | 1083 | (progn |
| 1378 | (format t "~&>> term matches to stop pattern: ") | |
| 1084 | (format t "~%>> term matches to stop pattern: ") | |
| 1379 | 1085 | (let ((*print-indent* (+ *print-indent* 8))) |
| 1380 | 1086 | (term-print *rewrite-stop-pattern*)) |
| 1381 | (format t "~&<< will stop rewriting") | |
| 1087 | (format t "~%<< will stop rewriting") | |
| 1382 | 1088 | ) |
| 1383 | 1089 | (progn |
| 1384 | (format t "~&>> subterm : ") | |
| 1090 | (format t "~%>> subterm : ") | |
| 1385 | 1091 | (let ((*print-indent* (+ *print-indent* 8))) |
| 1386 | 1092 | (term-print matched)) |
| 1387 | 1093 | (format t "~& of term : ") |
| 1390 | 1096 | (format t "~& matches to stop pattern: ") |
| 1391 | 1097 | (let ((*print-indent* (+ *print-indent* 8))) |
| 1392 | 1098 | (term-print *rewrite-stop-pattern*)) |
| 1393 | (format t "~&<< will stop rewriting") | |
| 1099 | (format t "~%<< will stop rewriting") | |
| 1394 | 1100 | )) |
| 1395 | 1101 | (force-output)) |
| 1396 | 1102 | ;; |
| 1448 | 1154 | (when (and *steps-to-be-done* (> (the fixnum *steps-to-be-done*) 0)) |
| 1449 | 1155 | (return-from cafein-stepper nil)) |
| 1450 | 1156 | (unless *steps-to-be-done* (return-from cafein-stepper nil)))) |
| 1451 | ;; | |
| 1452 | 1157 | ;; print current term |
| 1453 | (format t "~&>> taret: ") | |
| 1158 | (format t "~%>> target: ") | |
| 1454 | 1159 | (term-print term) |
| 1455 | 1160 | ;; prompt command |
| 1456 | 1161 | (catch 'cafein-stepper-exit |
| 1487 | 1192 | (with-chaos-top-error () |
| 1488 | 1193 | (with-chaos-error () |
| 1489 | 1194 | (when top-level? |
| 1490 | (format t "~&STEP[~D]? " *rule-count*) | |
| 1195 | (format t "~%STEP[~D]? " *rule-count*) | |
| 1491 | 1196 | (force-output)) |
| 1492 | 1197 | (reader 'step-commands *step-commands*))))) |
| 1493 | 1198 | |
| 1494 | 1199 | (eval-when (:execute :load-toplevel) |
| 1495 | 1200 | (setq *step-commands* |
| 1496 | '((step-commands | |
| 1497 | (:one-of | |
| 1201 | '((step-commands | |
| 1202 | (:one-of | |
| 1498 | 1203 | |
| 1499 | 1204 | ;; end of step (just stop now). |
| 1500 | #-CMU (#\^D) | |
| 1501 | #+CMU (#\) | |
| 1502 | (eof) | |
| 1503 | ((:+ q |:q|)) | |
| 1205 | #-CMU (#\^D) | |
| 1206 | #+CMU (#\) | |
| 1207 | (eof) | |
| 1208 | ((:+ q |:q|)) | |
| 1504 | 1209 | |
| 1505 | 1210 | ;; continue rewriting and exit from stepping mode. |
| 1506 | ((:+ c |:c| continue |:continue|)) | |
| 1211 | ((:+ c |:c| continue |:continue|)) | |
| 1507 | 1212 | |
| 1508 | 1213 | ;; stop pattern |
| 1509 | ((:+ stop |:stop|) :top-term) | |
| 1510 | ||
| 1214 | ((:+ stop |:stop|) :top-term) | |
| 1215 | ||
| 1511 | 1216 | ;; rewrite limit |
| 1512 | ((:+ rwt rewrite |:rwt| |:rewrite|) :symbol) | |
| 1513 | ||
| 1217 | ((:+ rwt rewrite |:rwt| |:rewrite|) :symbol) | |
| 1218 | ||
| 1514 | 1219 | ;; step to next |
| 1515 | ((:+ n |:n| next |:next|)) | |
| 1220 | ((:+ n |:n| next |:next|)) | |
| 1516 | 1221 | |
| 1517 | 1222 | ;; step N step |
| 1518 | ((:+ g go |:g| |:go|) :int) | |
| 1519 | ||
| 1223 | ((:+ g go |:g| |:go|) :int) | |
| 1224 | ||
| 1520 | 1225 | ;; abort |
| 1521 | ((:+ a |:a| abort |:abort|)) | |
| 1522 | ||
| 1226 | ((:+ a |:a| abort |:abort|)) | |
| 1227 | ||
| 1523 | 1228 | ;; show infos |
| 1524 | ((:+ r |:r| |:rule| rule)) | |
| 1525 | ((:+ s |:s| subst |:subst|)) | |
| 1526 | ((:+ p |:p| pattern |:pattern|)) | |
| 1527 | ((:+ l |:l| limit |:limit|)) | |
| 1528 | ((:+ x |:x| )) | |
| 1229 | ((:+ r |:r| |:rule| rule)) | |
| 1230 | ((:+ s |:s| subst |:subst|)) | |
| 1231 | ((:+ p |:p| pattern |:pattern|)) | |
| 1232 | ((:+ l |:l| limit |:limit|)) | |
| 1233 | ((:+ x |:x| )) | |
| 1529 | 1234 | ;; some useful top level commands |
| 1530 | ((:+ match unify) (:seq-of :term) to (:seq-of :term) |.|) | |
| 1531 | ((:+ lisp ev eval evq lispq) | |
| 1532 | (:call (read))) | |
| 1533 | ((:+ show sh set describe desc) | |
| 1534 | (:seq-of :top-opname)) | |
| 1235 | ((:+ match unify) (:seq-of :term) to (:seq-of :term) |.|) | |
| 1236 | ((:+ lisp ev eval evq lispq) | |
| 1237 | (:call (read))) | |
| 1238 | ((:+ show sh set describe desc) | |
| 1239 | (:seq-of :top-opname)) | |
| 1535 | 1240 | ;; |
| 1536 | (cd :symbol) | |
| 1537 | #-(or GCL LUCID CMU) (ls :symbol) | |
| 1538 | #+(or GCL LUCID CMU) (ls :top-term) | |
| 1539 | (pwd) | |
| 1540 | (! :top-term) | |
| 1541 | ((+ ? |:?| |:h| h |:help| help)) | |
| 1542 | )) | |
| 1241 | (cd :symbol) | |
| 1242 | #-(or GCL LUCID CMU) (ls :symbol) | |
| 1243 | #+(or GCL LUCID CMU) (ls :top-term) | |
| 1244 | (pwd) | |
| 1245 | (! :top-term) | |
| 1246 | ((+ ? |:?| |:h| h |:help| help)) | |
| 1247 | )) | |
| 1543 | 1248 | (Selector |
| 1544 | (:one-of | |
| 1545 | ;; (term) (top) (subterm) | |
| 1546 | (|{| :int :append (:seq-of |,| :int) |}|) | |
| 1547 | (|(| (:seq-of :int) |)|) | |
| 1548 | (\[ :int (:optional |..| :int) \]))) | |
| 1549 | ))) | |
| 1249 | (:one-of | |
| 1250 | (|{| :int :append (:seq-of |,| :int) |}|) | |
| 1251 | (|(| (:seq-of :int) |)|) | |
| 1252 | (\[ :int (:optional |..| :int) \]))) | |
| 1253 | ))) | |
| 1550 | 1254 | |
| 1551 | 1255 | ;;; REWRITE COUNT LIMIT |
| 1552 | 1256 | ;;; ("rwt" <number>) |
| 1615 | 1319 | ;;; |
| 1616 | 1320 | (defun cafein-stepper-help-proc (inp) |
| 1617 | 1321 | (declare (ignore inp)) |
| 1618 | (format t "~&-- Stepper command help :") | |
| 1322 | (format t "~%-- Stepper command help :") | |
| 1619 | 1323 | (format t "~& ?~18Tprint out this help") |
| 1620 | 1324 | (format t "~& n(ext)~18Tgo one step") |
| 1621 | 1325 | (format t "~& g(o) <number>~18Tgo <number> step") |
| 1690 | 1394 | (when (rule-non-exec rule) |
| 1691 | 1395 | (return-from apply-one-rule nil)) |
| 1692 | 1396 | (let ((mandor (axiom-meta-and-or rule)) |
| 1693 | (.trace-or-step. (or $$trace-rewrite-whole $$trace-rewrite *rewrite-stepping*))) | |
| 1397 | (.trace-or-step. (or $$trace-rewrite-whole $$trace-rewrite *rewrite-stepping*))) | |
| 1694 | 1398 | (declare (special .trace-or-step.)) |
| 1695 | 1399 | (cond (mandor |
| 1696 | (let ((all-subst nil) | |
| 1697 | (rhs-list nil) | |
| 1698 | (new-rhs nil)) | |
| 1699 | (multiple-value-bind (gs sub no-match eeq) | |
| 1700 | (rew-matcher (rule-lhs rule) term) | |
| 1701 | (declare (ignore eeq)) | |
| 1702 | (when no-match | |
| 1703 | (return-from apply-one-rule nil)) | |
| 1704 | (push sub all-subst) | |
| 1705 | ;; | |
| 1706 | ;; try other patterns untill there's no hope | |
| 1707 | (loop | |
| 1708 | (multiple-value-setq (gs sub no-match) | |
| 1709 | (next-match gs)) | |
| 1710 | (when no-match (return)) | |
| 1711 | (push sub all-subst))) | |
| 1712 | ;; | |
| 1713 | (if (cdr all-subst) | |
| 1714 | (progn | |
| 1715 | (when *debug-meta* | |
| 1716 | (format t "~&~s[subst]" mandor)) | |
| 1717 | (dolist (sub all-subst) | |
| 1718 | (push (set-term-color (substitution-image-simplifying sub (rule-rhs rule))) rhs-list) | |
| 1719 | (when *debug-meta* | |
| 1720 | (let ((*print-indent* (+ 4 *print-indent*))) | |
| 1721 | (print-next) | |
| 1722 | (print-substitution sub)))) | |
| 1723 | ;; | |
| 1724 | (setq new-rhs (make-right-assoc-normal-form-with-sort-check | |
| 1725 | (case mandor | |
| 1726 | ('|:m-and| *bool-and*) | |
| 1727 | ('|:m-and-also| *bool-and-also*) | |
| 1728 | ('|:m-or| *bool-or*) | |
| 1729 | ('|:m-or-else| *bool-or-else*) | |
| 1730 | (otherwise (with-output-panic-message () | |
| 1731 | (format t "internal error, invalid meta rule label ~s" mandor)))) | |
| 1732 | rhs-list)) | |
| 1733 | ;; DEBUG | |
| 1734 | (when *debug-meta* | |
| 1735 | (format t "~&~s[=>] " mandor) | |
| 1736 | (term-print-with-sort new-rhs)) | |
| 1737 | ;; | |
| 1738 | ;; do rewrite | |
| 1739 | ;; | |
| 1740 | (if .trace-or-step. | |
| 1741 | (progn (term-replace-dd-dbg term new-rhs) t) | |
| 1742 | (progn (term-replace-dd-simple term new-rhs) t))) | |
| 1743 | (!apply-one-rule rule term)))) | |
| 1744 | ;; normal case | |
| 1745 | (t (!apply-one-rule rule term))))) | |
| 1400 | (let ((all-subst nil) | |
| 1401 | (rhs-list nil) | |
| 1402 | (new-rhs nil)) | |
| 1403 | (multiple-value-bind (gs sub no-match eeq) | |
| 1404 | (rew-matcher (rule-lhs rule) term) | |
| 1405 | (declare (ignore eeq)) | |
| 1406 | (when no-match | |
| 1407 | (return-from apply-one-rule nil)) | |
| 1408 | (push sub all-subst) | |
| 1409 | ;; | |
| 1410 | ;; try other patterns untill there's no hope | |
| 1411 | (loop | |
| 1412 | (multiple-value-setq (gs sub no-match) | |
| 1413 | (next-match gs)) | |
| 1414 | (when no-match (return)) | |
| 1415 | (push sub all-subst))) | |
| 1416 | ;; | |
| 1417 | (if (cdr all-subst) | |
| 1418 | (progn | |
| 1419 | (when *debug-meta* | |
| 1420 | (format t "~%~s[subst]" mandor)) | |
| 1421 | (dolist (sub all-subst) | |
| 1422 | (push (set-term-color (substitution-image-simplifying sub (rule-rhs rule))) rhs-list) | |
| 1423 | (when *debug-meta* | |
| 1424 | (let ((*print-indent* (+ 4 *print-indent*))) | |
| 1425 | (print-next) | |
| 1426 | (print-substitution sub)))) | |
| 1427 | ;; | |
| 1428 | (setq new-rhs (make-right-assoc-normal-form-with-sort-check | |
| 1429 | (case mandor | |
| 1430 | ('|:m-and| *bool-and*) | |
| 1431 | ('|:m-and-also| *bool-and-also*) | |
| 1432 | ('|:m-or| *bool-or*) | |
| 1433 | ('|:m-or-else| *bool-or-else*) | |
| 1434 | (otherwise (with-output-panic-message () | |
| 1435 | (format t "internal error, invalid meta rule label ~s" mandor)))) | |
| 1436 | rhs-list)) | |
| 1437 | ;; DEBUG | |
| 1438 | (when *debug-meta* | |
| 1439 | (format t "~%~s[=>] " mandor) | |
| 1440 | (term-print-with-sort new-rhs)) | |
| 1441 | ;; | |
| 1442 | ;; do rewrite | |
| 1443 | ;; | |
| 1444 | (if .trace-or-step. | |
| 1445 | (progn (term-replace-dd-dbg term new-rhs) t) | |
| 1446 | (progn (term-replace-dd-simple term new-rhs) t))) | |
| 1447 | (!apply-one-rule rule term)))) | |
| 1448 | ;; normal case | |
| 1449 | (t (!apply-one-rule rule term))))) | |
| 1746 | 1450 | ;;; |
| 1747 | 1451 | ;;; SOME MEL SUPPORT |
| 1748 | 1452 | ;;; |
| 1769 | 1473 | (setf (cdr old-ent) value) |
| 1770 | 1474 | (if (symbolp value) |
| 1771 | 1475 | (push (cons term value) .memb-term-hash.) |
| 1772 | (push (cons (simple-copy-term term) value) | |
| 1476 | (push (cons (simple-copy-term term) value) | |
| 1773 | 1477 | .memb-term-hash.))))) |
| 1774 | 1478 | |
| 1775 | 1479 | (defun apply-sort-memb (term module) |
| 1783 | 1487 | (apply-sort-memb-internal term module))) |
| 1784 | 1488 | term) |
| 1785 | 1489 | |
| 1786 | (defun sort-to-sort-id-term (sort &optional (module (or *current-module* | |
| 1787 | *last-module*))) | |
| 1490 | (defun sort-to-sort-id-term (sort &optional (module (get-context-module))) | |
| 1788 | 1491 | (let* ((name (string (sort-id sort))) |
| 1789 | 1492 | (op (find-method-in module (list name) nil *sort-id-sort*))) |
| 1790 | 1493 | (unless op |
| 1917 | 1620 | (setq $$term saved-$$term) |
| 1918 | 1621 | term)))) |
| 1919 | 1622 | |
| 1920 | ;;; **** | |
| 1921 | ;;; INIT | |
| 1922 | ;;; **** | |
| 1923 | ;;;(eval-when (:execute :load-toplevel) | |
| 1924 | ;;; (setf (symbol-function 'apply-one-rule) | |
| 1925 | ;;; #'apply-one-rule-simple)) | |
| 1926 | ||
| 1927 | 1623 | ;;; EOF |
| 1928 | 1624 | |
| 0 | 0 | ;;;-*-Mode:LISP; Package: CHAOS; Base:10; Syntax:Common-lisp -*- |
| 1 | 1 | ;;; |
| 2 | ;;; Copyright (c) 2000-2014, Toshimi Sawada. All rights reserved. | |
| 2 | ;;; Copyright (c) 2000-2015, Toshimi Sawada. All rights reserved. | |
| 3 | 3 | ;;; |
| 4 | 4 | ;;; Redistribution and use in source and binary forms, with or without |
| 5 | 5 | ;;; modification, are permitted provided that the following conditions |
| 0 | 0 | ;;;-*-Mode:LISP; Package: CHAOS; Base:10; Syntax:Common-lisp -*- |
| 1 | 1 | ;;; |
| 2 | ;;; Copyright (c) 2000-2014, Toshimi Sawada. All rights reserved. | |
| 2 | ;;; Copyright (c) 2000-2015, Toshimi Sawada. All rights reserved. | |
| 3 | 3 | ;;; |
| 4 | 4 | ;;; Redistribution and use in source and binary forms, with or without |
| 5 | 5 | ;;; modification, are permitted provided that the following conditions |
| 27 | 27 | ;;; |
| 28 | 28 | (in-package :chaos) |
| 29 | 29 | #|============================================================================= |
| 30 | System:CHAOS | |
| 31 | Module:construct | |
| 32 | File:axiom.lisp | |
| 30 | System:CHAOS | |
| 31 | Module:construct | |
| 32 | File:axiom.lisp | |
| 33 | 33 | =============================================================================|# |
| 34 | 34 | #-:chaos-debug |
| 35 | 35 | (declaim (optimize (speed 3) (safety 0) #-GCL (debug 0))) |
| 42 | 42 | ;;; RULE CONSTRUCTOR |
| 43 | 43 | ;;; **************** |
| 44 | 44 | (defun make-rule (&key lhs rhs condition type id-condition behavioural |
| 45 | extensions | |
| 46 | kind first-match-method | |
| 47 | next-match-method | |
| 48 | labels | |
| 49 | (meta-and-or nil) | |
| 50 | no-method-computation) | |
| 45 | extensions | |
| 46 | kind first-match-method | |
| 47 | next-match-method | |
| 48 | labels | |
| 49 | (meta-and-or nil) | |
| 50 | no-method-computation) | |
| 51 | 51 | (declare (type (or null term) lhs rhs) |
| 52 | (type list condition) | |
| 53 | (type symbol type) | |
| 54 | (type t id-condition extensions kind first-match-method | |
| 55 | next-match-method labels) | |
| 56 | (type (or null t) behavioural no-method-computation) | |
| 57 | (values axiom)) | |
| 52 | (type list condition) | |
| 53 | (type symbol type) | |
| 54 | (type t id-condition extensions kind first-match-method | |
| 55 | next-match-method labels) | |
| 56 | (type (or null t) behavioural no-method-computation) | |
| 57 | (values axiom)) | |
| 58 | 58 | ;; *NOTE* now rewrite rule is just same to AXIOM, there are some |
| 59 | 59 | ;; room for optimization. |
| 60 | 60 | (let ((rule (create-axiom lhs |
| 61 | rhs | |
| 62 | condition | |
| 63 | type | |
| 64 | behavioural | |
| 65 | id-condition | |
| 66 | extensions | |
| 67 | kind | |
| 68 | first-match-method | |
| 69 | next-match-method | |
| 70 | labels | |
| 71 | meta-and-or))) | |
| 61 | rhs | |
| 62 | condition | |
| 63 | type | |
| 64 | behavioural | |
| 65 | id-condition | |
| 66 | extensions | |
| 67 | kind | |
| 68 | first-match-method | |
| 69 | next-match-method | |
| 70 | labels | |
| 71 | meta-and-or))) | |
| 72 | 72 | (if (term-is-lisp-form? rhs) |
| 73 | (setf (axiom-rhs rule) | |
| 74 | (convert-lisp-form-term rhs (axiom-lhs rule))) | |
| 73 | (setf (axiom-rhs rule) | |
| 74 | (convert-lisp-form-term rhs (axiom-lhs rule))) | |
| 75 | 75 | (if (and (term-is-builtin-constant? rhs) |
| 76 | (sort= (term-sort rhs) *chaos-value-sort*)) | |
| 77 | (convert-chaos-expr rhs (axiom-lhs rule)))) | |
| 76 | (sort= (term-sort rhs) *chaos-value-sort*)) | |
| 77 | (convert-chaos-expr rhs (axiom-lhs rule)))) | |
| 78 | 78 | (unless no-method-computation |
| 79 | 79 | (compute-rule-method rule)) |
| 80 | 80 | rule)) |
| 81 | 81 | |
| 82 | 82 | (defun make-simple-axiom (lhs rhs type &optional behavioural meta-and-or) |
| 83 | 83 | (declare (type term lhs rhs) |
| 84 | (type (or null t) behavioural)) | |
| 84 | (type (or null t) behavioural)) | |
| 85 | 85 | (make-rule :lhs lhs |
| 86 | :rhs rhs | |
| 87 | :condition *bool-true* | |
| 88 | :behavioural behavioural | |
| 89 | :id-condition nil | |
| 90 | :type type | |
| 91 | :kind nil | |
| 92 | :labels nil | |
| 93 | :meta-and-or meta-and-or)) | |
| 86 | :rhs rhs | |
| 87 | :condition *bool-true* | |
| 88 | :behavioural behavioural | |
| 89 | :id-condition nil | |
| 90 | :type type | |
| 91 | :kind nil | |
| 92 | :labels nil | |
| 93 | :meta-and-or meta-and-or)) | |
| 94 | 94 | ;;; |
| 95 | 95 | (defun make-fun (f) |
| 96 | 96 | #+GCL f |
| 124 | 124 | (defun convert-lisp-form-term (term lhs) |
| 125 | 125 | (declare (type term term lhs)) |
| 126 | 126 | (let* ((variables (term-variables lhs)) |
| 127 | (form (lisp-form-original-form term)) | |
| 128 | (parameters (mapcar #'(lambda (v) | |
| 129 | (intern (string-upcase (string (variable-name | |
| 130 | v))))) | |
| 131 | variables)) | |
| 132 | (fun-body nil) | |
| 133 | (new-term nil)) | |
| 127 | (form (lisp-form-original-form term)) | |
| 128 | (parameters (mapcar #'(lambda (v) | |
| 129 | (intern (string-upcase (string (variable-name | |
| 130 | v))))) | |
| 131 | variables)) | |
| 132 | (fun-body nil) | |
| 133 | (new-term nil)) | |
| 134 | 134 | (cond ((term-is-simple-lisp-form? term) |
| 135 | (let ((s-simbol (intern (format nil "slisp-sort-~D" | |
| 136 | (incf xsim-counter))))) | |
| 137 | (setf (get s-simbol :sort) (term-sort lhs)) | |
| 138 | (setf fun-body | |
| 139 | (make-fun* | |
| 140 | ` (lambda (subst) | |
| 141 | (invoke-simple-lisp-fun | |
| 142 | ',(make-fun `(lambda ,parameters ,form)) | |
| 143 | ',(reverse (mapcar #'(lambda (x) | |
| 144 | (variable-name x)) | |
| 145 | variables)) | |
| 146 | subst | |
| 147 | ',s-simbol)) | |
| 148 | ) | |
| 149 | ))) | |
| 150 | ((term-is-general-lisp-form? term) | |
| 151 | (setf fun-body | |
| 152 | (make-fun* `(lambda (subst) | |
| 135 | (let ((s-simbol (intern (format nil "slisp-sort-~D" | |
| 136 | (incf xsim-counter))))) | |
| 137 | (setf (get s-simbol :sort) (term-sort lhs)) | |
| 138 | (setf fun-body | |
| 139 | (make-fun* | |
| 140 | ` (lambda (subst) | |
| 141 | (invoke-simple-lisp-fun | |
| 142 | ',(make-fun `(lambda ,parameters ,form)) | |
| 143 | ',(reverse (mapcar #'(lambda (x) | |
| 144 | (variable-name x)) | |
| 145 | variables)) | |
| 146 | subst | |
| 147 | ',s-simbol)))))) | |
| 148 | ((term-is-general-lisp-form? term) | |
| 149 | (setf fun-body | |
| 150 | (make-fun* `(lambda (subst) | |
| 153 | 151 | (invoke-general-lisp-fun |
| 154 | 152 | ',(make-fun `(lambda ,parameters ,form)) |
| 155 | 153 | ',(reverse (mapcar #'(lambda (x) |
| 156 | (variable-name x)) | |
| 157 | variables)) | |
| 154 | (variable-name x)) | |
| 155 | variables)) | |
| 158 | 156 | subst))))) |
| 159 | (t (error "Internal error: invalid lisp form term ~s" term))) | |
| 157 | (t (error "Internal error: invalid lisp form term ~s" term))) | |
| 160 | 158 | (setf new-term (if (term-is-simple-lisp-form? term) |
| 161 | (make-simple-lisp-form-term (lisp-form-original-form | |
| 162 | term)) | |
| 163 | (make-general-lisp-form-term (lisp-form-original-form | |
| 164 | term)))) | |
| 159 | (make-simple-lisp-form-term (lisp-form-original-form | |
| 160 | term)) | |
| 161 | (make-general-lisp-form-term (lisp-form-original-form | |
| 162 | term)))) | |
| 165 | 163 | (setf (lisp-form-function new-term) fun-body) |
| 166 | 164 | (setf (term-sort new-term) (term-sort lhs)) |
| 167 | 165 | new-term)) |
| 169 | 167 | (defun convert-chaos-expr (term lhs) |
| 170 | 168 | (declare (type term term lhs)) |
| 171 | 169 | (let* ((variables (term-variables lhs)) |
| 172 | (form (list 'eval-ast2 (term-builtin-value term))) | |
| 173 | (parameters (mapcar #'(lambda (v) | |
| 174 | (intern (string-upcase (string (variable-name | |
| 175 | v))))) | |
| 176 | variables)) | |
| 177 | (fun-body nil)) | |
| 170 | (form (list 'eval-ast2 (term-builtin-value term))) | |
| 171 | (parameters (mapcar #'(lambda (v) | |
| 172 | (intern (string-upcase (string (variable-name | |
| 173 | v))))) | |
| 174 | variables)) | |
| 175 | (fun-body nil)) | |
| 178 | 176 | ;; |
| 179 | 177 | (setf fun-body |
| 180 | 178 | (make-fun* |
| 181 | 179 | ` (lambda (subst) |
| 182 | (eval-chaos-expr | |
| 183 | ',(make-fun `(lambda ,parameters ,form)) | |
| 184 | ',(reverse (mapcar #'(lambda (x) | |
| 185 | (variable-name x)) | |
| 186 | variables)) | |
| 187 | subst)) | |
| 188 | ) | |
| 189 | ) | |
| 180 | (eval-chaos-expr | |
| 181 | ',(make-fun `(lambda ,parameters ,form)) | |
| 182 | ',(reverse (mapcar #'(lambda (x) | |
| 183 | (variable-name x)) | |
| 184 | variables)) | |
| 185 | subst)))) | |
| 190 | 186 | (setf (term-builtin-value term) |
| 191 | 187 | (list '|%Chaos| fun-body (term-builtin-value term))) |
| 192 | 188 | term)) |
| 198 | 194 | (defun invoke-general-lisp-fun (fun vars substitution) |
| 199 | 195 | (declare (type list vars substitution)) |
| 200 | 196 | (macrolet ((subst-image-by-name (v-name) |
| 201 | ` (dolist (b substitution '((error image))) | |
| 202 | (when (equal ,v-name (variable-name (car b))) | |
| 203 | (return (cdr b)))))) | |
| 197 | ` (dolist (b substitution '((error image))) | |
| 198 | (when (equal ,v-name (variable-name (car b))) | |
| 199 | (return (cdr b)))))) | |
| 204 | 200 | (let ((bindings nil)) |
| 205 | 201 | (dolist (v vars) |
| 206 | (push (subst-image-by-name v) bindings)) | |
| 202 | (push (subst-image-by-name v) bindings)) | |
| 207 | 203 | (catch 'rewrite-failure |
| 208 | (values (apply fun bindings) t))))) | |
| 204 | (values (apply fun bindings) t))))) | |
| 209 | 205 | |
| 210 | 206 | (defun is-metalevel-special-sort (sort) |
| 211 | 207 | (gethash sort *builtin-metalevel-sort*)) |
| 212 | 208 | |
| 213 | 209 | (defun invoke-simple-lisp-fun (fun vars substitution sort-x) |
| 214 | 210 | (declare (type function fun) |
| 215 | (type list vars substitution) | |
| 216 | (type t sort-x) | |
| 217 | (values t t)) | |
| 211 | (type list vars substitution) | |
| 212 | (type t sort-x) | |
| 213 | (values t t)) | |
| 218 | 214 | (macrolet ((subst-image-by-name (v-name) |
| 219 | ` (dolist (b substitution nil) | |
| 220 | (when (equal ,v-name (variable-name (car b))) | |
| 221 | (return (cdr b))))) | |
| 222 | (coerce-lisp-to-term (sort value) | |
| 223 | ` (if (sort= *bool-sort* ,sort) | |
| 224 | (if ,value | |
| 225 | *bool-true* | |
| 226 | *bool-false*) | |
| 227 | (if (is-metalevel-special-sort sort) | |
| 228 | ,value | |
| 229 | (make-bconst-term ,sort ,value))))) | |
| 215 | ` (dolist (b substitution nil) | |
| 216 | (when (equal ,v-name (variable-name (car b))) | |
| 217 | (return (cdr b))))) | |
| 218 | (coerce-lisp-to-term (sort value) | |
| 219 | ` (if (sort= *bool-sort* ,sort) | |
| 220 | (if ,value | |
| 221 | *bool-true* | |
| 222 | *bool-false*) | |
| 223 | (if (is-metalevel-special-sort sort) | |
| 224 | ,value | |
| 225 | (make-bconst-term ,sort ,value))))) | |
| 230 | 226 | ;; |
| 231 | 227 | (block invoke |
| 232 | 228 | (let ((bindings nil) |
| 233 | (sort (get sort-x :sort))) | |
| 234 | (dolist (v vars) | |
| 235 | (let ((value (subst-image-by-name v))) | |
| 236 | (if value | |
| 237 | (if (term-is-pure-builtin-constant? value) | |
| 238 | (push (term-builtin-value value) bindings) | |
| 239 | (if *reduce-builtin-eager* | |
| 240 | (let ((args (term-subterms value))) | |
| 241 | (dolist (a args) (normalize-term a)) | |
| 242 | (if (every #'(lambda (x) | |
| 243 | (and (term-is-builtin-constant? x) | |
| 244 | (not (term-is-psuedo-constant? x)))) | |
| 245 | args) | |
| 246 | (progn | |
| 247 | (normalize-term value) | |
| 248 | (if (term-is-builtin-constant? value) | |
| 249 | (push (term-builtin-value value) bindings) | |
| 250 | (return-from invoke (values nil nil)))) | |
| 251 | (return-from invoke (values value t)))) | |
| 252 | (return-from invoke (values nil nil))) | |
| 253 | ) | |
| 254 | (return-from invoke (values nil nil)) | |
| 255 | ))) | |
| 256 | (if (sort-is-builtin sort) | |
| 257 | (values (make-bconst-term sort | |
| 258 | (apply fun bindings)) | |
| 259 | t) | |
| 260 | (values (coerce-lisp-to-term sort (apply fun bindings)) | |
| 261 | t)))))) | |
| 229 | (sort (get sort-x :sort))) | |
| 230 | (dolist (v vars) | |
| 231 | (let ((value (subst-image-by-name v))) | |
| 232 | (if value | |
| 233 | (if (term-is-pure-builtin-constant? value) | |
| 234 | (push (term-builtin-value value) bindings) | |
| 235 | (if *reduce-builtin-eager* | |
| 236 | (let ((args (term-subterms value))) | |
| 237 | (dolist (a args) (normalize-term a)) | |
| 238 | (if (every #'(lambda (x) | |
| 239 | (and (term-is-builtin-constant? x) | |
| 240 | (not (term-is-psuedo-constant? x)))) | |
| 241 | args) | |
| 242 | (progn | |
| 243 | (normalize-term value) | |
| 244 | (if (term-is-builtin-constant? value) | |
| 245 | (push (term-builtin-value value) bindings) | |
| 246 | (return-from invoke (values nil nil)))) | |
| 247 | (return-from invoke (values value t)))) | |
| 248 | (return-from invoke (values nil nil)))) | |
| 249 | (return-from invoke (values nil nil))))) | |
| 250 | (if (sort-is-builtin sort) | |
| 251 | (values (make-bconst-term sort | |
| 252 | (apply fun bindings)) | |
| 253 | t) | |
| 254 | (values (coerce-lisp-to-term sort (apply fun bindings)) | |
| 255 | t)))))) | |
| 262 | 256 | |
| 263 | 257 | (defun eval-chaos-expr (fun vars substitution) |
| 264 | 258 | (declare (type function fun) |
| 265 | (type list vars substitution) | |
| 266 | (values t t)) | |
| 259 | (type list vars substitution) | |
| 260 | (values t t)) | |
| 267 | 261 | (macrolet ((subst-image-by-name (v-name) |
| 268 | ` (dolist (b substitution nil) | |
| 269 | (when (equal ,v-name (variable-name (car b))) | |
| 270 | (return (cdr b)))))) | |
| 262 | ` (dolist (b substitution nil) | |
| 263 | (when (equal ,v-name (variable-name (car b))) | |
| 264 | (return (cdr b)))))) | |
| 271 | 265 | ;; |
| 272 | 266 | (block invoke |
| 273 | 267 | (let ((bindings nil) |
| 274 | (sort *chaos-value-sort*)) | |
| 275 | (dolist (v vars) | |
| 276 | (let ((value (subst-image-by-name v))) | |
| 277 | (if value | |
| 278 | (if (term-is-pure-builtin-constant? value) | |
| 279 | (push (term-builtin-value value) bindings) | |
| 280 | (if *reduce-builtin-eager* | |
| 281 | (let ((args (term-subterms value))) | |
| 282 | (dolist (a args) (normalize-term a)) | |
| 283 | (if (every #'(lambda (x) | |
| 284 | (and (term-is-builtin-constant? x) | |
| 285 | (not (term-is-psuedo-constant? x)))) | |
| 286 | args) | |
| 287 | (progn | |
| 288 | (normalize-term value) | |
| 289 | (if (term-is-builtin-constant? value) | |
| 290 | (push (term-builtin-value value) bindings) | |
| 291 | (return-from invoke (values nil nil)))) | |
| 292 | (return-from invoke (values value t)))) | |
| 293 | (return-from invoke (values nil nil))) | |
| 294 | ) | |
| 295 | (return-from invoke (values nil nil)) | |
| 296 | ))) | |
| 297 | (values (make-bconst-term sort | |
| 298 | (apply fun bindings)) | |
| 299 | t) | |
| 300 | )))) | |
| 268 | (sort *chaos-value-sort*)) | |
| 269 | (dolist (v vars) | |
| 270 | (let ((value (subst-image-by-name v))) | |
| 271 | (if value | |
| 272 | (if (term-is-pure-builtin-constant? value) | |
| 273 | (push (term-builtin-value value) bindings) | |
| 274 | (if *reduce-builtin-eager* | |
| 275 | (let ((args (term-subterms value))) | |
| 276 | (dolist (a args) (normalize-term a)) | |
| 277 | (if (every #'(lambda (x) | |
| 278 | (and (term-is-builtin-constant? x) | |
| 279 | (not (term-is-psuedo-constant? x)))) | |
| 280 | args) | |
| 281 | (progn | |
| 282 | (normalize-term value) | |
| 283 | (if (term-is-builtin-constant? value) | |
| 284 | (push (term-builtin-value value) bindings) | |
| 285 | (return-from invoke (values nil nil)))) | |
| 286 | (return-from invoke (values value t)))) | |
| 287 | (return-from invoke (values nil nil)))) | |
| 288 | (return-from invoke (values nil nil))))) | |
| 289 | (values (make-bconst-term sort | |
| 290 | (apply fun bindings)) | |
| 291 | t))))) | |
| 301 | 292 | |
| 302 | 293 | ;;; |
| 303 | 294 | ;;; |
| 305 | 296 | (defun make-ext-rule-label (ls modif) |
| 306 | 297 | (let ((lbl (car ls))) |
| 307 | 298 | (if lbl |
| 308 | (list (intern (format nil "~a_ext_~a" lbl modif))) | |
| 299 | (list (intern (format nil "~a_ext_~a" lbl modif))) | |
| 309 | 300 | nil))) |
| 310 | 301 | |
| 311 | 302 | |
| 315 | 306 | ;;; |
| 316 | 307 | (defun compute-A-extensions (rule top) |
| 317 | 308 | (declare (type axiom rule) |
| 318 | (type method top) | |
| 319 | (values list)) | |
| 309 | (type method top) | |
| 310 | (values list)) | |
| 320 | 311 | (let ((knd (axiom-kind rule))) |
| 321 | 312 | (when *on-axiom-debug* |
| 322 | 313 | (format t "~%[A-extension] ") |
| 323 | 314 | (print-chaos-object rule) |
| 324 | 315 | (format t "~% kind=~S" knd)) |
| 325 | 316 | (if (and knd (or (eq :id-theorem knd) (eq :idem-theory knd))) |
| 326 | (setf (!axiom-A-extensions rule) '(nil nil nil)) | |
| 317 | (setf (!axiom-A-extensions rule) '(nil nil nil)) | |
| 327 | 318 | (let ((listext nil) |
| 328 | ext-rule | |
| 329 | (new-var (make-variable-term *cosmos* 'A1)) | |
| 330 | (new-var2 (make-variable-term *cosmos* 'A2))) | |
| 331 | ||
| 332 | ;; first the left associative extension | |
| 333 | (setf ext-rule | |
| 334 | (make-rule | |
| 335 | :lhs (make-right-assoc-normal-form top | |
| 336 | (cons new-var | |
| 337 | (list-assoc-subterms | |
| 338 | (axiom-lhs rule) | |
| 339 | (term-method | |
| 340 | (axiom-lhs rule))))) | |
| 341 | :rhs (make-applform (method-coarity top) | |
| 342 | top | |
| 343 | (list new-var | |
| 344 | ;;(substitution-check-builtin | |
| 345 | ;; (axiom-rhs rule)) | |
| 346 | (axiom-rhs rule) | |
| 347 | )) | |
| 348 | :condition (axiom-condition rule) | |
| 349 | :id-condition (axiom-id-condition rule) | |
| 350 | :type (axiom-type rule) | |
| 351 | :labels (make-ext-rule-label (axiom-labels rule) "A-l") | |
| 352 | :behavioural (axiom-is-behavioural rule) | |
| 353 | :kind (if (eq :id-theorem knd) | |
| 354 | :id-ext-theory | |
| 355 | :A-left-theory) | |
| 356 | :meta-and-or (axiom-meta-and-or rule))) | |
| 357 | ;; (compute-rule-method ext-rule) | |
| 358 | (push ext-rule listext) | |
| 359 | ||
| 360 | ;; the right associative extension: | |
| 361 | (setf ext-rule | |
| 362 | (make-rule | |
| 363 | :lhs (make-right-assoc-normal-form top | |
| 364 | (append | |
| 365 | (list-assoc-subterms | |
| 366 | (axiom-lhs rule) | |
| 367 | (term-method | |
| 368 | (axiom-lhs rule))) | |
| 369 | (list new-var))) | |
| 370 | :rhs (make-applform (method-coarity top) | |
| 371 | top | |
| 372 | (list (axiom-rhs rule) | |
| 373 | new-var)) | |
| 374 | :condition (axiom-condition rule) | |
| 375 | :id-condition (axiom-id-condition rule) | |
| 376 | :type (axiom-type rule) | |
| 377 | :behavioural (axiom-is-behavioural rule) | |
| 378 | :labels (make-ext-rule-label (axiom-labels rule) "A-r") | |
| 379 | :kind (if (eq :id-theorem knd) | |
| 380 | :id-ext-theory | |
| 381 | :A-right-theory) | |
| 382 | :meta-and-or (axiom-meta-and-or rule))) | |
| 383 | ;; (compute-rule-method ext-rule) | |
| 384 | (push ext-rule listext) | |
| 385 | ||
| 386 | ;; the middle associative extension: | |
| 387 | (setf ext-rule | |
| 388 | (make-rule | |
| 389 | :lhs (make-right-assoc-normal-form top | |
| 390 | (list new-var2 | |
| 391 | (axiom-lhs rule) | |
| 392 | new-var)) | |
| 393 | :rhs (make-right-assoc-normal-form top | |
| 394 | (list new-var2 | |
| 395 | (axiom-rhs rule) | |
| 396 | new-var)) | |
| 397 | :condition (axiom-condition rule) | |
| 398 | :id-condition (axiom-id-condition rule) | |
| 399 | :type (axiom-type rule) | |
| 400 | :behavioural (axiom-is-behavioural rule) | |
| 401 | :labels (make-ext-rule-label (axiom-labels rule) "A-m") | |
| 402 | :kind (if (eq :id-theorem knd) | |
| 403 | :id-ext-theory | |
| 404 | :A-middle-theory) | |
| 405 | :meta-and-or (axiom-meta-and-or rule))) | |
| 406 | ;; | |
| 407 | (push ext-rule listext) | |
| 408 | (setf (axiom-A-extensions rule) listext)) | |
| 409 | ))) | |
| 319 | ext-rule | |
| 320 | (new-var (make-variable-term *cosmos* 'A1)) | |
| 321 | (new-var2 (make-variable-term *cosmos* 'A2))) | |
| 322 | ||
| 323 | ;; first the left associative extension | |
| 324 | (setf ext-rule | |
| 325 | (make-rule | |
| 326 | :lhs (make-right-assoc-normal-form top | |
| 327 | (cons new-var | |
| 328 | (list-assoc-subterms | |
| 329 | (axiom-lhs rule) | |
| 330 | (term-method | |
| 331 | (axiom-lhs rule))))) | |
| 332 | :rhs (make-applform (method-coarity top) | |
| 333 | top | |
| 334 | (list new-var | |
| 335 | (axiom-rhs rule))) | |
| 336 | :condition (axiom-condition rule) | |
| 337 | :id-condition (axiom-id-condition rule) | |
| 338 | :type (axiom-type rule) | |
| 339 | :labels (make-ext-rule-label (axiom-labels rule) "A-l") | |
| 340 | :behavioural (axiom-is-behavioural rule) | |
| 341 | :kind (if (eq :id-theorem knd) | |
| 342 | :id-ext-theory | |
| 343 | :A-left-theory) | |
| 344 | :meta-and-or (axiom-meta-and-or rule))) | |
| 345 | ;; (compute-rule-method ext-rule) | |
| 346 | (push ext-rule listext) | |
| 347 | ||
| 348 | ;; the right associative extension: | |
| 349 | (setf ext-rule | |
| 350 | (make-rule | |
| 351 | :lhs (make-right-assoc-normal-form top | |
| 352 | (append | |
| 353 | (list-assoc-subterms | |
| 354 | (axiom-lhs rule) | |
| 355 | (term-method | |
| 356 | (axiom-lhs rule))) | |
| 357 | (list new-var))) | |
| 358 | :rhs (make-applform (method-coarity top) | |
| 359 | top | |
| 360 | (list (axiom-rhs rule) | |
| 361 | new-var)) | |
| 362 | :condition (axiom-condition rule) | |
| 363 | :id-condition (axiom-id-condition rule) | |
| 364 | :type (axiom-type rule) | |
| 365 | :behavioural (axiom-is-behavioural rule) | |
| 366 | :labels (make-ext-rule-label (axiom-labels rule) "A-r") | |
| 367 | :kind (if (eq :id-theorem knd) | |
| 368 | :id-ext-theory | |
| 369 | :A-right-theory) | |
| 370 | :meta-and-or (axiom-meta-and-or rule))) | |
| 371 | (push ext-rule listext) | |
| 372 | ;; the middle associative extension: | |
| 373 | (setf ext-rule | |
| 374 | (make-rule | |
| 375 | :lhs (make-right-assoc-normal-form top | |
| 376 | (list new-var2 | |
| 377 | (axiom-lhs rule) | |
| 378 | new-var)) | |
| 379 | :rhs (make-right-assoc-normal-form top | |
| 380 | (list new-var2 | |
| 381 | (axiom-rhs rule) | |
| 382 | new-var)) | |
| 383 | :condition (axiom-condition rule) | |
| 384 | :id-condition (axiom-id-condition rule) | |
| 385 | :type (axiom-type rule) | |
| 386 | :behavioural (axiom-is-behavioural rule) | |
| 387 | :labels (make-ext-rule-label (axiom-labels rule) "A-m") | |
| 388 | :kind (if (eq :id-theorem knd) | |
| 389 | :id-ext-theory | |
| 390 | :A-middle-theory) | |
| 391 | :meta-and-or (axiom-meta-and-or rule))) | |
| 392 | ;; | |
| 393 | (push ext-rule listext) | |
| 394 | (setf (axiom-A-extensions rule) listext))))) | |
| 410 | 395 | |
| 411 | 396 | |
| 412 | 397 | ;;; COMPUTE-AC-EXTENSION : rule method -> List[Rule] |
| 415 | 400 | ;;; |
| 416 | 401 | (defun compute-AC-extension (rule top) |
| 417 | 402 | (declare (type axiom rule) |
| 418 | (type method top) | |
| 419 | (values list)) | |
| 403 | (type method top) | |
| 404 | (values list)) | |
| 420 | 405 | ;;(declare (optimize (speed 3) (safety 0))) |
| 421 | 406 | (let ((knd (axiom-kind rule))) |
| 422 | 407 | (if (and knd (not (eq :id-theorem knd)) (not (eq :idem-theory knd))) |
| 423 | (setf (!axiom-AC-extension rule) | |
| 424 | ;; '(nil) | |
| 425 | nil) | |
| 408 | (setf (!axiom-AC-extension rule) | |
| 409 | ;; '(nil) | |
| 410 | nil) | |
| 426 | 411 | (let (ext-rule |
| 427 | (new-var (make-variable-term (car (method-arity top)) | |
| 428 | ;; *cosmos* | |
| 429 | 'AC))) | |
| 430 | (setf ext-rule | |
| 431 | (make-rule | |
| 432 | :lhs (make-right-assoc-normal-form top | |
| 433 | (cons new-var | |
| 434 | (list-assoc-subterms | |
| 435 | (axiom-lhs rule) | |
| 436 | (term-method | |
| 437 | (axiom-lhs rule))))) | |
| 438 | :rhs (make-applform (method-coarity top) | |
| 439 | top | |
| 440 | (list new-var | |
| 441 | (axiom-rhs rule) | |
| 442 | )) | |
| 443 | :condition (axiom-condition rule) | |
| 444 | :type (axiom-type rule) | |
| 445 | :behavioural (axiom-is-behavioural rule) | |
| 446 | :id-condition (axiom-id-condition rule) | |
| 447 | :labels (make-ext-rule-label (axiom-labels rule) "AC") | |
| 448 | :kind (if (eq ':id-theorem knd) | |
| 449 | ':id-ext-theory | |
| 450 | ':ac-theory) | |
| 451 | :meta-and-or (axiom-meta-and-or rule))) | |
| 452 | ;; | |
| 453 | (setf (axiom-AC-extension rule) (list ext-rule)) | |
| 454 | )))) | |
| 412 | (new-var (make-variable-term (car (method-arity top)) | |
| 413 | ;; *cosmos* | |
| 414 | 'AC))) | |
| 415 | (setf ext-rule | |
| 416 | (make-rule | |
| 417 | :lhs (make-right-assoc-normal-form top | |
| 418 | (cons new-var | |
| 419 | (list-assoc-subterms | |
| 420 | (axiom-lhs rule) | |
| 421 | (term-method | |
| 422 | (axiom-lhs rule))))) | |
| 423 | :rhs (make-applform (method-coarity top) | |
| 424 | top | |
| 425 | (list new-var | |
| 426 | (axiom-rhs rule))) | |
| 427 | :condition (axiom-condition rule) | |
| 428 | :type (axiom-type rule) | |
| 429 | :behavioural (axiom-is-behavioural rule) | |
| 430 | :id-condition (axiom-id-condition rule) | |
| 431 | :labels (make-ext-rule-label (axiom-labels rule) "AC") | |
| 432 | :kind (if (eq ':id-theorem knd) | |
| 433 | ':id-ext-theory | |
| 434 | ':ac-theory) | |
| 435 | :meta-and-or (axiom-meta-and-or rule))) | |
| 436 | ;; | |
| 437 | (setf (axiom-AC-extension rule) (list ext-rule)))))) | |
| 455 | 438 | |
| 456 | 439 | |
| 457 | 440 | ;;; GIVE-AC-EXTENSION : rule -> List[Rule] |
| 460 | 443 | ;;; |
| 461 | 444 | (defun give-AC-extension (rule) |
| 462 | 445 | (declare (type axiom rule) |
| 463 | (values list)) | |
| 446 | (values list)) | |
| 464 | 447 | (let ((listext (!axiom-AC-extension rule))) |
| 465 | 448 | (when (or (null listext) (null (car listext))) |
| 466 | 449 | ;; then need to pre-compute the extensions and store then |
| 467 | 450 | (setq listext (compute-AC-extension |
| 468 | rule (term-method (axiom-lhs rule))))) | |
| 451 | rule (term-method (axiom-lhs rule))))) | |
| 469 | 452 | listext)) |
| 470 | 453 | |
| 471 | 454 | ;;; GIVE-A-EXTENSIONS : rule -> List[Rule] |
| 474 | 457 | ;;; |
| 475 | 458 | (defun give-A-extensions (rule) |
| 476 | 459 | (declare (type axiom rule) |
| 477 | (values list)) | |
| 460 | (values list)) | |
| 478 | 461 | (let ((listext (!axiom-A-extensions rule))) |
| 479 | 462 | (when (or (null listext) (null (car listext))) |
| 480 | 463 | ;; then need to pre-compute the extensions and store then |
| 481 | 464 | (setq listext (compute-A-extensions |
| 482 | rule (term-method (axiom-lhs rule))))) | |
| 465 | rule (term-method (axiom-lhs rule))))) | |
| 483 | 466 | listext)) |
| 484 | 467 | |
| 485 | 468 | ;;; COMPUTE-RULE-METHOD : rule -> rule' |
| 489 | 472 | (defun compute-rule-method (rule) |
| 490 | 473 | (declare (type axiom rule) |
| 491 | 474 | (values t)) |
| 475 | (when *on-axiom-debug* | |
| 476 | (format t "~%[CRM] compute rule method") | |
| 477 | (format t "~% (~x) " (addr-of rule)) | |
| 478 | (print-axiom-brief rule)) | |
| 492 | 479 | (let ((m (choose-match-method (axiom-lhs rule) |
| 493 | 480 | (axiom-condition rule) |
| 494 | 481 | (axiom-kind rule)))) |
| 495 | 482 | (setf (axiom-first-match-method rule) (car m)) |
| 496 | 483 | (setf (axiom-next-match-method rule) (cdr m)) |
| 497 | 484 | rule)) |
| 498 | ||
| 485 | ||
| 499 | 486 | ;;; RULE-COPY : rule -> rule |
| 500 | 487 | ;;;----------------------------------------------------------------------------- |
| 501 | 488 | ;;; Returns a copy of "rule". The variable occuring in the rule are also |
| 508 | 495 | |
| 509 | 496 | (defun rule-copy (rule) |
| 510 | 497 | (declare (type axiom rule) |
| 511 | (values axiom)) | |
| 498 | (values axiom)) | |
| 512 | 499 | (let ((new-rule nil)) |
| 513 | 500 | (multiple-value-bind (new-lhs list-new-var) |
| 514 | (term-copy-and-returns-list-variables (axiom-lhs rule)) | |
| 501 | (term-copy-and-returns-list-variables (axiom-lhs rule)) | |
| 515 | 502 | (setq new-rule (make-rule |
| 516 | :lhs new-lhs | |
| 517 | :condition (if (is-true? (axiom-condition rule)) | |
| 518 | *bool-true* | |
| 519 | (copy-term-using-variable (axiom-condition rule) | |
| 520 | list-new-var)) | |
| 521 | :id-condition (if (null (axiom-id-condition rule)) | |
| 522 | nil | |
| 523 | (if (is-true? (axiom-id-condition rule)) | |
| 524 | *bool-true* | |
| 525 | (term-copy-id-cond | |
| 526 | (axiom-id-condition rule) list-new-var))) | |
| 527 | :rhs (copy-term-using-variable (axiom-rhs rule) | |
| 528 | list-new-var) | |
| 529 | :type (axiom-type rule) | |
| 530 | :behavioural (axiom-is-behavioural rule) | |
| 531 | ;; :end-reduction (copy-list (axiom-end-reduction rule)) | |
| 532 | :first-match-method (axiom-first-match-method rule) | |
| 533 | :next-match-method (axiom-next-match-method rule) | |
| 534 | :labels (copy-list (axiom-labels rule)) | |
| 535 | :kind (axiom-kind rule) | |
| 536 | :meta-and-or (axiom-meta-and-or rule))) | |
| 503 | :lhs new-lhs | |
| 504 | :condition (if (is-true? (axiom-condition rule)) | |
| 505 | *bool-true* | |
| 506 | (copy-term-using-variable (axiom-condition rule) | |
| 507 | list-new-var)) | |
| 508 | :id-condition (if (null (axiom-id-condition rule)) | |
| 509 | nil | |
| 510 | (if (is-true? (axiom-id-condition rule)) | |
| 511 | *bool-true* | |
| 512 | (term-copy-id-cond | |
| 513 | (axiom-id-condition rule) list-new-var))) | |
| 514 | :rhs (copy-term-using-variable (axiom-rhs rule) | |
| 515 | list-new-var) | |
| 516 | :type (axiom-type rule) | |
| 517 | :behavioural (axiom-is-behavioural rule) | |
| 518 | ;; :end-reduction (copy-list (axiom-end-reduction rule)) | |
| 519 | :first-match-method (axiom-first-match-method rule) | |
| 520 | :next-match-method (axiom-next-match-method rule) | |
| 521 | :labels (copy-list (axiom-labels rule)) | |
| 522 | :kind (axiom-kind rule) | |
| 523 | :meta-and-or (axiom-meta-and-or rule))) | |
| 537 | 524 | (compute-rule-method new-rule) |
| 538 | 525 | new-rule))) |
| 539 | 526 | |
| 540 | 527 | (defun term-copy-id-cond (tm vars) |
| 541 | 528 | (declare (type (or null term) tm) |
| 542 | (type list vars)) | |
| 529 | (type list vars)) | |
| 543 | 530 | (cond |
| 544 | 531 | ((null tm) nil) |
| 545 | 532 | ((term-is-variable? tm) |
| 546 | 533 | (let ((val (assoc tm vars))) |
| 547 | 534 | (if val |
| 548 | (cdr val) | |
| 549 | (variable-copy tm) ; This should never occur | |
| 550 | ))) | |
| 535 | (cdr val) | |
| 536 | (variable-copy tm) ; This should never occur | |
| 537 | ))) | |
| 551 | 538 | (t (make-applform (method-coarity (term-method tm)) |
| 552 | (term-method tm) | |
| 553 | (mapcar #'(lambda (stm) | |
| 554 | (term-copy-id-cond stm vars)) | |
| 555 | (term-subterms tm)))))) | |
| 539 | (term-method tm) | |
| 540 | (mapcar #'(lambda (stm) | |
| 541 | (term-copy-id-cond stm vars)) | |
| 542 | (term-subterms tm)))))) | |
| 556 | 543 | |
| 557 | 544 | |
| 558 | 545 | ;;; ****************** |
| 566 | 553 | ;;; |
| 567 | 554 | (defun term-is-congruent-2? (t1 t2) |
| 568 | 555 | (declare (type term t1 t2) |
| 569 | (values (or null t))) | |
| 556 | (values (or null t))) | |
| 570 | 557 | (let ((t1-body (term-body t1)) |
| 571 | (t2-body (term-body t2))) | |
| 558 | (t2-body (term-body t2))) | |
| 572 | 559 | (cond ((term$is-variable? t1-body) |
| 573 | (or (eq t1 t2) | |
| 574 | (and (term$is-variable? t2-body) | |
| 575 | #|| | |
| 576 | ;; (eq (variable$name t1-body) (variable$name t2-body)) | |
| 577 | (sort= (variable$sort t1-body) (variable$sort t2-body)) | |
| 578 | ||# | |
| 579 | (variable= t1 t2) | |
| 580 | ))) | |
| 581 | ((term$is-variable? t2-body) nil) | |
| 582 | ((term$is-application-form? t1-body) | |
| 583 | (and (term$is-application-form? t2-body) | |
| 584 | (if ;;(method-is-same-qual-method (term$method t1-body) | |
| 585 | ;; (term$method t2-body)) | |
| 586 | (method-is-of-same-operator+ (term$method t1-body) | |
| 587 | (term$method t2-body)) | |
| 588 | (let ((sl1 (term$subterms t1-body)) | |
| 589 | (sl2 (term$subterms t2-body))) | |
| 590 | (loop (when (null sl1) (return (null sl2))) | |
| 591 | (unless (term-is-congruent-2? (car sl1) (car sl2)) | |
| 592 | (return nil)) | |
| 593 | (setf sl1 (cdr sl1) | |
| 594 | sl2 (cdr sl2)))) | |
| 595 | nil))) | |
| 596 | ((term$is-builtin-constant? t1-body) | |
| 597 | (term$builtin-equal t1-body t2-body)) | |
| 598 | ((term$is-builtin-constant? t2-body) nil) | |
| 599 | ((term$is-lisp-form? t1-body) | |
| 600 | (and (term$is-lisp-form? t2-body) | |
| 601 | (equal (term$lisp-function t1-body) | |
| 602 | (term$lisp-function t2-body)))) | |
| 603 | ((term$is-lisp-form? t2-body) nil) | |
| 604 | (t (break "Panic! unknown type of term to term-is-congruent?"))))) | |
| 560 | (or (eq t1 t2) | |
| 561 | (and (term$is-variable? t2-body) | |
| 562 | (variable= t1 t2)))) | |
| 563 | ((term$is-variable? t2-body) nil) | |
| 564 | ((term$is-application-form? t1-body) | |
| 565 | (and (term$is-application-form? t2-body) | |
| 566 | (if (method-is-of-same-operator+ (term$method t1-body) | |
| 567 | (term$method t2-body)) | |
| 568 | (let ((sl1 (term$subterms t1-body)) | |
| 569 | (sl2 (term$subterms t2-body))) | |
| 570 | (loop (when (null sl1) (return (null sl2))) | |
| 571 | (unless (term-is-congruent-2? (car sl1) (car sl2)) | |
| 572 | (return nil)) | |
| 573 | (setf sl1 (cdr sl1) | |
| 574 | sl2 (cdr sl2)))) | |
| 575 | nil))) | |
| 576 | ((term$is-builtin-constant? t1-body) | |
| 577 | (term$builtin-equal t1-body t2-body)) | |
| 578 | ((term$is-builtin-constant? t2-body) nil) | |
| 579 | ((term$is-lisp-form? t1-body) | |
| 580 | (and (term$is-lisp-form? t2-body) | |
| 581 | (equal (term$lisp-function t1-body) | |
| 582 | (term$lisp-function t2-body)))) | |
| 583 | ((term$is-lisp-form? t2-body) nil) | |
| 584 | (t (break "Panic! unknown type of term to term-is-congruent?"))))) | |
| 605 | 585 | |
| 606 | 586 | (defun rule-is-similar? (r1 r2) |
| 607 | 587 | (declare (type axiom r1 r2) |
| 608 | (values (or null t))) | |
| 588 | (values (or null t))) | |
| 609 | 589 | (and (eq (axiom-type r1) (axiom-type r2)) |
| 610 | 590 | (term-is-congruent-2? (axiom-lhs r1) (axiom-lhs r2)) |
| 611 | 591 | (term-is-congruent-2? (axiom-condition r1) (axiom-condition r2)) |
| 618 | 598 | ;;; |
| 619 | 599 | (defun rule-member (r l) |
| 620 | 600 | (declare (type axiom r) |
| 621 | (type list l) | |
| 622 | (values (or null t))) | |
| 601 | (type list l) | |
| 602 | (values (or null t))) | |
| 623 | 603 | (dolist (e l nil) |
| 624 | 604 | (when (rule-is-similar? r e) (return t)))) |
| 625 | 605 | |
| 634 | 614 | |
| 635 | 615 | (defun adjoin-rule (rule rs) |
| 636 | 616 | (declare (type axiom rule) |
| 637 | (type list rs) | |
| 638 | (values list)) | |
| 617 | (type list rs) | |
| 618 | (values list)) | |
| 639 | 619 | (do* ((lst rs (cdr lst)) |
| 640 | (r (car lst) (car lst))) | |
| 641 | ((null lst) (cons rule rs)) | |
| 620 | (r (car lst) (car lst))) | |
| 621 | ((null lst) (cons rule rs)) | |
| 642 | 622 | (when (rule-is-similar? rule r) |
| 643 | (when (and *chaos-verbose* | |
| 644 | (not (eq rule r)) | |
| 645 | (not (member (axiom-kind rule) .ext-rule-kinds.)) | |
| 646 | ) | |
| 647 | (with-output-msg () | |
| 648 | (format t "a similar pair of axioms is found:") | |
| 649 | (print-next) | |
| 650 | (format t "(1:~x)" (addr-of rule)) | |
| 651 | (print-axiom-brief rule) | |
| 652 | (print-next) | |
| 653 | (format t "(2:~x)" (addr-of r)) | |
| 654 | (print-axiom-brief r))) | |
| 623 | (when (and (or *chaos-verbose* *on-axiom-debug*) | |
| 624 | (not (eq rule r)) | |
| 625 | (not (member (axiom-kind rule) .ext-rule-kinds.))) | |
| 626 | (with-output-msg () | |
| 627 | (format t "a similar pair of axioms is found:") | |
| 628 | (print-next) | |
| 629 | (format t "(1:~x)" (addr-of rule)) | |
| 630 | (print-axiom-brief rule) | |
| 631 | (print-next) | |
| 632 | (format t "(2:~x)" (addr-of r)) | |
| 633 | (print-axiom-brief r))) | |
| 655 | 634 | (let ((newlhs (axiom-lhs rule)) |
| 656 | (oldlhs (axiom-lhs r))) | |
| 657 | (when (and (not (term-is-variable? newlhs)) | |
| 658 | (not (term-is-variable? oldlhs)) | |
| 659 | (not (method= (term-method newlhs) (term-method oldlhs))) | |
| 660 | (sort<= (term-sort oldlhs) (term-sort newlhs))) | |
| 661 | (rplaca lst rule)) | |
| 662 | (return-from adjoin-rule rs))))) | |
| 635 | (oldlhs (axiom-lhs r))) | |
| 636 | (when (and (not (term-is-variable? newlhs)) | |
| 637 | (not (term-is-variable? oldlhs)) | |
| 638 | (not (method= (term-method newlhs) (term-method oldlhs))) | |
| 639 | (sort<= (term-sort oldlhs) (term-sort newlhs))) | |
| 640 | (rplaca lst rule)) | |
| 641 | (return-from adjoin-rule rs))))) | |
| 663 | 642 | |
| 664 | 643 | ;;; RULE-OCCURS : rule ruleset -> Bool |
| 665 | 644 | ;;;----------------------------------------------------------------------------- |
| 667 | 646 | ;;; |
| 668 | 647 | (defun rule-occurs (rule rs) |
| 669 | 648 | (declare (type axiom rule) |
| 670 | (type list rs) | |
| 671 | (values (or null t))) | |
| 649 | (type list rs) | |
| 650 | (values (or null t))) | |
| 672 | 651 | (let ((newlhs (axiom-lhs rule))) |
| 673 | 652 | (do* ((lst rs (cdr lst)) |
| 674 | (r (car lst) (car lst))) | |
| 675 | ((null lst) nil) | |
| 653 | (r (car lst) (car lst))) | |
| 654 | ((null lst) nil) | |
| 676 | 655 | (when (and (rule-is-similar? rule r) |
| 677 | (let ((oldlhs (axiom-lhs r))) | |
| 678 | (and (or (term-is-variable? newlhs) | |
| 679 | (and (not (term-is-variable? oldlhs)) ;very defensive | |
| 680 | (method= (term-head newlhs) (term-head oldlhs)))) | |
| 681 | (sort<= (term-sort oldlhs) | |
| 682 | (term-sort newlhs))))) | |
| 683 | (return t))))) | |
| 656 | (let ((oldlhs (axiom-lhs r))) | |
| 657 | (and (or (term-is-variable? newlhs) | |
| 658 | (and (not (term-is-variable? oldlhs)) ;very defensive | |
| 659 | (method= (term-head newlhs) (term-head oldlhs)))) | |
| 660 | (sort<= (term-sort oldlhs) | |
| 661 | (term-sort newlhs))))) | |
| 662 | (return t))))) | |
| 684 | 663 | |
| 685 | 664 | ;;; *************** |
| 686 | 665 | ;;; RULE-RING UTILS |
| 690 | 669 | ;;; |
| 691 | 670 | (defun rule-ring-member (r rr) |
| 692 | 671 | (declare (type axiom r) |
| 693 | (type rule-ring rr) | |
| 694 | (values (or null t))) | |
| 672 | (type rule-ring rr) | |
| 673 | (values (or null t))) | |
| 695 | 674 | (do ((rule (initialize-rule-ring rr) (rule-ring-next rr))) |
| 696 | 675 | ((end-of-rule-ring rr) nil) |
| 697 | 676 | (when (rule-is-similar? r rule) (return t)))) |
| 704 | 683 | ;;; |
| 705 | 684 | (defun rule-ring-adjoin-rule (rr rule) |
| 706 | 685 | (declare (type rule-ring rr) |
| 707 | (type axiom rule) | |
| 708 | (values t)) | |
| 686 | (type axiom rule) | |
| 687 | (values t)) | |
| 709 | 688 | (do ((r (initialize-rule-ring rr) (rule-ring-next rr))) |
| 710 | 689 | ((end-of-rule-ring rr)) |
| 711 | 690 | (when (rule-is-similar? r rule) |
| 712 | 691 | ;; there exists similar rule. |
| 713 | 692 | ;; we don't add, but keeps higher (more general) one. |
| 714 | 693 | (unless *current-module* |
| 715 | (break "rule-ring-adjoin-rule: need current module")) | |
| 694 | (break "rule-ring-adjoin-rule: need current module")) | |
| 716 | 695 | (let ((newlhs (rule-lhs rule)) |
| 717 | (oldlhs (rule-lhs r))) | |
| 718 | ;; compare lhs of rules. | |
| 719 | (when (and (not (term-is-variable? newlhs)) | |
| 720 | (not (term-is-variable? oldlhs)) | |
| 721 | (not (method= (term-method newlhs) (term-method oldlhs))) | |
| 722 | (sort<= (term-sort oldlhs) (term-sort newlhs) | |
| 723 | *current-sort-order*)) | |
| 724 | ;; we keep higher one. | |
| 725 | (rplaca (rule-ring-current rr) rule)) | |
| 726 | (return-from rule-ring-adjoin-rule t)))) | |
| 696 | (oldlhs (rule-lhs r))) | |
| 697 | ;; compare lhs of rules. | |
| 698 | (when (and (not (term-is-variable? newlhs)) | |
| 699 | (not (term-is-variable? oldlhs)) | |
| 700 | (not (method= (term-method newlhs) (term-method oldlhs))) | |
| 701 | (sort<= (term-sort oldlhs) (term-sort newlhs) | |
| 702 | *current-sort-order*)) | |
| 703 | ;; we keep higher one. | |
| 704 | (rplaca (rule-ring-current rr) rule)) | |
| 705 | (return-from rule-ring-adjoin-rule t)))) | |
| 727 | 706 | ;; No similar rules. |
| 728 | 707 | (add-rule-to-ring rr rule) |
| 729 | 708 | nil) |
| 731 | 710 | ;;; *********************** |
| 732 | 711 | ;;; ADDING AXIOMS TO MODULE |
| 733 | 712 | ;;; *********************** |
| 734 | #|| | |
| 713 | ||
| 735 | 714 | (defun add-axiom-to-module (module ax) |
| 736 | (declare (type module module) | |
| 737 | (type axiom ax) | |
| 738 | (values t)) | |
| 739 | (if (memq (axiom-type ax) '(:equation :pignose-axiom :pignose-goal)) | |
| 740 | (push ax (module-equations module)) | |
| 741 | (push ax (module-rules module)))) | |
| 742 | ||# | |
| 743 | ||
| 744 | (defun add-axiom-to-module (module ax) | |
| 745 | (adjoin-axiom-to-module module ax) | |
| 746 | ) | |
| 715 | (adjoin-axiom-to-module module ax)) | |
| 747 | 716 | |
| 748 | 717 | (defun adjoin-axiom-to-module (module ax) |
| 749 | 718 | (declare (type module module) |
| 750 | (type axiom ax) | |
| 751 | (values t)) | |
| 752 | ;; (when (eq (object-context-mod ax) module) | |
| 753 | ;; (let ((labels (axiom-labels ax))) | |
| 754 | ;; (dolist (lab labels) | |
| 755 | ;; (symbol-table-add (module-symbol-table module) | |
| 756 | ;; lab | |
| 757 | ;; ax))) | |
| 758 | ;; ) | |
| 759 | (if (memq (axiom-type ax) '(:equation :pignose-axiom :pignose-goal)) | |
| 760 | (setf (module-equations module) | |
| 761 | (adjoin-rule ax (module-equations module))) | |
| 719 | (type axiom ax) | |
| 720 | (values t)) | |
| 721 | (with-in-module (module) | |
| 722 | (if (memq (axiom-type ax) '(:equation :pignose-axiom :pignose-goal)) | |
| 723 | (setf (module-equations module) | |
| 724 | (adjoin-rule ax (module-equations module))) | |
| 762 | 725 | (setf (module-rules module) |
| 763 | (adjoin-rule ax (module-rules module))))) | |
| 726 | (adjoin-rule ax (module-rules module)))))) | |
| 764 | 727 | |
| 765 | 728 | (defun add-rule-to-module (module rule) |
| 766 | 729 | (declare (type module module) |
| 767 | (type axiom rule) | |
| 768 | (values t)) | |
| 769 | (add-rule-to-method rule | |
| 770 | (term-head (axiom-lhs rule)) | |
| 771 | (module-opinfo-table module)) | |
| 772 | (pushnew rule (module-rewrite-rules module) | |
| 773 | :test #'rule-is-similar?)) | |
| 730 | (type axiom rule) | |
| 731 | (values t)) | |
| 732 | (with-in-module (module) | |
| 733 | (add-rule-to-method rule | |
| 734 | (term-head (axiom-lhs rule)) | |
| 735 | (module-opinfo-table module)) | |
| 736 | (pushnew rule (module-rewrite-rules module) | |
| 737 | :test #'rule-is-similar?))) | |
| 774 | 738 | |
| 775 | 739 | (defun add-rule-to-method (rule method |
| 776 | &optional (opinfo-table *current-opinfo-table*)) | |
| 740 | &optional (opinfo-table *current-opinfo-table*)) | |
| 777 | 741 | (declare (type axiom rule) |
| 778 | (type method method) | |
| 779 | (type hash-table opinfo-table)) | |
| 742 | (type method method) | |
| 743 | (type hash-table opinfo-table)) | |
| 780 | 744 | ;; set trans-rule flag. |
| 781 | 745 | (when (eq (axiom-type rule) :rule) |
| 782 | 746 | (setf (method-has-trans-rule method opinfo-table) t)) |
| 784 | 748 | (setf (method-rewrite-strategy method opinfo-table) nil) |
| 785 | 749 | ;; |
| 786 | 750 | (if (and (term-is-applform? (rule-rhs rule)) |
| 787 | (method= (rule-lhs rule) (term-method (rule-rhs rule)))) | |
| 751 | (method= (rule-lhs rule) (term-method (rule-rhs rule)))) | |
| 788 | 752 | (rule-ring-adjoin-rule (method-rules-with-same-top method opinfo-table) |
| 789 | rule) | |
| 753 | rule) | |
| 790 | 754 | (setf (method-rules-with-different-top method opinfo-table) |
| 791 | 755 | (adjoin-rule rule (method-rules-with-different-top method |
| 792 | opinfo-table))))) | |
| 756 | opinfo-table))))) | |
| 793 | 757 | |
| 794 | 758 | ;;; RULE-SUBSUMES : rule rule -> bool |
| 795 | 759 | ;;;----------------------------------------------------------------------------- |
| 797 | 761 | ;;; |
| 798 | 762 | (defun rule-subsumes (r1 r2) |
| 799 | 763 | (declare (type axiom r1 r2) |
| 800 | (values (or null t))) | |
| 764 | (values (or null t))) | |
| 765 | (when *on-axiom-debug* | |
| 766 | (format t "~%[rule-subsumes]:") | |
| 767 | (format t "~% r1: ") | |
| 768 | (print-axiom-brief r1) | |
| 769 | (format t "~% r2: ") | |
| 770 | (print-axiom-brief r2)) | |
| 801 | 771 | (or (eq r1 r2) |
| 802 | 772 | (let ((lhs1 (rule-lhs r1)) |
| 803 | (lhs2 (rule-lhs r2))) | |
| 804 | (or (term-is-variable? lhs1) | |
| 805 | (and (term-is-application-form? lhs1) | |
| 806 | (term-is-application-form? lhs2) | |
| 807 | (method-is-of-same-operator (term-method lhs1) | |
| 808 | (term-method lhs2)) | |
| 809 | (multiple-value-bind (gs subst no eeq) | |
| 810 | (first-match lhs1 lhs2) | |
| 811 | (declare (ignore gs)) | |
| 812 | (and (or eeq (not no)) | |
| 813 | (or (is-true? (rule-condition r1)) | |
| 814 | (let (($$trace-rewrite nil) | |
| 815 | ($$trace-rewrite-whole nil)) | |
| 816 | (let ((newcond | |
| 817 | (term-simplify | |
| 818 | (normalize-for-identity-total | |
| 819 | (substitution-partial-image | |
| 820 | subst | |
| 821 | (rule-condition r1)))))) | |
| 822 | (matches? newcond (rule-condition r2)) | |
| 823 | )))))))))) | |
| 773 | (lhs2 (rule-lhs r2))) | |
| 774 | (or (term-is-variable? lhs1) | |
| 775 | (and (term-is-application-form? lhs1) | |
| 776 | (term-is-application-form? lhs2) | |
| 777 | (method-is-of-same-operator (term-method lhs1) | |
| 778 | (term-method lhs2)) | |
| 779 | (multiple-value-bind (gs subst no eeq) | |
| 780 | (first-match lhs1 lhs2) | |
| 781 | (declare (ignore gs)) | |
| 782 | (and (or eeq (not no)) | |
| 783 | (or (is-true? (rule-condition r1)) | |
| 784 | (let (($$trace-rewrite nil) | |
| 785 | ($$trace-rewrite-whole nil)) | |
| 786 | (let ((newcond | |
| 787 | (term-simplify | |
| 788 | (normalize-for-identity-total | |
| 789 | (substitution-partial-image | |
| 790 | subst | |
| 791 | (rule-condition r1)))))) | |
| 792 | (matches? newcond (rule-condition r2)))))))))))) | |
| 824 | 793 | |
| 825 | 794 | (defun rule-strictly-subsumes (r1 r2) |
| 826 | 795 | (declare (type axiom r1 r2) |
| 827 | (values (or null t))) | |
| 796 | (values (or null t))) | |
| 828 | 797 | (and (rule-subsumes r1 r2) |
| 829 | 798 | (not (rule-subsumes r2 r1)))) |
| 830 | 799 | |
| 836 | 805 | ;;; |
| 837 | 806 | (defun get-rule-numbered (mod n) |
| 838 | 807 | (declare (type module mod) |
| 839 | (type fixnum n)) | |
| 808 | (type fixnum n)) | |
| 840 | 809 | (!setup-reduction mod) |
| 841 | 810 | (when (<= n 0) |
| 842 | 811 | (with-output-chaos-error () |
| 843 | 812 | (format t "rule number must be greater than 0.") |
| 844 | 813 | (chaos-to-top))) |
| 845 | 814 | (let* ((*module-all-rules-every* t) |
| 846 | (res (nth (1- n) (get-module-axioms mod t)))) | |
| 815 | (res (nth (1- n) (get-module-axioms mod t)))) | |
| 847 | 816 | (if (null res) |
| 848 | (with-output-chaos-error () | |
| 849 | (format t "selected rule doesn't exist, ~d" n) | |
| 850 | (chaos-to-top)) | |
| 851 | res))) | |
| 817 | (with-output-chaos-error () | |
| 818 | (format t "selected rule doesn't exist, ~d" n) | |
| 819 | (chaos-to-top)) | |
| 820 | res))) | |
| 852 | 821 | |
| 853 | 822 | (defun get-all-rules-labelled (mod l) |
| 854 | 823 | (declare (type module mod) |
| 855 | (type (or symbol simple-string) l) | |
| 856 | (values list)) | |
| 824 | (type (or symbol simple-string) l) | |
| 825 | (values list)) | |
| 857 | 826 | (!setup-reduction mod) |
| 858 | 827 | (when (stringp l) |
| 859 | 828 | (setq l (intern l))) |
| 860 | 829 | (let ((res nil) |
| 861 | (*module-all-rules-every* t)) | |
| 830 | (*module-all-rules-every* t)) | |
| 862 | 831 | (dolist (rul (get-module-axioms mod t)) |
| 863 | 832 | (when (memq l (axiom-labels rul)) |
| 864 | (push rul res))) | |
| 833 | (push rul res))) | |
| 865 | 834 | res)) |
| 866 | 835 | |
| 867 | 836 | (defun get-rule-labelled (mod l) |
| 868 | 837 | (declare (type module mod) |
| 869 | (type (or symbol simple-string) l)) | |
| 838 | (type (or symbol simple-string) l)) | |
| 870 | 839 | (let ((val (get-all-rules-labelled mod l))) |
| 871 | 840 | (if (null val) |
| 872 | (with-output-chaos-error ('no-rule) | |
| 873 | (format t "No rule with label: ~a" l)) | |
| 874 | (if (and val (null (cdr val))) | |
| 875 | (car val) | |
| 876 | (with-output-chaos-error ('no-unique-rule) | |
| 877 | (format t "No unique rule with label: ~a" l)))))) | |
| 841 | (with-output-chaos-error ('no-rule) | |
| 842 | (format t "No rule with label: ~a" l)) | |
| 843 | (if (and val (null (cdr val))) | |
| 844 | (car val) | |
| 845 | (with-output-chaos-error ('no-unique-rule) | |
| 846 | (format t "No unique rule with label: ~a" l)))))) | |
| 878 | 847 | |
| 879 | 848 | ;;; ************************ |
| 880 | 849 | ;;; COMPUTING RULE SPECIFIER |
| 887 | 856 | (if (rule-is-builtin rule) |
| 888 | 857 | rule |
| 889 | 858 | (make-rule :lhs (axiom-rhs rule) |
| 890 | :rhs (axiom-lhs rule) | |
| 891 | :condition (axiom-condition rule) | |
| 892 | :labels (axiom-labels rule) | |
| 893 | :kind (axiom-kind rule) | |
| 894 | :type (axiom-type rule) | |
| 895 | ;; :meta-and-or (axiom-meta-and-or rule) | |
| 896 | ;; :no-method-computation t | |
| 897 | ))) | |
| 859 | :rhs (axiom-lhs rule) | |
| 860 | :condition (axiom-condition rule) | |
| 861 | :labels (axiom-labels rule) | |
| 862 | :kind (axiom-kind rule) | |
| 863 | :type (axiom-type rule)))) | |
| 898 | 864 | |
| 899 | 865 | (defun make-rule-instance (rule subst) |
| 900 | 866 | (declare (type axiom rule) |
| 901 | (type list subst) | |
| 902 | (values axiom)) | |
| 867 | (type list subst) | |
| 868 | (values axiom)) | |
| 903 | 869 | (when (and rule (rule-is-builtin rule)) |
| 904 | 870 | (with-output-chaos-error ('internal-error) |
| 905 | 871 | (format t "cannot instantiate builtin rules!"))) |
| 907 | 873 | :lhs (substitution-image! subst (axiom-lhs rule)) |
| 908 | 874 | :rhs (substitution-image! subst (axiom-rhs rule)) |
| 909 | 875 | :condition (let ((cnd (axiom-condition rule))) |
| 910 | (if (eq *bool-true* cnd) | |
| 911 | cnd | |
| 912 | (substitution-image! subst cnd))) | |
| 876 | (if (eq *bool-true* cnd) | |
| 877 | cnd | |
| 878 | (substitution-image! subst cnd))) | |
| 913 | 879 | :labels (axiom-labels rule) |
| 914 | 880 | :type (axiom-type rule) |
| 915 | 881 | :kind (axiom-kind rule) |
| 922 | 888 | ;;; |
| 923 | 889 | (defun compute-action-rule (rule-spec subst-list &optional selectors) |
| 924 | 890 | (declare (ignore selectors) |
| 925 | (type list rule-spec subst-list selectors) | |
| 926 | (values axiom module)) | |
| 891 | (type list rule-spec subst-list selectors) | |
| 892 | (values axiom module)) | |
| 927 | 893 | (let ((mod (first rule-spec)) |
| 928 | (rule-id (second rule-spec)) | |
| 929 | (rule nil)) ; the result | |
| 894 | (rule-id (second rule-spec)) | |
| 895 | (rule nil)) ; the result | |
| 930 | 896 | (declare (type (or module modexp) mod) |
| 931 | (type simple-string rule-id)) | |
| 897 | (type simple-string rule-id)) | |
| 932 | 898 | ;; we always need rule specifier |
| 933 | 899 | (when (equal "" rule-id) |
| 934 | 900 | (with-output-chaos-error ('invalid-rule-spec) |
| 935 | (format t "No rule number or name is specified.") | |
| 936 | )) | |
| 901 | (format t "No rule number or name is specified."))) | |
| 937 | 902 | ;; get module in which the specified rule is looked up |
| 938 | (if (equal "" mod) | |
| 939 | (setq mod *last-module*) | |
| 940 | (if (and *last-module* | |
| 941 | (equal "%" (module-name *last-module*)) | |
| 942 | (module-submodules *last-module*) | |
| 943 | (equal mod | |
| 944 | (module-name | |
| 945 | (caar (module-submodules *last-module*))))) | |
| 946 | (setq mod *last-module*) | |
| 947 | ;; we also find in local modules | |
| 948 | (setq mod (eval-modexp mod t)))) | |
| 949 | ;; | |
| 950 | (unless mod | |
| 951 | (with-output-chaos-error ('no-context) | |
| 952 | (princ "no context module."))) | |
| 953 | ;; | |
| 954 | (when (modexp-is-error mod) | |
| 955 | (let ((nxt (eval-mod (list (car rule-spec))))) | |
| 956 | (if (modexp-is-error nxt) | |
| 957 | (with-output-chaos-error ('invalid-module) | |
| 958 | (format t "module is undefined or unreachable: ~a" (car rule-spec)) | |
| 959 | ) | |
| 960 | (setq mod nxt)))) | |
| 961 | ;; check context | |
| 962 | (unless (eq *last-module* mod) | |
| 963 | (let ((e-mod (assoc mod (module-all-submodules *last-module*)))) | |
| 964 | (unless e-mod | |
| 965 | (with-output-chaos-error ('invalid-context) | |
| 966 | (format t "specified module is out of current context: ") | |
| 967 | (print-simple-mod-name mod))) | |
| 968 | (unless (member (cdr e-mod) | |
| 969 | '(:protecting :extending :using)) | |
| 970 | (with-output-chaos-error ('invalid-rule-ref) | |
| 971 | (format t "you cannot refer the rule ~a of module " rule-spec) | |
| 972 | (print-simple-mod-name mod) | |
| 973 | (princ " directly."))))) | |
| 974 | ;; | |
| 975 | (with-in-module (mod) | |
| 976 | ;; find specified rule | |
| 977 | (if (and (< 0 (length rule-id)) | |
| 978 | (every #'digit-char-p rule-id)) | |
| 979 | (setq rule (get-rule-numbered mod (str-to-int rule-id))) | |
| 980 | (setq rule (get-rule-labelled mod rule-id))) | |
| 981 | ;; make rule reverse order if need | |
| 903 | (let ((cur-context (get-context-module t))) | |
| 904 | (if (equal "" mod) | |
| 905 | (setq mod cur-context) | |
| 906 | (if (and cur-context | |
| 907 | (equal "%" (module-name cur-context)) | |
| 908 | (module-submodules cur-context) | |
| 909 | (equal mod | |
| 910 | (module-name | |
| 911 | (caar (module-submodules cur-context))))) | |
| 912 | (setq mod cur-context) | |
| 913 | ;; we also find in local modules | |
| 914 | (setq mod (eval-modexp mod t)))) | |
| 915 | (unless mod | |
| 916 | (with-output-chaos-error ('no-context) | |
| 917 | (princ "no context module."))) | |
| 918 | (when (modexp-is-error mod) | |
| 919 | (let ((nxt (eval-mod (list (car rule-spec))))) | |
| 920 | (if (modexp-is-error nxt) | |
| 921 | (with-output-chaos-error ('invalid-module) | |
| 922 | (format t "module is undefined or unreachable: ~a" (car rule-spec))) | |
| 923 | (setq mod nxt)))) | |
| 924 | ;; check context | |
| 925 | (unless (eq cur-context mod) | |
| 926 | (let ((e-mod (assoc mod (module-all-submodules cur-context)))) | |
| 927 | (unless e-mod | |
| 928 | (with-output-chaos-error ('invalid-context) | |
| 929 | (format t "specified module is out of current context: ") | |
| 930 | (print-simple-mod-name mod))) | |
| 931 | (unless (member (cdr e-mod) | |
| 932 | '(:protecting :extending :using)) | |
| 933 | (with-output-chaos-error ('invalid-rule-ref) | |
| 934 | (format t "you cannot refer the rule ~a of module " rule-spec) | |
| 935 | (print-simple-mod-name mod) | |
| 936 | (princ " directly."))))) | |
| 937 | ;; do search in 'mod' | |
| 938 | (with-in-module (mod) | |
| 939 | ;; find specified rule | |
| 940 | (if (and (< 0 (length rule-id)) | |
| 941 | (every #'digit-char-p rule-id)) | |
| 942 | (setq rule (get-rule-numbered mod (str-to-int rule-id))) | |
| 943 | (setq rule (get-rule-labelled mod rule-id))) | |
| 944 | ;; make rule reverse order if need | |
| 982 | 945 | (when (nth 2 rule-spec) (setq rule (make-rule-reverse rule))) |
| 983 | 946 | ;; apply variable substitution |
| 984 | 947 | (when subst-list |
| 985 | (setq rule | |
| 986 | (make-rule-instance rule (compute-variable-substitution | |
| 987 | rule subst-list)))) | |
| 988 | ) | |
| 948 | (setq rule | |
| 949 | (make-rule-instance rule (compute-variable-substitution | |
| 950 | rule subst-list))))) | |
| 989 | 951 | ;; the result |
| 990 | (when *on-axiom-debug* | |
| 991 | (with-output-simple-msg () | |
| 992 | (princ "[compute-action-rule]: rule= ") | |
| 993 | (print-chaos-object rule))) | |
| 994 | ;; | |
| 995 | (values rule mod) | |
| 996 | )) | |
| 952 | (when *on-axiom-debug* | |
| 953 | (with-output-simple-msg () | |
| 954 | (princ "[compute-action-rule]: rule= ") | |
| 955 | (print-chaos-object rule))) | |
| 956 | (values rule mod)))) | |
| 997 | 957 | |
| 998 | 958 | |
| 999 | 959 | ;;; CHECK-AXIOM-ERROR-METHOD : Module Axiom -> Axiom |
| 1003 | 963 | |
| 1004 | 964 | (defun check-axiom-error-method (module axiom &optional message?) |
| 1005 | 965 | (declare (type module module) |
| 1006 | (type axiom axiom) | |
| 1007 | (type (or null t) message?) | |
| 1008 | (values axiom)) | |
| 966 | (type axiom axiom) | |
| 967 | (type (or null t) message?) | |
| 968 | (values axiom)) | |
| 1009 | 969 | (let ((new-axiom (cdr (assq axiom (module-axioms-to-be-fixed module)))) |
| 1010 | (error-operators (module-error-methods module))) | |
| 970 | (error-operators (module-error-methods module))) | |
| 1011 | 971 | (macrolet ((check-check (_eops) |
| 1012 | ` (when (every #'(lambda (x) | |
| 1013 | #|| | |
| 1014 | (and (memq x error-operators) | |
| 1015 | (not (method-is-user-defined-error-method | |
| 1016 | x))) | |
| 1017 | ||# | |
| 1018 | (memq x error-operators) | |
| 1019 | ) | |
| 1020 | ,_eops) | |
| 1021 | (setq ,_eops nil)))) | |
| 972 | ` (when (every #'(lambda (x) | |
| 973 | (memq x error-operators)) | |
| 974 | ,_eops) | |
| 975 | (setq ,_eops nil)))) | |
| 1022 | 976 | ;; |
| 1023 | 977 | (if new-axiom |
| 1024 | new-axiom | |
| 1025 | (let* ((lhs (axiom-lhs axiom)) | |
| 1026 | (lhs-e (term-error-operators&variables lhs nil)) | |
| 1027 | (rhs (axiom-rhs axiom)) | |
| 1028 | (rhs-e (term-error-operators&variables rhs nil)) | |
| 1029 | (cond (axiom-condition axiom)) | |
| 1030 | (cond-e (term-error-operators&variables cond nil))) | |
| 1031 | (when (and (or lhs-e rhs-e cond-e) | |
| 1032 | message?) | |
| 1033 | (when *chaos-verbose* | |
| 1034 | (with-output-chaos-warning () | |
| 1035 | (format t "axiom : ") | |
| 1036 | (print-chaos-object axiom) | |
| 1037 | (print-next) | |
| 1038 | (format t "contains error operators.")))) | |
| 1039 | ;; check | |
| 1040 | (when *optimize-error-operators* | |
| 1041 | (check-check lhs-e) | |
| 1042 | (check-check rhs-e) | |
| 1043 | (check-check cond-e)) | |
| 1044 | ;; | |
| 1045 | (if (or lhs-e rhs-e cond-e) | |
| 1046 | (let ((vars (mapcar #'(lambda (x) (cons x x)) (term-variables lhs)))) | |
| 1047 | (when lhs-e | |
| 1048 | (push (cons lhs | |
| 1049 | (or (cdr (assq lhs | |
| 1050 | (module-terms-to-be-fixed module))) | |
| 1051 | (setq lhs | |
| 1052 | (copy-term-using-variable lhs vars)))) | |
| 1053 | (module-terms-to-be-fixed module))) | |
| 1054 | (when rhs-e | |
| 1055 | (push (cons rhs | |
| 1056 | (or (cdr (assq rhs | |
| 1057 | (module-terms-to-be-fixed module))) | |
| 1058 | (setq rhs | |
| 1059 | (copy-term-using-variable rhs vars)))) | |
| 1060 | (module-terms-to-be-fixed module))) | |
| 1061 | (when cond-e | |
| 1062 | (push (cons cond | |
| 1063 | (or (cdr (assq cond | |
| 1064 | (module-terms-to-be-fixed module))) | |
| 1065 | (setq cond | |
| 1066 | (copy-term-using-variable cond vars)))) | |
| 1067 | (module-terms-to-be-fixed module))) | |
| 1068 | (setq new-axiom | |
| 1069 | (make-rule :lhs lhs | |
| 1070 | :rhs rhs | |
| 1071 | :condition cond | |
| 1072 | :labels (axiom-labels axiom) | |
| 1073 | :type (axiom-type axiom) | |
| 1074 | :kind (axiom-kind axiom) | |
| 1075 | :no-method-computation t | |
| 1076 | :meta-and-or (axiom-meta-and-or axiom))) | |
| 1077 | (push (cons axiom new-axiom) | |
| 1078 | (module-axioms-to-be-fixed module)) | |
| 1079 | new-axiom) | |
| 1080 | axiom)))))) | |
| 978 | new-axiom | |
| 979 | (let* ((lhs (axiom-lhs axiom)) | |
| 980 | (lhs-e (term-error-operators&variables lhs nil)) | |
| 981 | (rhs (axiom-rhs axiom)) | |
| 982 | (rhs-e (term-error-operators&variables rhs nil)) | |
| 983 | (cond (axiom-condition axiom)) | |
| 984 | (cond-e (term-error-operators&variables cond nil))) | |
| 985 | (when (and (or lhs-e rhs-e cond-e) | |
| 986 | message?) | |
| 987 | (when t ; *chaos-verbose* ; should always be reported. | |
| 988 | (with-output-chaos-warning () | |
| 989 | (format t "axiom : ") | |
| 990 | (print-chaos-object axiom) | |
| 991 | (print-next) | |
| 992 | (format t "contains error operators.")))) | |
| 993 | ;; check | |
| 994 | (when *optimize-error-operators* | |
| 995 | (check-check lhs-e) | |
| 996 | (check-check rhs-e) | |
| 997 | (check-check cond-e)) | |
| 998 | ;; | |
| 999 | (if (or lhs-e rhs-e cond-e) | |
| 1000 | (let ((vars (mapcar #'(lambda (x) (cons x x)) (term-variables lhs)))) | |
| 1001 | (when lhs-e | |
| 1002 | (push (cons lhs | |
| 1003 | (or (cdr (assq lhs | |
| 1004 | (module-terms-to-be-fixed module))) | |
| 1005 | (setq lhs | |
| 1006 | (copy-term-using-variable lhs vars)))) | |
| 1007 | (module-terms-to-be-fixed module))) | |
| 1008 | (when rhs-e | |
| 1009 | (push (cons rhs | |
| 1010 | (or (cdr (assq rhs | |
| 1011 | (module-terms-to-be-fixed module))) | |
| 1012 | (setq rhs | |
| 1013 | (copy-term-using-variable rhs vars)))) | |
| 1014 | (module-terms-to-be-fixed module))) | |
| 1015 | (when cond-e | |
| 1016 | (push (cons cond | |
| 1017 | (or (cdr (assq cond | |
| 1018 | (module-terms-to-be-fixed module))) | |
| 1019 | (setq cond | |
| 1020 | (copy-term-using-variable cond vars)))) | |
| 1021 | (module-terms-to-be-fixed module))) | |
| 1022 | (setq new-axiom | |
| 1023 | (make-rule :lhs lhs | |
| 1024 | :rhs rhs | |
| 1025 | :condition cond | |
| 1026 | :labels (axiom-labels axiom) | |
| 1027 | :type (axiom-type axiom) | |
| 1028 | :kind (axiom-kind axiom) | |
| 1029 | :no-method-computation t | |
| 1030 | :meta-and-or (axiom-meta-and-or axiom))) | |
| 1031 | (push (cons axiom new-axiom) | |
| 1032 | (module-axioms-to-be-fixed module)) | |
| 1033 | new-axiom) | |
| 1034 | axiom)))))) | |
| 1081 | 1035 | |
| 1082 | 1036 | ;;; |
| 1083 | 1037 | ;;; RECREATE-ERROR-AXIOM |
| 1084 | 1038 | ;;; |
| 1085 | 1039 | (defun recreate-error-axiom (axiom module) |
| 1086 | 1040 | (declare (type axiom axiom) |
| 1087 | (type module module) | |
| 1088 | (values axiom)) | |
| 1041 | (type module module) | |
| 1042 | (values axiom)) | |
| 1089 | 1043 | (let ((new-axiom (cdr (assq axiom (module-axioms-to-be-fixed module)))) |
| 1090 | (error-operators (module-error-methods module))) | |
| 1044 | (error-operators (module-error-methods module))) | |
| 1091 | 1045 | (declare (type (or null axiom ) new-axiom) |
| 1092 | (type list error-operators)) | |
| 1046 | (type list error-operators)) | |
| 1093 | 1047 | (macrolet ((check-check (_eops) |
| 1094 | ` (when (every #'(lambda (x) | |
| 1095 | #|| | |
| 1096 | (and (memq x error-operators) | |
| 1097 | (not (method-is-user-defined-error-method | |
| 1098 | x))) | |
| 1099 | ||# | |
| 1100 | (memq x error-operators) | |
| 1101 | ) | |
| 1102 | ,_eops) | |
| 1103 | (setq ,_eops nil)))) | |
| 1048 | ` (when (every #'(lambda (x) | |
| 1049 | (memq x error-operators)) | |
| 1050 | ,_eops) | |
| 1051 | (setq ,_eops nil)))) | |
| 1104 | 1052 | ;; |
| 1105 | 1053 | (if new-axiom |
| 1106 | new-axiom | |
| 1107 | (let* ((lhs (axiom-lhs axiom)) | |
| 1108 | (lhs-e (term-error-operators&variables lhs nil)) | |
| 1109 | (rhs (axiom-rhs axiom)) | |
| 1110 | (rhs-e (term-error-operators&variables rhs nil)) | |
| 1111 | (cond (axiom-condition axiom)) | |
| 1112 | (cond-e (term-error-operators&variables cond nil)) | |
| 1113 | (terms-to-be-fixed nil) | |
| 1114 | ) | |
| 1115 | (declare (type term lhs rhs cond) | |
| 1116 | (type list lhs-e rhs-e terms-to-be-fixed)) | |
| 1117 | ;; check | |
| 1118 | (when *optimize-error-operators* | |
| 1119 | (check-check lhs-e) | |
| 1120 | (check-check rhs-e) | |
| 1121 | (check-check cond-e)) | |
| 1122 | ;; | |
| 1123 | (when (not (or lhs-e rhs-e cond-e)) | |
| 1124 | (return-from recreate-error-axiom axiom)) | |
| 1125 | ;; | |
| 1126 | (let ((vars (mapcar #'(lambda (x) (cons x x)) (term-variables lhs)))) | |
| 1127 | (when lhs-e | |
| 1128 | (setq lhs (copy-term-using-variable lhs vars)) | |
| 1129 | (push lhs terms-to-be-fixed)) | |
| 1130 | (when rhs-e | |
| 1131 | (setq rhs (copy-term-using-variable rhs vars)) | |
| 1132 | (push rhs terms-to-be-fixed)) | |
| 1133 | (when cond-e | |
| 1134 | (setq cond (copy-term-using-variable cond vars)) | |
| 1135 | (push cond terms-to-be-fixed)) | |
| 1136 | ;; | |
| 1137 | (with-in-module (module) | |
| 1138 | (let ((name (module-name module)) | |
| 1139 | (op-map nil) | |
| 1140 | (sort-map nil)) | |
| 1141 | (declare (type list op-map sort-map)) | |
| 1142 | (cond ((int-instantiation-p name) | |
| 1143 | (let ((modmorph (views-to-modmorph | |
| 1144 | (int-instantiation-module name) | |
| 1145 | (int-instantiation-args name)))) | |
| 1146 | (setq op-map (modmorph-op modmorph)) | |
| 1147 | (setq sort-map (modmorph-sort modmorph)))) | |
| 1148 | ((int-rename-p name) | |
| 1149 | (setq op-map (int-rename-op-maps name)) | |
| 1150 | (setq sort-map (int-rename-sort-maps name)))) | |
| 1151 | ;; | |
| 1152 | (dolist (term terms-to-be-fixed) | |
| 1153 | (replace-error-method module term op-map sort-map)))) | |
| 1154 | ;; | |
| 1155 | (setq new-axiom | |
| 1156 | (make-rule :lhs lhs | |
| 1157 | :rhs rhs | |
| 1158 | :condition cond | |
| 1159 | :labels (axiom-labels axiom) | |
| 1160 | :type (axiom-type axiom) | |
| 1161 | :kind (axiom-kind axiom) | |
| 1162 | :no-method-computation t | |
| 1163 | :meta-and-or (axiom-meta-and-or axiom))) | |
| 1164 | new-axiom)))))) | |
| 1054 | new-axiom | |
| 1055 | (let* ((lhs (axiom-lhs axiom)) | |
| 1056 | (lhs-e (term-error-operators&variables lhs nil)) | |
| 1057 | (rhs (axiom-rhs axiom)) | |
| 1058 | (rhs-e (term-error-operators&variables rhs nil)) | |
| 1059 | (cond (axiom-condition axiom)) | |
| 1060 | (cond-e (term-error-operators&variables cond nil)) | |
| 1061 | (terms-to-be-fixed nil) | |
| 1062 | ) | |
| 1063 | (declare (type term lhs rhs cond) | |
| 1064 | (type list lhs-e rhs-e terms-to-be-fixed)) | |
| 1065 | ;; check | |
| 1066 | (when *optimize-error-operators* | |
| 1067 | (check-check lhs-e) | |
| 1068 | (check-check rhs-e) | |
| 1069 | (check-check cond-e)) | |
| 1070 | ;; | |
| 1071 | (when (not (or lhs-e rhs-e cond-e)) | |
| 1072 | (return-from recreate-error-axiom axiom)) | |
| 1073 | ;; | |
| 1074 | (let ((vars (mapcar #'(lambda (x) (cons x x)) (term-variables lhs)))) | |
| 1075 | (when lhs-e | |
| 1076 | (setq lhs (copy-term-using-variable lhs vars)) | |
| 1077 | (push lhs terms-to-be-fixed)) | |
| 1078 | (when rhs-e | |
| 1079 | (setq rhs (copy-term-using-variable rhs vars)) | |
| 1080 | (push rhs terms-to-be-fixed)) | |
| 1081 | (when cond-e | |
| 1082 | (setq cond (copy-term-using-variable cond vars)) | |
| 1083 | (push cond terms-to-be-fixed)) | |
| 1084 | ;; | |
| 1085 | (with-in-module (module) | |
| 1086 | (let ((name (module-name module)) | |
| 1087 | (op-map nil) | |
| 1088 | (sort-map nil)) | |
| 1089 | (declare (type list op-map sort-map)) | |
| 1090 | (cond ((int-instantiation-p name) | |
| 1091 | (let ((modmorph (views-to-modmorph | |
| 1092 | (int-instantiation-module name) | |
| 1093 | (int-instantiation-args name)))) | |
| 1094 | (setq op-map (modmorph-op modmorph)) | |
| 1095 | (setq sort-map (modmorph-sort modmorph)))) | |
| 1096 | ((int-rename-p name) | |
| 1097 | (setq op-map (int-rename-op-maps name)) | |
| 1098 | (setq sort-map (int-rename-sort-maps name)))) | |
| 1099 | ;; | |
| 1100 | (dolist (term terms-to-be-fixed) | |
| 1101 | (replace-error-method module term op-map sort-map)))) | |
| 1102 | ;; | |
| 1103 | (setq new-axiom | |
| 1104 | (make-rule :lhs lhs | |
| 1105 | :rhs rhs | |
| 1106 | :condition cond | |
| 1107 | :labels (axiom-labels axiom) | |
| 1108 | :type (axiom-type axiom) | |
| 1109 | :kind (axiom-kind axiom) | |
| 1110 | :no-method-computation t | |
| 1111 | :meta-and-or (axiom-meta-and-or axiom))) | |
| 1112 | new-axiom)))))) | |
| 1165 | 1113 | |
| 1166 | 1114 | ;;; EOF |
| 0 | 0 | ;;;-*- Mode:LISP; Package:CHAOS; Base:10; Syntax:Common-lisp -*- |
| 1 | 1 | ;;; |
| 2 | ;;; Copyright (c) 2000-2014, Toshimi Sawada. All rights reserved. | |
| 2 | ;;; Copyright (c) 2000-2015, Toshimi Sawada. All rights reserved. | |
| 3 | 3 | ;;; |
| 4 | 4 | ;;; Redistribution and use in source and binary forms, with or without |
| 5 | 5 | ;;; modification, are permitted provided that the following conditions |
| 27 | 27 | ;;; |
| 28 | 28 | (in-package :chaos) |
| 29 | 29 | #|============================================================================== |
| 30 | System: Chaos | |
| 31 | Module: construct | |
| 32 | File: beh.lisp | |
| 30 | System: Chaos | |
| 31 | Module: construct | |
| 32 | File: beh.lisp | |
| 33 | 33 | ==============================================================================|# |
| 34 | 34 | #-:chaos-debug |
| 35 | 35 | (declaim (optimize (speed 3) (safety 0) #-GCL (debug 0))) |
| 40 | 40 | ;;; stuff supporting proof in behavioural specification. |
| 41 | 41 | ;;; |
| 42 | 42 | (defstruct (beh-stuff (:print-function print-beh-stuff)) |
| 43 | (hs nil) ; hidden sort | |
| 44 | (attributes nil) ; list of attributes | |
| 45 | (methods nil) ; list of methods | |
| 46 | (axioms nil) ; axioms generated. | |
| 47 | (theorem nil) ; ceq t =*= t' = true | |
| 48 | ; if attr(t,d) == attr(t',d) and ... | |
| 49 | (assumptions nil) ; eq attr(`t,`d) = attr(`t',`d) | |
| 50 | (targets nil) ; list of terms to be evaluated to true | |
| 51 | ; method(`d,`t) =*= method(`d,`t') | |
| 43 | (hs nil) ; hidden sort | |
| 44 | (attributes nil) ; list of attributes | |
| 45 | (methods nil) ; list of methods | |
| 46 | (axioms nil) ; axioms generated. | |
| 47 | (theorem nil) ; ceq t =*= t' = true | |
| 48 | ; if attr(t,d) == attr(t',d) and ... | |
| 49 | (assumptions nil) ; eq attr(`t,`d) = attr(`t',`d) | |
| 50 | (targets nil) ; list of terms to be evaluated to true | |
| 51 | ; method(`d,`t) =*= method(`d,`t') | |
| 52 | 52 | ) |
| 53 | 53 | |
| 54 | 54 | (defun print-beh-stuff (obj stream &rest ignore) |
| 55 | 55 | (declare (ignore ignore) |
| 56 | (type beh-stuff obj) | |
| 57 | (type stream stream) | |
| 58 | (values t)) | |
| 56 | (type beh-stuff obj) | |
| 57 | (type stream stream) | |
| 58 | (values t)) | |
| 59 | 59 | (let ((*standard-output* stream)) |
| 60 | 60 | (print-next) |
| 61 | 61 | (format t "Hidden sort : ") |
| 64 | 64 | (format t "axioms : ") |
| 65 | 65 | (let ((*print-indent* (+ *print-indent* 2))) |
| 66 | 66 | (dolist (ax (beh-stuff-axioms obj)) |
| 67 | (print-next) | |
| 68 | (print-chaos-object ax))) | |
| 67 | (print-next) | |
| 68 | (print-chaos-object ax))) | |
| 69 | 69 | (print-next) |
| 70 | 70 | (format t "theorem : ") |
| 71 | 71 | (let ((*print-indent* (+ *print-indent* 2))) |
| 75 | 75 | (format t "assumptions : ") |
| 76 | 76 | (let ((*print-indent* (+ *print-indent* 2))) |
| 77 | 77 | (dolist (as (beh-stuff-assumptions obj)) |
| 78 | (print-next) | |
| 79 | (print-chaos-object as))) | |
| 78 | (print-next) | |
| 79 | (print-chaos-object as))) | |
| 80 | 80 | (print-next) |
| 81 | 81 | (format t "targets :") |
| 82 | 82 | (let ((*print-indent* (+ 2 *print-indent*))) |
| 83 | 83 | (dolist (tg (beh-stuff-targets obj)) |
| 84 | (print-next) | |
| 85 | (print-chaos-object tg))) | |
| 86 | )) | |
| 87 | ||
| 88 | ;;; (defvar *beh-debug* nil) | |
| 84 | (print-next) | |
| 85 | (print-chaos-object tg))))) | |
| 89 | 86 | |
| 90 | 87 | (defun construct-beh-stuff (module) |
| 91 | 88 | (declare (type module module) |
| 92 | (values list)) | |
| 93 | (setf (module-beh-stuff module) nil) ; reset to initial. | |
| 89 | (values list)) | |
| 90 | (setf (module-beh-stuff module) nil) ; reset to initial. | |
| 94 | 91 | (let ((methods (module-beh-methods module)) |
| 95 | (attributes (module-beh-attributes module))) | |
| 92 | (attributes (module-beh-attributes module))) | |
| 96 | 93 | (declare (type list methods attributes)) |
| 97 | 94 | (unless (and attributes |
| 98 | (or (some #'(lambda (x) (eq module (method-module x))) | |
| 99 | methods) | |
| 100 | (some #'(lambda (x) (eq module (method-module x))) | |
| 101 | attributes))) | |
| 95 | (or (some #'(lambda (x) (eq module (method-module x))) | |
| 96 | methods) | |
| 97 | (some #'(lambda (x) (eq module (method-module x))) | |
| 98 | attributes))) | |
| 102 | 99 | (return-from construct-beh-stuff nil)) |
| 103 | 100 | ;; |
| 104 | 101 | (let ((beh-list nil) |
| 105 | (beh nil)) | |
| 102 | (beh nil)) | |
| 106 | 103 | (declare (type list beh-list)) |
| 107 | 104 | (dolist (s (module-all-sorts module)) |
| 108 | (when (and (sort-is-hidden s) | |
| 109 | (not (or (sort= s *huniversal-sort*) | |
| 110 | (sort= s *hbottom-sort*)))) | |
| 111 | (setq beh (make-beh-stuff :hs s)) | |
| 112 | ;; | |
| 113 | (dolist (m methods) | |
| 114 | (let ((c (find-if #'(lambda (x) (sort-is-hidden x)) (method-arity m)))) | |
| 115 | (when (sort= c s) | |
| 116 | (push m (beh-stuff-methods beh))))) | |
| 117 | ;; | |
| 118 | (dolist (attr attributes) | |
| 119 | (let ((as (dolist (x (method-arity attr)) | |
| 120 | (when (sort-is-hidden x) (return x))))) | |
| 121 | (when (sort= as s) | |
| 122 | (push attr (beh-stuff-attributes beh))))) | |
| 123 | ;; | |
| 124 | (when (beh-stuff-attributes beh) | |
| 125 | (push beh beh-list)) | |
| 126 | ||
| 127 | #|| | |
| 128 | (if (or (null (beh-stuff-methods beh)) | |
| 129 | (null (beh-stuff-attributes beh))) | |
| 130 | (progn | |
| 131 | (unless (beh-stuff-methods beh) | |
| 132 | (with-output-chaos-warning () | |
| 133 | (princ "there are no methods defined on hidden sort ") | |
| 134 | (print-sort-name s module))) | |
| 135 | (unless (beh-stuff-attributes beh) | |
| 136 | (with-output-chaos-warning () | |
| 137 | (princ "there are no attributes defined on hidden sort ") | |
| 138 | (print-sort-name s module)))) | |
| 139 | (push beh beh-list)) | |
| 140 | ||# | |
| 141 | )) | |
| 105 | (when (and (sort-is-hidden s) | |
| 106 | (not (or (sort= s *huniversal-sort*) | |
| 107 | (sort= s *hbottom-sort*)))) | |
| 108 | (setq beh (make-beh-stuff :hs s)) | |
| 109 | ;; | |
| 110 | (dolist (m methods) | |
| 111 | (let ((c (find-if #'(lambda (x) (sort-is-hidden x)) (method-arity m)))) | |
| 112 | (when (sort= c s) | |
| 113 | (push m (beh-stuff-methods beh))))) | |
| 114 | ;; | |
| 115 | (dolist (attr attributes) | |
| 116 | (let ((as (dolist (x (method-arity attr)) | |
| 117 | (when (sort-is-hidden x) (return x))))) | |
| 118 | (when (sort= as s) | |
| 119 | (push attr (beh-stuff-attributes beh))))) | |
| 120 | ;; | |
| 121 | (when (beh-stuff-attributes beh) | |
| 122 | (push beh beh-list)))) | |
| 142 | 123 | ;; |
| 143 | 124 | (add-beh-equivalence module beh-list) |
| 144 | 125 | ;; |
| 146 | 127 | |
| 147 | 128 | (defun add-beh-equivalence (module beh-list) |
| 148 | 129 | (declare (type module module) |
| 149 | (type list beh-list) | |
| 150 | (values t)) | |
| 130 | (type list beh-list) | |
| 131 | (values t)) | |
| 151 | 132 | ;; |
| 152 | 133 | ;; for each hidden sort with its methods/attributes |
| 153 | 134 | ;; |
| 154 | 135 | (dolist (hma beh-list) |
| 155 | (let ((hs (beh-stuff-hs hma)) ; hidden sort | |
| 156 | (methods (beh-stuff-methods hma)) ; methods | |
| 157 | (attributes (beh-stuff-attributes hma)) ; attributes | |
| 158 | (var-num 0) | |
| 159 | cond | |
| 160 | hvars | |
| 161 | pvars | |
| 162 | (th-rhs-args nil) | |
| 163 | hs-pos | |
| 164 | lhs-args | |
| 165 | rhs-args | |
| 166 | lhs | |
| 167 | rhs | |
| 168 | ax) | |
| 136 | (let ((hs (beh-stuff-hs hma)) ; hidden sort | |
| 137 | (methods (beh-stuff-methods hma)) ; methods | |
| 138 | (attributes (beh-stuff-attributes hma)) ; attributes | |
| 139 | (var-num 0) | |
| 140 | cond | |
| 141 | hvars | |
| 142 | pvars | |
| 143 | (th-rhs-args nil) | |
| 144 | hs-pos | |
| 145 | lhs-args | |
| 146 | rhs-args | |
| 147 | lhs | |
| 148 | rhs | |
| 149 | ax) | |
| 169 | 150 | (declare (type fixnum var-num)) |
| 170 | 151 | ;; |
| 171 | 152 | (setq hvars (list (make-variable-term hs '|hs1|) |
| 172 | (make-variable-term hs '|hs2|))) | |
| 153 | (make-variable-term hs '|hs2|))) | |
| 173 | 154 | (setq pvars (list (make-pvariable-term hs '|`phs-1|) |
| 174 | (make-pvariable-term hs '|`phs-2|))) | |
| 175 | #|| | |
| 176 | (setq pvars (list (make-variable-term hs '|phs-1|) | |
| 177 | (make-variable-term hs '|phs-2|))) | |
| 178 | ||# | |
| 179 | ;; cond (hs1 =*= hs2) | |
| 155 | (make-pvariable-term hs '|`phs-2|))) | |
| 180 | 156 | (setq cond (make-term-with-sort-check *beh-equal* hvars)) |
| 181 | ;; | |
| 182 | 157 | (dolist (attr attributes) |
| 183 | (let ((arity (method-arity attr))) | |
| 184 | ;; first, make general axiom for each attributes. | |
| 185 | ;; ceq attr(t,d) = attr(t',d) if t =*= t'. | |
| 186 | ;; *NOTE* This is redundant, seems useless. | |
| 187 | ;; we omit this now. Mon Mar 9 23:05:16 JST 1998 | |
| 188 | ;; | |
| 189 | (setq hs-pos (position-if #'(lambda (x) (sort-is-hidden x)) | |
| 190 | arity)) | |
| 191 | (setq lhs-args | |
| 192 | (mapcar #'(lambda (x) | |
| 193 | (if (sort-is-hidden x) | |
| 194 | (car hvars) | |
| 195 | (make-variable-term x | |
| 196 | (intern (format nil | |
| 197 | "vs~D" | |
| 198 | (incf | |
| 199 | var-num)))) | |
| 200 | )) | |
| 201 | arity)) | |
| 202 | (setq rhs-args (copy-list lhs-args)) | |
| 203 | (setf (nth hs-pos rhs-args) (cadr hvars)) | |
| 204 | ;; lhs : attr(t,d) | |
| 205 | (setq lhs (make-term-with-sort-check attr lhs-args)) | |
| 206 | ;; rhs : attr(t',d) | |
| 207 | (setq rhs (make-term-with-sort-check attr rhs-args)) | |
| 208 | ;; ax : ceq attr(t,d) = attr(t',d) if t =*= t'. | |
| 209 | ;; *NOTE* we don't introduce this now, see the above note. | |
| 210 | #||--------------------omit------------------- | |
| 211 | (setq ax | |
| 212 | (check-axiom-error-method module | |
| 213 | (make-rule :lhs lhs | |
| 214 | :rhs rhs | |
| 215 | :condition cond | |
| 216 | :type ':equation | |
| 217 | ;; :kind ':beh-equiv | |
| 218 | ))) | |
| 219 | ;; we can always introcude this axiom. | |
| 220 | (adjoin-axiom-to-module module ax) | |
| 221 | (push ax (beh-stuff-axioms hma)) | |
| 222 | -----------------------omit------------------ ||# | |
| 223 | ;; | |
| 224 | ;; make assumption used for prove congruence relation at the later stage. | |
| 225 | ;; eq attr(t,d) = attr(t',d) | |
| 226 | ;; NOTE: uses psuedo constants. | |
| 227 | ;; | |
| 228 | (push (list lhs rhs) th-rhs-args) | |
| 229 | (setq lhs-args | |
| 230 | (mapcar #'(lambda (x) | |
| 231 | (if (sort-is-hidden x) | |
| 232 | (car pvars) | |
| 233 | (make-pvariable-term x | |
| 234 | (intern (format nil | |
| 235 | "`pvs~D" | |
| 236 | (incf var-num))) | |
| 237 | ) | |
| 238 | #|| | |
| 239 | (make-variable-term x | |
| 240 | (intern (format nil | |
| 241 | "vs~D" | |
| 242 | (incf var-num)))) | |
| 243 | ||# | |
| 244 | )) | |
| 245 | arity)) | |
| 246 | (setf rhs-args (copy-list lhs-args)) | |
| 247 | (setf (nth hs-pos rhs-args) (cadr pvars)) | |
| 248 | (setq lhs (make-term-with-sort-check attr lhs-args)) | |
| 249 | (setq rhs (make-term-with-sort-check attr rhs-args)) | |
| 250 | (setq ax | |
| 251 | (check-axiom-error-method module | |
| 252 | (make-rule :lhs lhs | |
| 253 | :rhs rhs | |
| 254 | :condition *bool-true* | |
| 255 | :type ':equation | |
| 256 | :kind ':beh-equiv-assumpt))) | |
| 257 | (push ax (beh-stuff-assumptions hma)) | |
| 258 | ||
| 259 | )) | |
| 158 | (let ((arity (method-arity attr))) | |
| 159 | ;; first, make general axiom for each attributes. | |
| 160 | ;; ceq attr(t,d) = attr(t',d) if t =*= t'. | |
| 161 | ;; *NOTE* This is redundant, seems useless. | |
| 162 | ;; we omit this now. Mon Mar 9 23:05:16 JST 1998 | |
| 163 | (setq hs-pos (position-if #'(lambda (x) (sort-is-hidden x)) | |
| 164 | arity)) | |
| 165 | (setq lhs-args | |
| 166 | (mapcar #'(lambda (x) | |
| 167 | (if (sort-is-hidden x) | |
| 168 | (car hvars) | |
| 169 | (make-variable-term x | |
| 170 | (intern (format nil | |
| 171 | "vs~D" | |
| 172 | (incf | |
| 173 | var-num)))) | |
| 174 | )) | |
| 175 | arity)) | |
| 176 | (setq rhs-args (copy-list lhs-args)) | |
| 177 | (setf (nth hs-pos rhs-args) (cadr hvars)) | |
| 178 | ;; lhs : attr(t,d) | |
| 179 | (setq lhs (make-term-with-sort-check attr lhs-args)) | |
| 180 | ;; rhs : attr(t',d) | |
| 181 | (setq rhs (make-term-with-sort-check attr rhs-args)) | |
| 182 | ;; ax : ceq attr(t,d) = attr(t',d) if t =*= t'. | |
| 183 | ;; *NOTE* we don't introduce this now, see the above note. | |
| 184 | ;; make assumption used for prove congruence relation at the later stage. | |
| 185 | ;; eq attr(t,d) = attr(t',d) | |
| 186 | ;; NOTE: uses psuedo constants. | |
| 187 | ;; | |
| 188 | (push (list lhs rhs) th-rhs-args) | |
| 189 | (setq lhs-args | |
| 190 | (mapcar #'(lambda (x) | |
| 191 | (if (sort-is-hidden x) | |
| 192 | (car pvars) | |
| 193 | (make-pvariable-term x | |
| 194 | (intern (format nil | |
| 195 | "`pvs~D" | |
| 196 | (incf var-num)))))) | |
| 197 | arity)) | |
| 198 | (setf rhs-args (copy-list lhs-args)) | |
| 199 | (setf (nth hs-pos rhs-args) (cadr pvars)) | |
| 200 | (setq lhs (make-term-with-sort-check attr lhs-args)) | |
| 201 | (setq rhs (make-term-with-sort-check attr rhs-args)) | |
| 202 | (setq ax | |
| 203 | (check-axiom-error-method module | |
| 204 | (make-rule :lhs lhs | |
| 205 | :rhs rhs | |
| 206 | :condition *bool-true* | |
| 207 | :type ':equation | |
| 208 | :kind ':beh-equiv-assumpt))) | |
| 209 | (push ax (beh-stuff-assumptions hma)) | |
| 210 | ||
| 211 | )) | |
| 260 | 212 | ;; |
| 261 | 213 | ;; make theorem to be proved |
| 262 | 214 | ;; |
| 264 | 216 | ;; ceq t =*= t' = true if attr(t,d) == attr(t',d) and ... |
| 265 | 217 | ;; |
| 266 | 218 | (when attributes |
| 267 | (setq rhs ; conjunction of each attr(t,d) == attr(t',d). | |
| 268 | (reduce #'(lambda (x y) | |
| 269 | (make-term-with-sort-check *bool-and* | |
| 270 | (list x y))) | |
| 271 | (mapcar #'(lambda (z) | |
| 272 | (make-term-with-sort-check *bool-equal* z)) | |
| 273 | th-rhs-args))) | |
| 274 | (setq ax | |
| 275 | (check-axiom-error-method module | |
| 276 | (make-rule :lhs cond | |
| 277 | :rhs *bool-true* | |
| 278 | :condition rhs ; *bool-true* | |
| 279 | :type ':equation | |
| 280 | ;; :kind ':beh-equiv-theorem | |
| 281 | ))) | |
| 282 | (setf (beh-stuff-theorem hma) ax) | |
| 283 | ) | |
| 219 | (setq rhs ; conjunction of each attr(t,d) == attr(t',d). | |
| 220 | (reduce #'(lambda (x y) | |
| 221 | (make-term-with-sort-check *bool-and* | |
| 222 | (list x y))) | |
| 223 | (mapcar #'(lambda (z) | |
| 224 | (make-term-with-sort-check *bool-equal* z)) | |
| 225 | th-rhs-args))) | |
| 226 | (setq ax | |
| 227 | (check-axiom-error-method module | |
| 228 | (make-rule :lhs cond | |
| 229 | :rhs *bool-true* | |
| 230 | :condition rhs ; *bool-true* | |
| 231 | :type ':equation | |
| 232 | ;; :kind ':beh-equiv-theorem | |
| 233 | ))) | |
| 234 | (setf (beh-stuff-theorem hma) ax)) | |
| 284 | 235 | ;; make terms to be evaluated to true in proof. |
| 285 | 236 | (when methods |
| 286 | ;; for each methods | |
| 287 | (dolist (bmeth methods) | |
| 288 | (let* ((marity (method-arity bmeth)) | |
| 289 | (mhpos (position-if #'(lambda (x) (sort-is-hidden x)) marity))) | |
| 290 | (setq lhs-args | |
| 291 | (mapcar #'(lambda (x) | |
| 292 | (if (sort-is-hidden x) | |
| 293 | (car pvars) | |
| 294 | (make-pvariable-term x | |
| 295 | (intern (format nil | |
| 296 | "`bpvs~D" | |
| 297 | (incf | |
| 298 | var-num)))) | |
| 299 | #|| | |
| 300 | (make-variable-term x | |
| 301 | (intern (format nil | |
| 302 | "bvs~D" | |
| 303 | (incf | |
| 304 | var-num)))) | |
| 305 | ||# | |
| 306 | )) | |
| 307 | marity)) | |
| 308 | (setq rhs-args (copy-list lhs-args)) | |
| 309 | (setf (nth mhpos rhs-args) (cadr pvars)) | |
| 310 | (Setq lhs (make-term-with-sort-check bmeth lhs-args)) | |
| 311 | (setq rhs (make-term-with-sort-check bmeth rhs-args)) | |
| 312 | (push (make-term-with-sort-check *beh-equal* (list lhs rhs)) | |
| 313 | (beh-stuff-targets hma))))) | |
| 314 | ))) | |
| 315 | ||
| 316 | ;;; | |
| 317 | ;;; now defined in globals.lisp | |
| 318 | ;;; (declaim (special *beh-proof-in-progress*)) | |
| 319 | ;;; (defvar *beh-proof-in-progress* nil) | |
| 320 | ||
| 321 | #|| | |
| 322 | (let ((.beh-proof-mod-num. 0)) | |
| 323 | (defun make-beh-proof-mod-name () | |
| 324 | ;; (format nil " % % -~d" (incf .beh-proof-mod-num.)) | |
| 325 | " % % " )) | |
| 326 | ||# | |
| 237 | ;; for each methods | |
| 238 | (dolist (bmeth methods) | |
| 239 | (let* ((marity (method-arity bmeth)) | |
| 240 | (mhpos (position-if #'(lambda (x) (sort-is-hidden x)) marity))) | |
| 241 | (setq lhs-args | |
| 242 | (mapcar #'(lambda (x) | |
| 243 | (if (sort-is-hidden x) | |
| 244 | (car pvars) | |
| 245 | (make-pvariable-term x | |
| 246 | (intern (format nil "`bpvs~D" | |
| 247 | (incf | |
| 248 | var-num)))))) | |
| 249 | marity)) | |
| 250 | (setq rhs-args (copy-list lhs-args)) | |
| 251 | (setf (nth mhpos rhs-args) (cadr pvars)) | |
| 252 | (Setq lhs (make-term-with-sort-check bmeth lhs-args)) | |
| 253 | (setq rhs (make-term-with-sort-check bmeth rhs-args)) | |
| 254 | (push (make-term-with-sort-check *beh-equal* (list lhs rhs)) | |
| 255 | (beh-stuff-targets hma)))))))) | |
| 327 | 256 | |
| 328 | 257 | (defun make-beh-proof-mod-name () " % % " ) |
| 329 | 258 | |
| 337 | 266 | (return-from try-beh-proof-in nil)) |
| 338 | 267 | (when *beh-proof-in-progress* (return-from try-beh-proof-in nil)) |
| 339 | 268 | (let ((proved nil) |
| 340 | (fail nil) | |
| 341 | (*beh-proof-in-progress* t) | |
| 342 | (*auto-context-change* nil) | |
| 343 | (*used==* nil)) | |
| 269 | (fail nil) | |
| 270 | (*beh-proof-in-progress* t) | |
| 271 | (*auto-context-change* nil) | |
| 272 | (*used==* nil)) | |
| 344 | 273 | (declare (special *auto-context-change*) |
| 345 | (special *used==*)) | |
| 274 | (special *used==*)) | |
| 346 | 275 | ;; first open the module |
| 347 | 276 | (let* ((proof-mod-nam (normalize-modexp (make-beh-proof-mod-name))) |
| 348 | (proof-mod (let ((*chaos-quiet* t)) | |
| 349 | (create-renamed-module module proof-mod-nam)))) | |
| 277 | (proof-mod (let ((*chaos-quiet* t)) | |
| 278 | (create-renamed-module module proof-mod-nam)))) | |
| 350 | 279 | (setf (module-type proof-mod) :system) |
| 351 | 280 | ;; ** strong assumption ** |
| 352 | 281 | ;; opened module is compiled & has just the same beh-to-be-proved!!!! |
| 353 | 282 | (with-in-module (proof-mod) |
| 354 | (let ((ths (module-beh-stuff proof-mod))) | |
| 355 | (declare (type list ths)) | |
| 356 | ;; for each beh-stuff | |
| 357 | (dotimes (t-pos (length ths)) | |
| 358 | (declare (type fixnum t-pos)) | |
| 359 | (let ((th (nth t-pos ths))) | |
| 360 | (when (beh-stuff-theorem th) | |
| 361 | (let ((*chaos-quiet* t) | |
| 362 | (*chaos-verbose* nil)) | |
| 363 | (declare (special *chaos-verbose* *chaos-quiet*)) | |
| 364 | ;; add theorem | |
| 365 | (adjoin-axiom-to-module proof-mod | |
| 366 | (check-axiom-error-method | |
| 367 | proof-mod | |
| 368 | (beh-stuff-theorem th))) | |
| 369 | (dolist (as (beh-stuff-assumptions th)) | |
| 370 | (adjoin-axiom-to-module proof-mod | |
| 371 | (check-axiom-error-method | |
| 372 | proof-mod | |
| 373 | as))) | |
| 374 | (set-needs-rule proof-mod) | |
| 375 | (compile-module proof-mod) | |
| 376 | ) | |
| 377 | ;; | |
| 378 | (when *chaos-verbose* | |
| 379 | (with-output-simple-msg () | |
| 380 | (format t "~&>> start trial proof : ") | |
| 381 | (print-chaos-object (beh-stuff-theorem th)) | |
| 382 | (print-next) | |
| 383 | (princ "* bases : ") | |
| 384 | (dolist (as (beh-stuff-assumptions th)) | |
| 385 | (print-next) | |
| 386 | (print-chaos-object as)) | |
| 387 | (force-output))) | |
| 388 | ;; try proof | |
| 389 | (let ((failed nil)) | |
| 390 | (dolist (tm (beh-stuff-targets th)) | |
| 391 | (when *chaos-verbose* | |
| 392 | (with-output-simple-msg () | |
| 393 | (print-next) | |
| 394 | (princ "* case : ") | |
| 395 | (print-chaos-object tm) | |
| 396 | (force-output))) | |
| 397 | ;; do the proof | |
| 398 | (beh-rewrite tm proof-mod) | |
| 399 | ;; | |
| 400 | (when *chaos-verbose* | |
| 401 | (print-next) | |
| 402 | (princ " -> ") (term-print tm)) | |
| 403 | (unless (is-true? tm) | |
| 404 | (setq failed t) | |
| 405 | (when *chaos-verbose* | |
| 406 | (with-output-simple-msg () | |
| 407 | (print-next) | |
| 408 | (princ "==> fail!"))) | |
| 409 | (return)) | |
| 410 | (when *chaos-verbose* | |
| 411 | (with-output-simple-msg () | |
| 412 | (print-next) | |
| 413 | (princ "==> success!"))) | |
| 414 | ) | |
| 415 | (if failed | |
| 416 | (progn (setq fail t) (return)) | |
| 417 | (push t-pos proved)) | |
| 418 | ))) | |
| 419 | ;; done for a beh-stuff | |
| 420 | ) | |
| 421 | ;; done for each beh-stuff | |
| 422 | )) | |
| 423 | (clean-up-module proof-mod) ; dont need no more | |
| 424 | ;; | |
| 425 | ;; (eval-close-module) | |
| 426 | ) | |
| 283 | (let ((ths (module-beh-stuff proof-mod))) | |
| 284 | (declare (type list ths)) | |
| 285 | ;; for each beh-stuff | |
| 286 | (dotimes (t-pos (length ths)) | |
| 287 | (declare (type fixnum t-pos)) | |
| 288 | (let ((th (nth t-pos ths))) | |
| 289 | (when (beh-stuff-theorem th) | |
| 290 | (let ((*chaos-quiet* t) | |
| 291 | (*chaos-verbose* nil)) | |
| 292 | (declare (special *chaos-verbose* *chaos-quiet*)) | |
| 293 | ;; add theorem | |
| 294 | (adjoin-axiom-to-module proof-mod | |
| 295 | (check-axiom-error-method | |
| 296 | proof-mod | |
| 297 | (beh-stuff-theorem th))) | |
| 298 | (dolist (as (beh-stuff-assumptions th)) | |
| 299 | (adjoin-axiom-to-module proof-mod | |
| 300 | (check-axiom-error-method | |
| 301 | proof-mod | |
| 302 | as))) | |
| 303 | (set-needs-rule proof-mod) | |
| 304 | (compile-module proof-mod)) | |
| 305 | ;; | |
| 306 | (when *chaos-verbose* | |
| 307 | (with-output-simple-msg () | |
| 308 | (format t "~%>> start trial proof : ") | |
| 309 | (print-chaos-object (beh-stuff-theorem th)) | |
| 310 | (print-next) | |
| 311 | (princ "* bases : ") | |
| 312 | (dolist (as (beh-stuff-assumptions th)) | |
| 313 | (print-next) | |
| 314 | (print-chaos-object as)) | |
| 315 | (force-output))) | |
| 316 | ;; try proof | |
| 317 | (let ((failed nil)) | |
| 318 | (dolist (tm (beh-stuff-targets th)) | |
| 319 | (when *chaos-verbose* | |
| 320 | (with-output-simple-msg () | |
| 321 | (print-next) | |
| 322 | (princ "* case : ") | |
| 323 | (print-chaos-object tm) | |
| 324 | (force-output))) | |
| 325 | ;; do the proof | |
| 326 | (beh-rewrite tm proof-mod) | |
| 327 | ;; | |
| 328 | (when *chaos-verbose* | |
| 329 | (print-next) | |
| 330 | (princ " -> ") (term-print tm)) | |
| 331 | (unless (is-true? tm) | |
| 332 | (setq failed t) | |
| 333 | (when *chaos-verbose* | |
| 334 | (with-output-simple-msg () | |
| 335 | (print-next) | |
| 336 | (princ "==> fail!"))) | |
| 337 | (return)) | |
| 338 | (when *chaos-verbose* | |
| 339 | (with-output-simple-msg () | |
| 340 | (print-next) | |
| 341 | (princ "==> success!")))) | |
| 342 | (if failed | |
| 343 | (progn (setq fail t) (return)) | |
| 344 | (push t-pos proved))))) | |
| 345 | ;; done for a beh-stuff | |
| 346 | ) | |
| 347 | ;; done for each beh-stuff | |
| 348 | )) | |
| 349 | (clean-up-module proof-mod)) | |
| 427 | 350 | ;; we assert proved theorem in module |
| 428 | 351 | (let ((real-ths (module-beh-stuff module))) |
| 429 | 352 | (if fail |
| 430 | (with-output-simple-msg () | |
| 431 | (format t "~&** system failed to prove =*= is a congruence of ") | |
| 432 | (print-mod-name module *standard-output* t t)) | |
| 433 | (with-in-module (module) | |
| 434 | (with-output-simple-msg () | |
| 353 | (with-output-simple-msg () | |
| 354 | (format t "~%** system failed to prove =*= is a congruence of ") | |
| 355 | (print-mod-name module *standard-output* t t)) | |
| 356 | (with-in-module (module) | |
| 357 | (with-output-simple-msg () | |
| 435 | 358 | (if (dont-believe-=*=-proof) |
| 436 | (format t "~&** system judged \"=*=\" is a congruence of ") | |
| 437 | (format t "~&** system already proved \"=*=\" is a congruence of ")) | |
| 438 | (print-mod-name module *standard-output* t t) | |
| 439 | (print-next) | |
| 440 | ;; | |
| 441 | (when (dont-believe-=*=-proof) | |
| 442 | (princ "** NOTE: in the proof process, an equality") | |
| 443 | (print-next) | |
| 444 | (princ " test (== or =/= with variable/constant on one side)") | |
| 445 | (print-next) | |
| 446 | (princ " was performed. Because system does not run case analysis,") | |
| 447 | (print-next) | |
| 448 | (princ " this judgement can be wrong.") | |
| 449 | (print-next) | |
| 450 | (princ " Please look into the proof process by loading ") | |
| 451 | (print-mod-name module *standard-output* t t) | |
| 452 | (princ " again") | |
| 453 | (print-next) | |
| 454 | (princ " after the two commands of") | |
| 455 | (print-next) | |
| 456 | (princ " set verbose on ") | |
| 457 | (print-next) | |
| 458 | (princ " set trace whole on ") | |
| 459 | (print-next) | |
| 460 | (princ " If you are sure that the proof is correct,") | |
| 461 | (print-next) | |
| 462 | (princ " you can add the following axiom(s):"))) | |
| 463 | (dolist (pos proved) | |
| 464 | (let ((th (nth pos real-ths))) | |
| 465 | (when (or *chaos-verbose* *used==*) | |
| 466 | (with-output-simple-msg () | |
| 467 | (if (not (dont-believe-=*=-proof)) | |
| 468 | (format t "~&>> adding axiom : ") | |
| 469 | (format t "~&ceq ")) | |
| 470 | (print-chaos-object (beh-stuff-theorem th)) | |
| 471 | (princ " . "))) | |
| 472 | (print-next) | |
| 473 | (unless (dont-believe-=*=-proof) | |
| 474 | (adjoin-axiom-to-module module | |
| 475 | (check-axiom-error-method | |
| 476 | module | |
| 477 | (beh-stuff-theorem th))) | |
| 478 | ) | |
| 479 | )) | |
| 480 | (set-needs-rule module) | |
| 481 | ))) | |
| 482 | )) | |
| 359 | (format t "~%** system judged \"=*=\" is a congruence of ") | |
| 360 | (format t "~%** system already proved \"=*=\" is a congruence of ")) | |
| 361 | (print-mod-name module *standard-output* t t) | |
| 362 | (print-next) | |
| 363 | ;; | |
| 364 | (when (dont-believe-=*=-proof) | |
| 365 | (princ "** NOTE: in the proof process, an equality") | |
| 366 | (print-next) | |
| 367 | (princ " test (== or =/= with variable/constant on one side)") | |
| 368 | (print-next) | |
| 369 | (princ " was performed. Because system does not run case analysis,") | |
| 370 | (print-next) | |
| 371 | (princ " this judgement can be wrong.") | |
| 372 | (print-next) | |
| 373 | (princ " Please look into the proof process by loading ") | |
| 374 | (print-mod-name module *standard-output* t t) | |
| 375 | (princ " again") | |
| 376 | (print-next) | |
| 377 | (princ " after the two commands of") | |
| 378 | (print-next) | |
| 379 | (princ " set verbose on ") | |
| 380 | (print-next) | |
| 381 | (princ " set trace whole on ") | |
| 382 | (print-next) | |
| 383 | (princ " If you are sure that the proof is correct,") | |
| 384 | (print-next) | |
| 385 | (princ " you can add the following axiom(s):"))) | |
| 386 | (dolist (pos proved) | |
| 387 | (let ((th (nth pos real-ths))) | |
| 388 | (when (or *chaos-verbose* *used==*) | |
| 389 | (with-output-simple-msg () | |
| 390 | (if (not (dont-believe-=*=-proof)) | |
| 391 | (format t "~%>> adding axiom : ") | |
| 392 | (format t "~%ceq ")) | |
| 393 | (print-chaos-object (beh-stuff-theorem th)) | |
| 394 | (princ " . "))) | |
| 395 | (print-next) | |
| 396 | (unless (dont-believe-=*=-proof) | |
| 397 | (adjoin-axiom-to-module module | |
| 398 | (check-axiom-error-method | |
| 399 | module | |
| 400 | (beh-stuff-theorem th)))))) | |
| 401 | (set-needs-rule module)))))) | |
| 483 | 402 | |
| 484 | 403 | (defun beh-rewrite (term mod) |
| 485 | (let (($$term term) | |
| 486 | (*rule-count* 0) | |
| 487 | (*perform-on-demand-reduction* t) | |
| 488 | (*rewrite-semantic-reduce* (module-has-behavioural-axioms mod))) | |
| 489 | (declare (special $$term) | |
| 490 | (special *rewrite-semantic-reduce*)) | |
| 491 | (rewrite term mod))) | |
| 404 | (reducer-no-stat term mod :red)) | |
| 492 | 405 | |
| 493 | 406 | ;;; EOF |
| 0 | 0 | ;;;-*- Mode:LISP; Package:CHAOS; Base:10; Syntax:Common-lisp -*- |
| 1 | 1 | ;;; |
| 2 | ;;; Copyright (c) 2000-2014, Toshimi Sawada. All rights reserved. | |
| 2 | ;;; Copyright (c) 2000-2015, Toshimi Sawada. All rights reserved. | |
| 3 | 3 | ;;; |
| 4 | 4 | ;;; Redistribution and use in source and binary forms, with or without |
| 5 | 5 | ;;; modification, are permitted provided that the following conditions |
| 27 | 27 | ;;; |
| 28 | 28 | (in-package :chaos) |
| 29 | 29 | #|============================================================================== |
| 30 | System: CHAOS | |
| 31 | Module: construct | |
| 32 | File: cr.lisp | |
| 30 | System: CHAOS | |
| 31 | Module: construct | |
| 32 | File: cr.lisp | |
| 33 | 33 | ==============================================================================|# |
| 34 | 34 | #-:chaos-debug |
| 35 | 35 | (declaim (optimize (speed 3) (safety 0) #-GCL (debug 0))) |
| 71 | 71 | ;;; |
| 72 | 72 | (defun sort-to-id-sort (sort mod) |
| 73 | 73 | (declare (ignore mod) |
| 74 | (type sort-struct sort) | |
| 75 | (type module mod) | |
| 76 | (values sort-struct)) | |
| 74 | (type sort-struct sort) | |
| 75 | (type module mod) | |
| 76 | (values sort-struct)) | |
| 77 | 77 | (if (crsort-p sort) |
| 78 | 78 | (method-coarity (crsort-id-method sort)) |
| 79 | 79 | (error "Internal error : sort-to-id-sort gets non r/c sort ~s" |
| 80 | (sort-id sort)))) | |
| 80 | (sort-id sort)))) | |
| 81 | 81 | |
| 82 | 82 | (defun declare-cr-sort (module name supers type &optional hidden) |
| 83 | 83 | (declare (type module module) |
| 84 | (type t name) | |
| 85 | (type list supers) | |
| 86 | (type symbol type) | |
| 87 | (type (or null t) hidden) | |
| 88 | (values sort-struct t)) | |
| 84 | (type t name) | |
| 85 | (type list supers) | |
| 86 | (type symbol type) | |
| 87 | (type (or null t) hidden) | |
| 88 | (values sort-struct t)) | |
| 89 | 89 | (with-in-module (module) |
| 90 | 90 | (let ((sort (or (find-sort-in module name) |
| 91 | (declare-sort-in-module (intern name) module type hidden))) | |
| 92 | spr | |
| 93 | (super-refs nil)) | |
| 91 | (declare-sort-in-module (intern name) module type hidden))) | |
| 92 | spr | |
| 93 | (super-refs nil)) | |
| 94 | 94 | (declare (type sort-struct sort)) |
| 95 | 95 | ;; define sort relation with super classes |
| 96 | 96 | ;; check if supers really exist. |
| 97 | 97 | (dolist (sup supers) |
| 98 | (if (setq spr (find-sort-in module (%super-sort sup))) | |
| 99 | (progn | |
| 100 | (when hidden | |
| 101 | (unless (sort-is-hidden spr) | |
| 102 | (with-output-chaos-error ('invalid-hidden-sort) | |
| 103 | (format t "you cannot declare subsort relation between visible sort and hidden sort,~% the super sort ") | |
| 104 | (print-sort-name spr) | |
| 105 | (print-next) | |
| 106 | (format t " is visible, but should be hidden in this context.") | |
| 107 | ))) | |
| 108 | (push (list spr (%super-renames sup)) super-refs)) | |
| 109 | (with-output-chaos-error ('no-such-sort) | |
| 110 | (format t "no such sort ,") | |
| 111 | (print-ast sup) | |
| 112 | (print-next) | |
| 113 | (format t "super ") | |
| 114 | (print-ast sup) | |
| 115 | (print-next) | |
| 116 | (format t " is ignored.") | |
| 117 | ))) | |
| 98 | (if (setq spr (find-sort-in module (%super-sort sup))) | |
| 99 | (progn | |
| 100 | (when hidden | |
| 101 | (unless (sort-is-hidden spr) | |
| 102 | (with-output-chaos-error ('invalid-hidden-sort) | |
| 103 | (format t "you cannot declare subsort relation between visible sort and hidden sort,~% the super sort ") | |
| 104 | (print-sort-name spr) | |
| 105 | (print-next) | |
| 106 | (format t " is visible, but should be hidden in this context.") | |
| 107 | ))) | |
| 108 | (push (list spr (%super-renames sup)) super-refs)) | |
| 109 | (with-output-chaos-error ('no-such-sort) | |
| 110 | (format t "no such sort ,") | |
| 111 | (print-ast sup) | |
| 112 | (print-next) | |
| 113 | (format t "super ") | |
| 114 | (print-ast sup) | |
| 115 | (print-next) | |
| 116 | (format t " is ignored.") | |
| 117 | ))) | |
| 118 | 118 | (if super-refs |
| 119 | (declare-subsort-in-module (list (list* sort | |
| 120 | ':< | |
| 121 | (mapcar #'car super-refs)))) | |
| 122 | (declare-subsort-in-module (list (list sort ':< (if (eq type 'class-sort) | |
| 123 | *object-sort* | |
| 124 | *record-instance-sort* | |
| 125 | ))))) | |
| 119 | (declare-subsort-in-module (list (list* sort | |
| 120 | ':< | |
| 121 | (mapcar #'car super-refs)))) | |
| 122 | (declare-subsort-in-module (list (list sort ':< (if (eq type 'class-sort) | |
| 123 | *object-sort* | |
| 124 | *record-instance-sort* | |
| 125 | ))))) | |
| 126 | 126 | (values sort super-refs)))) |
| 127 | 127 | |
| 128 | 128 | |
| 162 | 162 | |
| 163 | 163 | (defun inherit-super-slots (super-ref module) |
| 164 | 164 | (declare (type t super-ref) |
| 165 | (type module module) | |
| 166 | (values list)) | |
| 165 | (type module module) | |
| 166 | (values list)) | |
| 167 | 167 | (if (null (second super-ref)) |
| 168 | 168 | ;; no slot renaming |
| 169 | 169 | (copy-list (crsort-slots (car super-ref))) ; might be modified later. |
| 170 | 170 | |
| 171 | 171 | ;; slot renaming. |
| 172 | 172 | (let* ((super-sort (car super-ref)) |
| 173 | (super-slots (crsort-slots super-sort)) | |
| 174 | (maps (mapcar #'(lambda (m) | |
| 175 | (cons (%attr-rename-source m) | |
| 176 | (%attr-rename-target m))) | |
| 177 | (second super-ref))) | |
| 178 | (inherited-slots nil)) | |
| 179 | ;; a little error check | |
| 180 | (dolist (ren maps) | |
| 181 | (let ((slot (assoc (car ren) super-slots :test #'equal))) | |
| 182 | (unless slot | |
| 183 | (with-output-chaos-error ('invalid-rc-attributes) | |
| 184 | (format t "renaming super's attribute, no such attribute ~a in super sort ~a" | |
| 185 | (car ren) (sort-id (car super-ref))) | |
| 186 | )))) | |
| 187 | ;; do renaming | |
| 188 | (dolist (sl super-slots) | |
| 189 | (let ((new-name (cdr (assoc (car sl) maps :test #'equal)))) | |
| 190 | (if new-name | |
| 191 | ;; | |
| 192 | (let ((new-slot (copy-list sl)) | |
| 193 | (new-slot-sort-name (slot-name-to-sort-name new-name)) | |
| 194 | (new-slot-sort nil)) | |
| 195 | (setf (car new-slot) new-name) | |
| 196 | (push new-slot inherited-slots) | |
| 197 | (setq new-slot-sort | |
| 198 | (declare-sort-in-module (intern new-slot-sort-name) | |
| 199 | module)) | |
| 200 | (declare-subsort-in-module (list (list new-slot-sort | |
| 201 | ':< | |
| 202 | (method-coarity | |
| 203 | (cr-slot-attribute-id-method sl)))) | |
| 204 | module) | |
| 205 | ;; | |
| 206 | (multiple-value-bind (new-sl-op new-sl-method) | |
| 207 | (declare-operator-in-module (list new-name) | |
| 208 | nil | |
| 209 | new-slot-sort | |
| 210 | module) | |
| 211 | (declare (ignore new-sl-op)) | |
| 212 | (setf (cr-slot-attribute-id new-slot) | |
| 213 | (cons new-sl-method | |
| 214 | (make-new-variable | |
| 215 | (concatenate 'string | |
| 216 | "VAR-" (string-upcase new-slot-sort-name)) | |
| 217 | new-slot-sort))))) | |
| 218 | ;; no modification, inherit as is . | |
| 219 | (push (copy-list sl) inherited-slots)))) | |
| 220 | (nreverse inherited-slots)))) | |
| 173 | (super-slots (crsort-slots super-sort)) | |
| 174 | (maps (mapcar #'(lambda (m) | |
| 175 | (cons (%attr-rename-source m) | |
| 176 | (%attr-rename-target m))) | |
| 177 | (second super-ref))) | |
| 178 | (inherited-slots nil)) | |
| 179 | ;; a little error check | |
| 180 | (dolist (ren maps) | |
| 181 | (let ((slot (assoc (car ren) super-slots :test #'equal))) | |
| 182 | (unless slot | |
| 183 | (with-output-chaos-error ('invalid-rc-attributes) | |
| 184 | (format t "renaming super's attribute, no such attribute ~a in super sort ~a" | |
| 185 | (car ren) (sort-id (car super-ref))) | |
| 186 | )))) | |
| 187 | ;; do renaming | |
| 188 | (dolist (sl super-slots) | |
| 189 | (let ((new-name (cdr (assoc (car sl) maps :test #'equal)))) | |
| 190 | (if new-name | |
| 191 | ;; | |
| 192 | (let ((new-slot (copy-list sl)) | |
| 193 | (new-slot-sort-name (slot-name-to-sort-name new-name)) | |
| 194 | (new-slot-sort nil)) | |
| 195 | (setf (car new-slot) new-name) | |
| 196 | (push new-slot inherited-slots) | |
| 197 | (setq new-slot-sort | |
| 198 | (declare-sort-in-module (intern new-slot-sort-name) | |
| 199 | module)) | |
| 200 | (declare-subsort-in-module (list (list new-slot-sort | |
| 201 | ':< | |
| 202 | (method-coarity | |
| 203 | (cr-slot-attribute-id-method sl)))) | |
| 204 | module) | |
| 205 | ;; | |
| 206 | (multiple-value-bind (new-sl-op new-sl-method) | |
| 207 | (declare-operator-in-module (list new-name) | |
| 208 | nil | |
| 209 | new-slot-sort | |
| 210 | module) | |
| 211 | (declare (ignore new-sl-op)) | |
| 212 | (setf (cr-slot-attribute-id new-slot) | |
| 213 | (cons new-sl-method | |
| 214 | (make-new-variable | |
| 215 | (concatenate 'string | |
| 216 | "VAR-" (string-upcase new-slot-sort-name)) | |
| 217 | new-slot-sort))))) | |
| 218 | ;; no modification, inherit as is . | |
| 219 | (push (copy-list sl) inherited-slots)))) | |
| 220 | (nreverse inherited-slots)))) | |
| 221 | 221 | |
| 222 | 222 | ;;; PROCESS-SLOT-DECLARATIONS module super-refs slot-decls |
| 223 | 223 | (defun process-slot-declarations (module cr-sort super-refs slot-decls) |
| 224 | 224 | (declare (type module module) |
| 225 | (type sort-struct cr-sort) | |
| 226 | (type t super-refs slot-decls) | |
| 227 | (values list)) | |
| 225 | (type sort-struct cr-sort) | |
| 226 | (type t super-refs slot-decls) | |
| 227 | (values list)) | |
| 228 | 228 | (with-in-module (module) |
| 229 | 229 | (let ((super-slots nil) |
| 230 | (own-slots nil)) | |
| 230 | (own-slots nil)) | |
| 231 | 231 | ;; INHERITS SUPER SLOTS. |
| 232 | 232 | (dolist (super-ref super-refs) |
| 233 | (let ((super-sort (car super-ref))) | |
| 234 | (if (crsort-p super-sort) | |
| 235 | (let ((inherited-slots (inherit-super-slots super-ref module))) | |
| 236 | (dolist (ihsl inherited-slots) | |
| 237 | (when (assoc (car ihsl) super-slots :test #'equal) | |
| 238 | (with-output-chaos-error ('invalid-rc-attribute) | |
| 239 | (format t "duplicated attribute name ~a is inherited from supers." | |
| 240 | (car ihsl)) | |
| 241 | )) | |
| 242 | (push ihsl super-slots)))))) | |
| 233 | (let ((super-sort (car super-ref))) | |
| 234 | (if (crsort-p super-sort) | |
| 235 | (let ((inherited-slots (inherit-super-slots super-ref module))) | |
| 236 | (dolist (ihsl inherited-slots) | |
| 237 | (when (assoc (car ihsl) super-slots :test #'equal) | |
| 238 | (with-output-chaos-error ('invalid-rc-attribute) | |
| 239 | (format t "duplicated attribute name ~a is inherited from supers." | |
| 240 | (car ihsl)) | |
| 241 | )) | |
| 242 | (push ihsl super-slots)))))) | |
| 243 | 243 | ;; PROCESS OWN SLOTS. |
| 244 | 244 | ;; WE DO NOT PARSE TERMS FOR DEFAULT VALUES HERE. |
| 245 | 245 | ;; May include re-defining sorts or default value of super slots. |
| 246 | 246 | (dolist (x slot-decls) |
| 247 | (block next | |
| 248 | (let* ((sort (find-sort-in module (%slot-sort x))) | |
| 249 | (slot-name (%slot-name x)) | |
| 250 | (slot-sort-name (slot-name-to-sort-name slot-name)) | |
| 251 | (slot-name-sort nil) | |
| 252 | (slot-name-var nil) | |
| 253 | the-slot) | |
| 254 | (unless sort | |
| 255 | (with-output-chaos-error ('no-such-sort) | |
| 256 | (format t "declaring record/class, no such sort ") | |
| 257 | (print-sort-ref (%slot-sort x)) | |
| 258 | (print-next) | |
| 259 | (format t "for attribute ~a." (%slot-name x)) | |
| 260 | )) | |
| 261 | ;; | |
| 262 | (when (assoc slot-name own-slots :test #'equal) | |
| 263 | (with-output-chaos-error ('invalid-rc-attribute) | |
| 264 | (format t "duplicated attributes ~a are declared" slot-name) | |
| 265 | )) | |
| 266 | ;; check sort changing or different default value. | |
| 267 | (let ((sup (assoc slot-name super-slots :test #'equal))) | |
| 268 | (when sup | |
| 269 | (if (sort<= sort (cr-slot-sort sup) *current-sort-order*) | |
| 270 | ;; ok | |
| 271 | (progn | |
| 272 | ;; delete slot declaration from inherited ones | |
| 273 | (setq super-slots (delete sup super-slots)) | |
| 274 | ) | |
| 275 | ;; | |
| 276 | (with-output-chaos-error ('invalid-rc-attribute) | |
| 277 | (format t "for attribute ~a, changed sort must be a susort of ~a, but declared as ~a" | |
| 278 | (car x) | |
| 279 | (sort-id (cr-slot-sort sup)) | |
| 280 | (sort-id sort)) | |
| 281 | )))) | |
| 282 | ||
| 283 | ;; declare slot's sort as an subsort of attribute-value | |
| 284 | (unless (sort<= sort *attr-value-sort* *current-sort-order*) | |
| 285 | (let ((supers (supersorts-no-err sort *current-sort-order*))) | |
| 286 | (if (null supers) | |
| 287 | (declare-subsort-in-module `((,sort :< ,*attr-value-sort*)) | |
| 288 | module) | |
| 289 | (declare-subsort-in-module `((,@(maximal-sorts-no-error supers *current-sort-order*) | |
| 290 | :< ,*attr-value-sort*)) | |
| 291 | module)))) | |
| 292 | ||
| 293 | ;; SORT FOR SLOT-NAME (Attribute Identifier) | |
| 294 | (setq slot-name-sort | |
| 295 | (or (find-sort-in module slot-sort-name) | |
| 296 | (declare-sort-in-module (intern slot-sort-name) | |
| 297 | module))) | |
| 298 | (unless (sort<= slot-name-sort *attribute-id-sort* *current-sort-order*) | |
| 299 | (declare-subsort-in-module (list (list slot-name-sort | |
| 300 | ':< | |
| 301 | *attribute-id-sort*)) | |
| 302 | module)) | |
| 303 | ||
| 304 | ;; | |
| 305 | ;; (update-sort-order (module-sort-order module)) *** | |
| 306 | ;; Attribute Identifier CONSTRUCTOR | |
| 307 | (multiple-value-bind (sl-op sl-method) | |
| 308 | (declare-operator-in-module (list slot-name) | |
| 309 | nil | |
| 310 | slot-name-sort | |
| 311 | module | |
| 312 | :attribute-id) | |
| 313 | (declare (ignore sl-op)) | |
| 314 | (setq slot-name-var | |
| 315 | (make-new-variable | |
| 316 | (concatenate 'string | |
| 317 | "VAR-" (string-upcase slot-sort-name)) | |
| 318 | slot-name-sort)) | |
| 319 | (setq the-slot (list slot-name ; name | |
| 320 | sort ; sort | |
| 321 | (%slot-default x) ; default value | |
| 322 | (cons sl-method slot-name-var) ; attribute id | |
| 323 | nil ; reader | |
| 324 | nil ; writer | |
| 325 | )) | |
| 326 | (push the-slot own-slots) | |
| 327 | ||
| 328 | (let* ((slot-sort (cr-slot-sort the-slot)) | |
| 329 | (slot-name (cr-slot-name the-slot)) | |
| 330 | (reader (list slot-name)) | |
| 331 | (writer (list (concatenate 'string "set-" slot-name)))) | |
| 332 | ;; READER | |
| 333 | (multiple-value-bind (r-op r-meth) | |
| 334 | (declare-operator-in-module reader | |
| 335 | (list cr-sort) | |
| 336 | slot-sort | |
| 337 | module) | |
| 338 | (declare (ignore r-op)) | |
| 339 | (setf (cr-slot-reader the-slot) r-meth)) | |
| 340 | ;; WRITER | |
| 341 | (multiple-value-bind (op meth) | |
| 342 | (declare-operator-in-module writer | |
| 343 | (list cr-sort slot-sort) | |
| 344 | cr-sort | |
| 345 | module) | |
| 346 | (setf (cr-slot-writer the-slot) meth) | |
| 347 | (declare-operator-strategy op '(1 2 0))) | |
| 348 | ))))) | |
| 247 | (block next | |
| 248 | (let* ((sort (find-sort-in module (%slot-sort x))) | |
| 249 | (slot-name (%slot-name x)) | |
| 250 | (slot-sort-name (slot-name-to-sort-name slot-name)) | |
| 251 | (slot-name-sort nil) | |
| 252 | (slot-name-var nil) | |
| 253 | the-slot) | |
| 254 | (unless sort | |
| 255 | (with-output-chaos-error ('no-such-sort) | |
| 256 | (format t "declaring record/class, no such sort ") | |
| 257 | (print-sort-ref (%slot-sort x)) | |
| 258 | (print-next) | |
| 259 | (format t "for attribute ~a." (%slot-name x)) | |
| 260 | )) | |
| 261 | ;; | |
| 262 | (when (assoc slot-name own-slots :test #'equal) | |
| 263 | (with-output-chaos-error ('invalid-rc-attribute) | |
| 264 | (format t "duplicated attributes ~a are declared" slot-name) | |
| 265 | )) | |
| 266 | ;; check sort changing or different default value. | |
| 267 | (let ((sup (assoc slot-name super-slots :test #'equal))) | |
| 268 | (when sup | |
| 269 | (if (sort<= sort (cr-slot-sort sup) *current-sort-order*) | |
| 270 | ;; ok | |
| 271 | (progn | |
| 272 | ;; delete slot declaration from inherited ones | |
| 273 | (setq super-slots (delete sup super-slots)) | |
| 274 | ) | |
| 275 | ;; | |
| 276 | (with-output-chaos-error ('invalid-rc-attribute) | |
| 277 | (format t "for attribute ~a, changed sort must be a susort of ~a, but declared as ~a" | |
| 278 | (car x) | |
| 279 | (sort-id (cr-slot-sort sup)) | |
| 280 | (sort-id sort)) | |
| 281 | )))) | |
| 282 | ||
| 283 | ;; declare slot's sort as an subsort of attribute-value | |
| 284 | (unless (sort<= sort *attr-value-sort* *current-sort-order*) | |
| 285 | (let ((supers (supersorts-no-err sort *current-sort-order*))) | |
| 286 | (if (null supers) | |
| 287 | (declare-subsort-in-module `((,sort :< ,*attr-value-sort*)) | |
| 288 | module) | |
| 289 | (declare-subsort-in-module `((,@(maximal-sorts-no-error supers *current-sort-order*) | |
| 290 | :< ,*attr-value-sort*)) | |
| 291 | module)))) | |
| 292 | ||
| 293 | ;; SORT FOR SLOT-NAME (Attribute Identifier) | |
| 294 | (setq slot-name-sort | |
| 295 | (or (find-sort-in module slot-sort-name) | |
| 296 | (declare-sort-in-module (intern slot-sort-name) | |
| 297 | module))) | |
| 298 | (unless (sort<= slot-name-sort *attribute-id-sort* *current-sort-order*) | |
| 299 | (declare-subsort-in-module (list (list slot-name-sort | |
| 300 | ':< | |
| 301 | *attribute-id-sort*)) | |
| 302 | module)) | |
| 303 | ||
| 304 | ;; | |
| 305 | ;; (update-sort-order (module-sort-order module)) *** | |
| 306 | ;; Attribute Identifier CONSTRUCTOR | |
| 307 | (multiple-value-bind (sl-op sl-method) | |
| 308 | (declare-operator-in-module (list slot-name) | |
| 309 | nil | |
| 310 | slot-name-sort | |
| 311 | module | |
| 312 | :attribute-id) | |
| 313 | (declare (ignore sl-op)) | |
| 314 | (setq slot-name-var | |
| 315 | (make-new-variable | |
| 316 | (concatenate 'string | |
| 317 | "VAR-" (string-upcase slot-sort-name)) | |
| 318 | slot-name-sort)) | |
| 319 | (setq the-slot (list slot-name ; name | |
| 320 | sort ; sort | |
| 321 | (%slot-default x) ; default value | |
| 322 | (cons sl-method slot-name-var) ; attribute id | |
| 323 | nil ; reader | |
| 324 | nil ; writer | |
| 325 | )) | |
| 326 | (push the-slot own-slots) | |
| 327 | ||
| 328 | (let* ((slot-sort (cr-slot-sort the-slot)) | |
| 329 | (slot-name (cr-slot-name the-slot)) | |
| 330 | (reader (list slot-name)) | |
| 331 | (writer (list (concatenate 'string "set-" slot-name)))) | |
| 332 | ;; READER | |
| 333 | (multiple-value-bind (r-op r-meth) | |
| 334 | (declare-operator-in-module reader | |
| 335 | (list cr-sort) | |
| 336 | slot-sort | |
| 337 | module) | |
| 338 | (declare (ignore r-op)) | |
| 339 | (setf (cr-slot-reader the-slot) r-meth)) | |
| 340 | ;; WRITER | |
| 341 | (multiple-value-bind (op meth) | |
| 342 | (declare-operator-in-module writer | |
| 343 | (list cr-sort slot-sort) | |
| 344 | cr-sort | |
| 345 | module) | |
| 346 | (setf (cr-slot-writer the-slot) meth) | |
| 347 | (declare-operator-strategy op '(1 2 0))) | |
| 348 | ))))) | |
| 349 | 349 | ;; |
| 350 | 350 | (nconc super-slots own-slots)))) |
| 351 | 351 | |
| 356 | 356 | ;;; |
| 357 | 357 | (defun make-make-name (name) |
| 358 | 358 | (declare (type (or symbol simple-string) name) |
| 359 | (values simple-string)) | |
| 359 | (values simple-string)) | |
| 360 | 360 | (concatenate 'string "make" (string name))) |
| 361 | 361 | |
| 362 | 362 | (defun make-id-sort-name (name type) |
| 363 | 363 | (declare (type (or symbol simple-string) name) |
| 364 | (type symbol type) | |
| 365 | (values symbol)) | |
| 364 | (type symbol type) | |
| 365 | (values symbol)) | |
| 366 | 366 | (intern (format nil "~a~a" |
| 367 | (if (eq type 'class-sort) "Class" "Record") | |
| 368 | name))) | |
| 367 | (if (eq type 'class-sort) "Class" "Record") | |
| 368 | name))) | |
| 369 | 369 | |
| 370 | 370 | (defun declare-cr-internal (module name supers slot-decls type &optional hidden) |
| 371 | 371 | (declare (type module module) |
| 372 | (type t name) | |
| 373 | (type list supers slot-decls) | |
| 374 | (type symbol type) | |
| 375 | (type (or null t) hidden) | |
| 376 | (values t)) | |
| 372 | (type t name) | |
| 373 | (type list supers slot-decls) | |
| 374 | (type symbol type) | |
| 375 | (type (or null t) hidden) | |
| 376 | (values t)) | |
| 377 | 377 | (multiple-value-bind (cr-sort super-sorts) |
| 378 | 378 | (declare-cr-sort module name supers type hidden) |
| 379 | 379 | (declare (type sort-struct cr-sort) |
| 380 | (type list super-sorts)) | |
| 380 | (type list super-sorts)) | |
| 381 | 381 | (unless (sort-struct-p cr-sort) |
| 382 | 382 | (break "Panic non sort")) |
| 383 | 383 | (let ((id-sort-name (make-id-sort-name name type)) |
| 384 | id-sort | |
| 385 | (constructor-name (if (eq type 'class-sort) | |
| 386 | ;; NOTE: the order is significant | |
| 387 | (list '("<" "_" ":" "_" "|" "_" ">") | |
| 388 | '("<" "_" ":" "_" ">")) | |
| 389 | (list '("_" "{" "_" "}") | |
| 390 | '("_" "{" "}")))) | |
| 391 | const-arities) | |
| 384 | id-sort | |
| 385 | (constructor-name (if (eq type 'class-sort) | |
| 386 | ;; NOTE: the order is significant | |
| 387 | (list '("<" "_" ":" "_" "|" "_" ">") | |
| 388 | '("<" "_" ":" "_" ">")) | |
| 389 | (list '("_" "{" "_" "}") | |
| 390 | '("_" "{" "}")))) | |
| 391 | const-arities) | |
| 392 | 392 | ;; RECORD&CLASS IDENTIFIER -------------------------------- |
| 393 | 393 | (setq id-sort (declare-sort-in-module id-sort-name module 'sort hidden)) |
| 394 | 394 | (setq const-arities |
| 395 | (if (eq type 'class-sort) | |
| 396 | (list (list *object-identifier-sort* | |
| 397 | id-sort | |
| 398 | *attribute-list-sort*) | |
| 399 | (list *object-identifier-sort* | |
| 400 | id-sort) | |
| 401 | (list *object-identifier-sort* | |
| 402 | id-sort)) | |
| 403 | (list (list id-sort *attribute-list-sort*) | |
| 404 | (list id-sort)))) | |
| 395 | (if (eq type 'class-sort) | |
| 396 | (list (list *object-identifier-sort* | |
| 397 | id-sort | |
| 398 | *attribute-list-sort*) | |
| 399 | (list *object-identifier-sort* | |
| 400 | id-sort) | |
| 401 | (list *object-identifier-sort* | |
| 402 | id-sort)) | |
| 403 | (list (list id-sort *attribute-list-sort*) | |
| 404 | (list id-sort)))) | |
| 405 | 405 | (if supers |
| 406 | (let ((supers-id (mapcar #'(lambda (x) (sort-to-id-sort (car x) module)) | |
| 407 | super-sorts))) | |
| 408 | (declare-subsort-in-module (list (list* id-sort ':< supers-id)) | |
| 409 | module | |
| 410 | hidden)) | |
| 411 | (declare-subsort-in-module (list (list id-sort ':< | |
| 412 | (if (eq type 'class-sort) | |
| 413 | *class-id-sort* | |
| 414 | *record-id-sort*))) | |
| 415 | module)) | |
| 406 | (let ((supers-id (mapcar #'(lambda (x) (sort-to-id-sort (car x) module)) | |
| 407 | super-sorts))) | |
| 408 | (declare-subsort-in-module (list (list* id-sort ':< supers-id)) | |
| 409 | module | |
| 410 | hidden)) | |
| 411 | (declare-subsort-in-module (list (list id-sort ':< | |
| 412 | (if (eq type 'class-sort) | |
| 413 | *class-id-sort* | |
| 414 | *record-id-sort*))) | |
| 415 | module)) | |
| 416 | 416 | ;; MESSAGE SORT FOR CLASS SORTS ------------------------------ |
| 417 | 417 | (when (eq type 'class-sort) |
| 418 | (let* ((msg-sort-name (format nil "~aMessage" name)) | |
| 419 | (msg-sort (declare-sort-in-module (intern msg-sort-name) module))) | |
| 420 | (declare-subsort-in-module (list (list msg-sort ':< *message-sort*)) | |
| 421 | module))) | |
| 418 | (let* ((msg-sort-name (format nil "~aMessage" name)) | |
| 419 | (msg-sort (declare-sort-in-module (intern msg-sort-name) module))) | |
| 420 | (declare-subsort-in-module (list (list msg-sort ':< *message-sort*)) | |
| 421 | module))) | |
| 422 | 422 | ;; |
| 423 | 423 | ;; (update-sort-order (module-sort-order module)) |
| 424 | 424 | ;; |
| 425 | 425 | ;; RECORD/CLASS ID ------------------------------------------- |
| 426 | 426 | (multiple-value-bind (op meth) |
| 427 | (declare-operator-in-module (list name) () id-sort module :crid) | |
| 428 | (declare (ignore op)) | |
| 429 | (unless meth | |
| 430 | (error "PANIC! no method returned")) | |
| 431 | (setf (crsort-idconstr cr-sort) (cons meth | |
| 432 | (make-new-variable "RCID" id-sort))) | |
| 433 | ||
| 434 | ;; CONSTRUCTOR --------------------------------------------- | |
| 435 | (dotimes (x 2) | |
| 436 | (multiple-value-bind (op meth) | |
| 437 | (declare-operator-in-module (nth x constructor-name) | |
| 438 | (nth x const-arities) | |
| 439 | cr-sort | |
| 440 | module | |
| 441 | (if (= 0 x) | |
| 442 | (if (eq type 'class-sort) | |
| 443 | :object | |
| 444 | :record) | |
| 445 | :object-ref) | |
| 446 | ) | |
| 447 | (declare (ignore op)) | |
| 448 | (if (= x 0) | |
| 449 | (setf (crsort-constr-method cr-sort) meth)))) | |
| 450 | ||
| 451 | ;; operator makeFoo ---------------------------------------- | |
| 452 | (if (eq type 'class-sort) | |
| 453 | ;; MAKE FOR CLASS --- | |
| 454 | (let ((op-name (make-make-name name))) | |
| 455 | ;; (declare (ignore make-op)) | |
| 456 | ;; (1) makeFoo : ObjectId Attributes -> Foo | |
| 457 | (multiple-value-bind (make-op make-meth) | |
| 458 | (declare-operator-in-module (list op-name) | |
| 459 | (list *object-identifier-sort* | |
| 460 | *attribute-list-sort*) | |
| 461 | cr-sort | |
| 462 | module) | |
| 463 | (declare (ignore make-op)) | |
| 464 | (setf (crsort-make-1 cr-sort) make-meth)) | |
| 465 | ||
| 466 | ;; (2) makeFoo : ObjectId -> Foo | |
| 467 | (multiple-value-bind (make-op make-meth) | |
| 468 | (declare-operator-in-module (list op-name) | |
| 469 | (list *object-identifier-sort*) | |
| 470 | cr-sort | |
| 471 | module) | |
| 472 | (declare (ignore make-op)) | |
| 473 | (setf (crsort-make-2 cr-sort) make-meth)) | |
| 474 | ||
| 475 | ;; (3) makeFoo_ : Attributes -> Foo | |
| 476 | (multiple-value-bind (make-op make-meth) | |
| 477 | (declare-operator-in-module (list op-name "_") | |
| 478 | (list *attribute-list-sort*) | |
| 479 | cr-sort | |
| 480 | module) | |
| 481 | (setf (crsort-make-3 cr-sort) make-meth) | |
| 482 | (declare-operator-precedence make-op 0)) | |
| 483 | ||
| 484 | ;; (4) makeFoo : -> Foo | |
| 485 | (multiple-value-bind (make-op make-meth) | |
| 486 | (declare-operator-in-module (list op-name) | |
| 487 | nil | |
| 488 | cr-sort | |
| 489 | module) | |
| 490 | (declare (ignore make-op)) | |
| 491 | (setf (crsort-make-4 cr-sort) make-meth)) | |
| 492 | ) | |
| 493 | ||
| 494 | ;; MAKE FOR RECORD --- | |
| 495 | (let ((op-name (list (make-make-name name)))) | |
| 496 | ;; makeFoo : Attrs -> Foo | |
| 497 | (multiple-value-bind (make-op make-meth) | |
| 498 | (declare-operator-in-module op-name | |
| 499 | (list *attribute-list-sort*) | |
| 500 | cr-sort | |
| 501 | module) | |
| 502 | (declare (ignore make-op)) | |
| 503 | (setf (crsort-make-1 cr-sort) make-meth)) | |
| 504 | ||
| 505 | ;; makeFoo : -> Foo | |
| 506 | (multiple-value-bind (make-op make-meth) | |
| 507 | (declare-operator-in-module op-name | |
| 508 | nil | |
| 509 | cr-sort | |
| 510 | module) | |
| 511 | (declare (ignore make-op)) | |
| 512 | (setf (crsort-make-2 cr-sort) make-meth)) | |
| 513 | ||
| 514 | ) | |
| 515 | ) | |
| 516 | ||
| 427 | (declare-operator-in-module (list name) () id-sort module :crid) | |
| 428 | (declare (ignore op)) | |
| 429 | (unless meth | |
| 430 | (error "PANIC! no method returned")) | |
| 431 | (setf (crsort-idconstr cr-sort) (cons meth | |
| 432 | (make-new-variable "RCID" id-sort))) | |
| 433 | ||
| 434 | ;; CONSTRUCTOR --------------------------------------------- | |
| 435 | (dotimes (x 2) | |
| 436 | (multiple-value-bind (op meth) | |
| 437 | (declare-operator-in-module (nth x constructor-name) | |
| 438 | (nth x const-arities) | |
| 439 | cr-sort | |
| 440 | module | |
| 441 | (if (= 0 x) | |
| 442 | (if (eq type 'class-sort) | |
| 443 | :object | |
| 444 | :record) | |
| 445 | :object-ref) | |
| 446 | ) | |
| 447 | (declare (ignore op)) | |
| 448 | (if (= x 0) | |
| 449 | (setf (crsort-constr-method cr-sort) meth)))) | |
| 450 | ||
| 451 | ;; operator makeFoo ---------------------------------------- | |
| 452 | (if (eq type 'class-sort) | |
| 453 | ;; MAKE FOR CLASS --- | |
| 454 | (let ((op-name (make-make-name name))) | |
| 455 | ;; (declare (ignore make-op)) | |
| 456 | ;; (1) makeFoo : ObjectId Attributes -> Foo | |
| 457 | (multiple-value-bind (make-op make-meth) | |
| 458 | (declare-operator-in-module (list op-name) | |
| 459 | (list *object-identifier-sort* | |
| 460 | *attribute-list-sort*) | |
| 461 | cr-sort | |
| 462 | module) | |
| 463 | (declare (ignore make-op)) | |
| 464 | (setf (crsort-make-1 cr-sort) make-meth)) | |
| 465 | ||
| 466 | ;; (2) makeFoo : ObjectId -> Foo | |
| 467 | (multiple-value-bind (make-op make-meth) | |
| 468 | (declare-operator-in-module (list op-name) | |
| 469 | (list *object-identifier-sort*) | |
| 470 | cr-sort | |
| 471 | module) | |
| 472 | (declare (ignore make-op)) | |
| 473 | (setf (crsort-make-2 cr-sort) make-meth)) | |
| 474 | ||
| 475 | ;; (3) makeFoo_ : Attributes -> Foo | |
| 476 | (multiple-value-bind (make-op make-meth) | |
| 477 | (declare-operator-in-module (list op-name "_") | |
| 478 | (list *attribute-list-sort*) | |
| 479 | cr-sort | |
| 480 | module) | |
| 481 | (setf (crsort-make-3 cr-sort) make-meth) | |
| 482 | (declare-operator-precedence make-op 0)) | |
| 483 | ||
| 484 | ;; (4) makeFoo : -> Foo | |
| 485 | (multiple-value-bind (make-op make-meth) | |
| 486 | (declare-operator-in-module (list op-name) | |
| 487 | nil | |
| 488 | cr-sort | |
| 489 | module) | |
| 490 | (declare (ignore make-op)) | |
| 491 | (setf (crsort-make-4 cr-sort) make-meth)) | |
| 492 | ) | |
| 493 | ||
| 494 | ;; MAKE FOR RECORD --- | |
| 495 | (let ((op-name (list (make-make-name name)))) | |
| 496 | ;; makeFoo : Attrs -> Foo | |
| 497 | (multiple-value-bind (make-op make-meth) | |
| 498 | (declare-operator-in-module op-name | |
| 499 | (list *attribute-list-sort*) | |
| 500 | cr-sort | |
| 501 | module) | |
| 502 | (declare (ignore make-op)) | |
| 503 | (setf (crsort-make-1 cr-sort) make-meth)) | |
| 504 | ||
| 505 | ;; makeFoo : -> Foo | |
| 506 | (multiple-value-bind (make-op make-meth) | |
| 507 | (declare-operator-in-module op-name | |
| 508 | nil | |
| 509 | cr-sort | |
| 510 | module) | |
| 511 | (declare (ignore make-op)) | |
| 512 | (setf (crsort-make-2 cr-sort) make-meth)) | |
| 513 | ||
| 514 | ) | |
| 515 | ) | |
| 516 | ||
| 517 | 517 | |
| 518 | ;; ATTRIBUTE IDS,READERS,WRITERS ---------------------------- | |
| 519 | (setf (crsort-slots cr-sort) | |
| 520 | (process-slot-declarations module cr-sort super-sorts slot-decls)) | |
| 521 | )) | |
| 518 | ;; ATTRIBUTE IDS,READERS,WRITERS ---------------------------- | |
| 519 | (setf (crsort-slots cr-sort) | |
| 520 | (process-slot-declarations module cr-sort super-sorts slot-decls)) | |
| 521 | )) | |
| 522 | 522 | ;; |
| 523 | 523 | cr-sort)) |
| 524 | 524 | |
| 526 | 526 | ;;; |
| 527 | 527 | (defun declare-class-in-module (module name supers slot-decls &optional hidden) |
| 528 | 528 | (let ((class-sort (declare-cr-internal module |
| 529 | name | |
| 530 | supers | |
| 531 | slot-decls | |
| 532 | 'class-sort | |
| 533 | hidden))) | |
| 529 | name | |
| 530 | supers | |
| 531 | slot-decls | |
| 532 | 'class-sort | |
| 533 | hidden))) | |
| 534 | 534 | class-sort)) |
| 535 | 535 | |
| 536 | 536 | ;;; Declaring RECORD |
| 537 | 537 | ;;; |
| 538 | 538 | (defun declare-record-in-module (module name supers slot-decls &optional hidden) |
| 539 | 539 | (let ((record-sort (declare-cr-internal module |
| 540 | name | |
| 541 | supers | |
| 542 | slot-decls | |
| 543 | 'record-sort | |
| 544 | hidden))) | |
| 540 | name | |
| 541 | supers | |
| 542 | slot-decls | |
| 543 | 'record-sort | |
| 544 | hidden))) | |
| 545 | 545 | record-sort)) |
| 546 | 546 | |
| 547 | 547 | ;;; DECLARING AXIOMS for ACCESSORS & MAKE. |
| 550 | 550 | (unless (crsort-is-a-copy sort) |
| 551 | 551 | (with-in-module (module) |
| 552 | 552 | (let* ((id-var (make-new-variable "OBJID" *object-identifier-sort*)) |
| 553 | (cid-var (crsort-id-variable sort)) | |
| 554 | (attrs-var (make-new-variable "ATTRS" *attribute-list-sort*))) | |
| 555 | (macrolet ((make-object-pattern (slot var) | |
| 556 | ` (make-applform sort | |
| 557 | (crsort-constr-method sort) | |
| 558 | (list id-var | |
| 559 | cid-var | |
| 560 | (make-applform | |
| 561 | *attribute-list-sort* | |
| 562 | *attribute-list-constructor* | |
| 563 | (list (make-applform | |
| 564 | *attribute-sort* | |
| 565 | *attribute-constructor* | |
| 566 | (list | |
| 567 | (cr-slot-attribute-id-variable ,slot) | |
| 568 | ,var)) | |
| 569 | attrs-var))))) | |
| 570 | ) | |
| 571 | ;; AXIOMS for READERS & WRITERS of EACH ATTRIBUTE | |
| 572 | (dolist (slot (crsort-slots sort)) | |
| 573 | (let* ((var (make-new-variable "VAL" (cr-slot-sort slot))) | |
| 574 | (object-pattern (make-object-pattern slot var))) | |
| 575 | ||
| 576 | ;; READER ------------------------------------------------------- | |
| 577 | (let (lhs | |
| 578 | rhs | |
| 579 | ax) | |
| 580 | (setf lhs (make-applform (cr-slot-sort slot) | |
| 581 | (cr-slot-reader slot) | |
| 582 | (list object-pattern))) | |
| 583 | (setf rhs var) | |
| 584 | (setf ax (make-simple-axiom lhs rhs :equation)) | |
| 585 | (add-axiom-to-module *current-module* ax) | |
| 586 | ) | |
| 587 | ;; WRITER ------------------------------------------------------- | |
| 588 | (let ((new-var (make-new-variable "NEW-VAL" (cr-slot-sort slot))) | |
| 589 | lhs | |
| 590 | rhs | |
| 591 | ax) | |
| 592 | (setf lhs (make-applform sort | |
| 593 | (cr-slot-writer slot) | |
| 594 | (list (make-object-pattern slot var) | |
| 595 | new-var))) | |
| 596 | (setf rhs (make-object-pattern slot new-var)) | |
| 597 | (setf ax (make-simple-axiom lhs rhs :rule)) | |
| 598 | (add-axiom-to-module *current-module* ax)))) | |
| 599 | ||
| 600 | ;; AXIOMS for makeFoo ---------------------------------------------- | |
| 601 | (let* ((*print-case* :upcase) | |
| 602 | (*print-escape* nil) | |
| 603 | (rhs-form-1 (format nil "#!! (make-class-instance ~a '~s ~a)" | |
| 604 | (variable-name id-var) | |
| 605 | (sort-id sort) | |
| 606 | (variable-name attrs-var) | |
| 607 | )) | |
| 608 | (rhs-form-2 (format nil "#!! (make-class-instance ~a '~s)" | |
| 609 | (variable-name id-var) | |
| 610 | (sort-id sort))) | |
| 611 | (rhs-form-3 (format nil "#!! (make-class-instance-allocating-id '~s ~a)" | |
| 612 | (sort-id sort) | |
| 613 | (variable-name attrs-var))) | |
| 614 | (rhs-form-4 (format nil "#!! (make-class-instance-allocating-id '~s)" | |
| 615 | (sort-id sort))) | |
| 616 | lhs | |
| 617 | rhs | |
| 618 | ax) | |
| 619 | ;; (1) makeFoo : ObjectId Attributes -> Foo | |
| 620 | (setf lhs (make-applform sort | |
| 621 | (crsort-make-1 sort) | |
| 622 | (list id-var attrs-var))) | |
| 623 | (setf rhs (simple-parse-from-string* rhs-form-1)) | |
| 624 | (setf ax (make-simple-axiom lhs rhs :rule)) | |
| 625 | (add-axiom-to-module *current-module* ax) | |
| 626 | ;; (2) makeFOO : ObjectID -> Foo | |
| 627 | (setf lhs (make-applform sort | |
| 628 | (crsort-make-2 sort) | |
| 629 | (list id-var))) | |
| 630 | (setf rhs (simple-parse-from-string* rhs-form-2)) | |
| 631 | (setf ax (make-simple-axiom lhs rhs :rule)) | |
| 632 | (add-axiom-to-module *current-module* ax) | |
| 633 | ;; (3) makeFoo_ : Attributes -> Foo | |
| 634 | (setf lhs (make-applform sort | |
| 635 | (crsort-make-3 sort) | |
| 636 | (list attrs-var))) | |
| 637 | (setf rhs (simple-parse-from-string* rhs-form-3)) | |
| 638 | (setf ax (make-simple-axiom lhs rhs :rule)) | |
| 639 | (add-axiom-to-module *current-module* ax) | |
| 640 | ;; (4) makeFoo : -> Foo | |
| 641 | (setf lhs (make-applform sort (crsort-make-4 sort) nil)) | |
| 642 | (setf rhs (simple-parse-from-string* rhs-form-4)) | |
| 643 | (setf ax (make-simple-axiom lhs rhs :rule)) | |
| 644 | (add-axiom-to-module *current-module* ax) | |
| 645 | )))))) | |
| 553 | (cid-var (crsort-id-variable sort)) | |
| 554 | (attrs-var (make-new-variable "ATTRS" *attribute-list-sort*))) | |
| 555 | (macrolet ((make-object-pattern (slot var) | |
| 556 | ` (make-applform sort | |
| 557 | (crsort-constr-method sort) | |
| 558 | (list id-var | |
| 559 | cid-var | |
| 560 | (make-applform | |
| 561 | *attribute-list-sort* | |
| 562 | *attribute-list-constructor* | |
| 563 | (list (make-applform | |
| 564 | *attribute-sort* | |
| 565 | *attribute-constructor* | |
| 566 | (list | |
| 567 | (cr-slot-attribute-id-variable ,slot) | |
| 568 | ,var)) | |
| 569 | attrs-var))))) | |
| 570 | ) | |
| 571 | ;; AXIOMS for READERS & WRITERS of EACH ATTRIBUTE | |
| 572 | (dolist (slot (crsort-slots sort)) | |
| 573 | (let* ((var (make-new-variable "VAL" (cr-slot-sort slot))) | |
| 574 | (object-pattern (make-object-pattern slot var))) | |
| 575 | ||
| 576 | ;; READER ------------------------------------------------------- | |
| 577 | (let (lhs | |
| 578 | rhs | |
| 579 | ax) | |
| 580 | (setf lhs (make-applform (cr-slot-sort slot) | |
| 581 | (cr-slot-reader slot) | |
| 582 | (list object-pattern))) | |
| 583 | (setf rhs var) | |
| 584 | (setf ax (make-simple-axiom lhs rhs :equation)) | |
| 585 | (add-axiom-to-module *current-module* ax) | |
| 586 | ) | |
| 587 | ;; WRITER ------------------------------------------------------- | |
| 588 | (let ((new-var (make-new-variable "NEW-VAL" (cr-slot-sort slot))) | |
| 589 | lhs | |
| 590 | rhs | |
| 591 | ax) | |
| 592 | (setf lhs (make-applform sort | |
| 593 | (cr-slot-writer slot) | |
| 594 | (list (make-object-pattern slot var) | |
| 595 | new-var))) | |
| 596 | (setf rhs (make-object-pattern slot new-var)) | |
| 597 | (setf ax (make-simple-axiom lhs rhs :rule)) | |
| 598 | (add-axiom-to-module *current-module* ax)))) | |
| 599 | ||
| 600 | ;; AXIOMS for makeFoo ---------------------------------------------- | |
| 601 | (let* ((*print-case* :upcase) | |
| 602 | (*print-escape* nil) | |
| 603 | (rhs-form-1 (format nil "#!! (make-class-instance ~a '~s ~a)" | |
| 604 | (variable-name id-var) | |
| 605 | (sort-id sort) | |
| 606 | (variable-name attrs-var) | |
| 607 | )) | |
| 608 | (rhs-form-2 (format nil "#!! (make-class-instance ~a '~s)" | |
| 609 | (variable-name id-var) | |
| 610 | (sort-id sort))) | |
| 611 | (rhs-form-3 (format nil "#!! (make-class-instance-allocating-id '~s ~a)" | |
| 612 | (sort-id sort) | |
| 613 | (variable-name attrs-var))) | |
| 614 | (rhs-form-4 (format nil "#!! (make-class-instance-allocating-id '~s)" | |
| 615 | (sort-id sort))) | |
| 616 | lhs | |
| 617 | rhs | |
| 618 | ax) | |
| 619 | ;; (1) makeFoo : ObjectId Attributes -> Foo | |
| 620 | (setf lhs (make-applform sort | |
| 621 | (crsort-make-1 sort) | |
| 622 | (list id-var attrs-var))) | |
| 623 | (setf rhs (simple-parse-from-string* rhs-form-1)) | |
| 624 | (setf ax (make-simple-axiom lhs rhs :rule)) | |
| 625 | (add-axiom-to-module *current-module* ax) | |
| 626 | ;; (2) makeFOO : ObjectID -> Foo | |
| 627 | (setf lhs (make-applform sort | |
| 628 | (crsort-make-2 sort) | |
| 629 | (list id-var))) | |
| 630 | (setf rhs (simple-parse-from-string* rhs-form-2)) | |
| 631 | (setf ax (make-simple-axiom lhs rhs :rule)) | |
| 632 | (add-axiom-to-module *current-module* ax) | |
| 633 | ;; (3) makeFoo_ : Attributes -> Foo | |
| 634 | (setf lhs (make-applform sort | |
| 635 | (crsort-make-3 sort) | |
| 636 | (list attrs-var))) | |
| 637 | (setf rhs (simple-parse-from-string* rhs-form-3)) | |
| 638 | (setf ax (make-simple-axiom lhs rhs :rule)) | |
| 639 | (add-axiom-to-module *current-module* ax) | |
| 640 | ;; (4) makeFoo : -> Foo | |
| 641 | (setf lhs (make-applform sort (crsort-make-4 sort) nil)) | |
| 642 | (setf rhs (simple-parse-from-string* rhs-form-4)) | |
| 643 | (setf ax (make-simple-axiom lhs rhs :rule)) | |
| 644 | (add-axiom-to-module *current-module* ax) | |
| 645 | )))))) | |
| 646 | 646 | |
| 647 | 647 | (defun declare-record-axioms (module sort) |
| 648 | 648 | (unless (crsort-is-a-copy sort) |
| 649 | 649 | (with-in-module (module) |
| 650 | 650 | (let ((*parse-variables* nil) |
| 651 | (*print-case* :upcase) | |
| 652 | (*print-escape* nil)) | |
| 653 | (let ((rid-var (make-new-variable "RID" (sort-to-id-sort sort *current-module*))) | |
| 654 | (attrs-var (make-new-variable "ATTRS" *attribute-list-sort*))) | |
| 655 | (macrolet ((make-record-pattern (slot var) | |
| 656 | ` (make-applform sort | |
| 657 | (crsort-constr-method sort) | |
| 658 | (list rid-var | |
| 659 | (make-applform | |
| 660 | *attribute-list-sort* | |
| 661 | *attribute-list-constructor* | |
| 662 | (list | |
| 663 | (make-applform | |
| 664 | *attribute-sort* | |
| 665 | *attribute-constructor* | |
| 666 | (list | |
| 667 | (cr-slot-attribute-id-variable ,slot) | |
| 668 | ,var)) | |
| 669 | attrs-var)))))) | |
| 670 | ;; AXOMS for READERS & WRITERS of EACH ATTRIBUTE | |
| 671 | (dolist (slot (crsort-slots sort)) | |
| 672 | (let* ((var (make-new-variable "VAL" (cr-slot-sort slot))) | |
| 673 | (record-pattern (make-record-pattern slot var))) | |
| 674 | ;; READER ----------------------------------------------------- | |
| 675 | (let (lhs | |
| 676 | rhs | |
| 677 | ax) | |
| 678 | (setf lhs (make-applform (cr-slot-sort slot) | |
| 679 | (cr-slot-reader slot) | |
| 680 | (list record-pattern))) | |
| 681 | (setf rhs var) | |
| 682 | (setf ax (make-rule :lhs lhs :rhs rhs | |
| 683 | :condition *bool-true* | |
| 684 | :id-condition nil | |
| 685 | :type :equation | |
| 686 | :kind nil | |
| 687 | :labels nil)) | |
| 688 | (add-axiom-to-module *current-module* ax) | |
| 689 | ) | |
| 690 | ||
| 691 | ;; WRITER --------------------------------------------------- | |
| 692 | (let ((new-var (make-new-variable "NEW-VAL" *cosmos*)) | |
| 693 | lhs | |
| 694 | rhs | |
| 695 | ax) | |
| 696 | (setf lhs | |
| 697 | (make-applform sort | |
| 698 | (cr-slot-writer slot) | |
| 699 | (list (make-record-pattern slot var) | |
| 700 | new-var))) | |
| 701 | (setf rhs (make-record-pattern slot new-var)) | |
| 702 | (setf ax (make-rule :lhs lhs :rhs rhs | |
| 703 | :condition *bool-true* | |
| 704 | :id-condition nil | |
| 705 | :type :equation | |
| 706 | :kind nil | |
| 707 | :labels nil)) | |
| 708 | (add-axiom-to-module *current-module* ax)))) | |
| 709 | ||
| 710 | ;; MAKE --------------------------------------------------------- | |
| 711 | (let ((rhs-form-1 (format nil "#!! (make-record-instance '~s ~a)" | |
| 712 | (sort-id sort) | |
| 713 | (variable-name attrs-var) | |
| 714 | )) | |
| 715 | (rhs-form-2 (format nil "#!! (make-record-instance '~s)" | |
| 716 | (sort-id sort))) | |
| 717 | lhs | |
| 718 | rhs | |
| 719 | ax) | |
| 720 | ;; (1) makeFoo : Attributes -> Foo | |
| 721 | (setf lhs (make-applform sort | |
| 722 | (crsort-make-1 sort) | |
| 723 | (list attrs-var))) | |
| 724 | (setf rhs (simple-parse-from-string* rhs-form-1)) | |
| 725 | (setf ax (make-simple-axiom lhs rhs :equation)) | |
| 726 | (add-axiom-to-module *current-module* ax) | |
| 727 | ;; (2) makeFoo : -> Foo | |
| 728 | (setf lhs (make-applform sort | |
| 729 | (crsort-make-2 sort) | |
| 730 | nil)) | |
| 731 | (setf rhs (simple-parse-from-string* rhs-form-2)) | |
| 732 | (setf ax (make-simple-axiom lhs rhs :equation)) | |
| 733 | (add-axiom-to-module *current-module* ax) | |
| 734 | ))))))) | |
| 651 | (*print-case* :upcase) | |
| 652 | (*print-escape* nil)) | |
| 653 | (let ((rid-var (make-new-variable "RID" (sort-to-id-sort sort *current-module*))) | |
| 654 | (attrs-var (make-new-variable "ATTRS" *attribute-list-sort*))) | |
| 655 | (macrolet ((make-record-pattern (slot var) | |
| 656 | ` (make-applform sort | |
| 657 | (crsort-constr-method sort) | |
| 658 | (list rid-var | |
| 659 | (make-applform | |
| 660 | *attribute-list-sort* | |
| 661 | *attribute-list-constructor* | |
| 662 | (list | |
| 663 | (make-applform | |
| 664 | *attribute-sort* | |
| 665 | *attribute-constructor* | |
| 666 | (list | |
| 667 | (cr-slot-attribute-id-variable ,slot) | |
| 668 | ,var)) | |
| 669 | attrs-var)))))) | |
| 670 | ;; AXOMS for READERS & WRITERS of EACH ATTRIBUTE | |
| 671 | (dolist (slot (crsort-slots sort)) | |
| 672 | (let* ((var (make-new-variable "VAL" (cr-slot-sort slot))) | |
| 673 | (record-pattern (make-record-pattern slot var))) | |
| 674 | ;; READER ----------------------------------------------------- | |
| 675 | (let (lhs | |
| 676 | rhs | |
| 677 | ax) | |
| 678 | (setf lhs (make-applform (cr-slot-sort slot) | |
| 679 | (cr-slot-reader slot) | |
| 680 | (list record-pattern))) | |
| 681 | (setf rhs var) | |
| 682 | (setf ax (make-rule :lhs lhs :rhs rhs | |
| 683 | :condition *bool-true* | |
| 684 | :id-condition nil | |
| 685 | :type :equation | |
| 686 | :kind nil | |
| 687 | :labels nil)) | |
| 688 | (add-axiom-to-module *current-module* ax) | |
| 689 | ) | |
| 690 | ||
| 691 | ;; WRITER --------------------------------------------------- | |
| 692 | (let ((new-var (make-new-variable "NEW-VAL" *cosmos*)) | |
| 693 | lhs | |
| 694 | rhs | |
| 695 | ax) | |
| 696 | (setf lhs | |
| 697 | (make-applform sort | |
| 698 | (cr-slot-writer slot) | |
| 699 | (list (make-record-pattern slot var) | |
| 700 | new-var))) | |
| 701 | (setf rhs (make-record-pattern slot new-var)) | |
| 702 | (setf ax (make-rule :lhs lhs :rhs rhs | |
| 703 | :condition *bool-true* | |
| 704 | :id-condition nil | |
| 705 | :type :equation | |
| 706 | :kind nil | |
| 707 | :labels nil)) | |
| 708 | (add-axiom-to-module *current-module* ax)))) | |
| 709 | ||
| 710 | ;; MAKE --------------------------------------------------------- | |
| 711 | (let ((rhs-form-1 (format nil "#!! (make-record-instance '~s ~a)" | |
| 712 | (sort-id sort) | |
| 713 | (variable-name attrs-var) | |
| 714 | )) | |
| 715 | (rhs-form-2 (format nil "#!! (make-record-instance '~s)" | |
| 716 | (sort-id sort))) | |
| 717 | lhs | |
| 718 | rhs | |
| 719 | ax) | |
| 720 | ;; (1) makeFoo : Attributes -> Foo | |
| 721 | (setf lhs (make-applform sort | |
| 722 | (crsort-make-1 sort) | |
| 723 | (list attrs-var))) | |
| 724 | (setf rhs (simple-parse-from-string* rhs-form-1)) | |
| 725 | (setf ax (make-simple-axiom lhs rhs :equation)) | |
| 726 | (add-axiom-to-module *current-module* ax) | |
| 727 | ;; (2) makeFoo : -> Foo | |
| 728 | (setf lhs (make-applform sort | |
| 729 | (crsort-make-2 sort) | |
| 730 | nil)) | |
| 731 | (setf rhs (simple-parse-from-string* rhs-form-2)) | |
| 732 | (setf ax (make-simple-axiom lhs rhs :equation)) | |
| 733 | (add-axiom-to-module *current-module* ax) | |
| 734 | ))))))) | |
| 735 | 735 | |
| 736 | 736 | ;;;----------------------------------------------------------------------------- |
| 737 | 737 | ;;; MAKE.FOO |
| 746 | 746 | (princ " is already exists.") |
| 747 | 747 | )) |
| 748 | 748 | (let* ((class-sort (or (find-sort-in *current-module* class-id) |
| 749 | (error "Internal error no class ~a" class-id))) | |
| 750 | (attr-list (complete-attributes class-sort attrs)) | |
| 751 | (cid-method (crsort-id-method class-sort)) | |
| 752 | (const-method (crsort-constr-method class-sort)) | |
| 753 | (instance nil)) | |
| 749 | (error "Internal error no class ~a" class-id))) | |
| 750 | (attr-list (complete-attributes class-sort attrs)) | |
| 751 | (cid-method (crsort-id-method class-sort)) | |
| 752 | (const-method (crsort-constr-method class-sort)) | |
| 753 | (instance nil)) | |
| 754 | 754 | (setf instance |
| 755 | (make-applform class-sort | |
| 756 | const-method | |
| 757 | (list id | |
| 758 | (make-applform (method-coarity cid-method) cid-method nil) | |
| 759 | attr-list))) | |
| 755 | (make-applform class-sort | |
| 756 | const-method | |
| 757 | (list id | |
| 758 | (make-applform (method-coarity cid-method) cid-method nil) | |
| 759 | attr-list))) | |
| 760 | 760 | (register-instance instance) |
| 761 | 761 | instance)) |
| 762 | 762 | |
| 767 | 767 | (defvar *gensym-prefix* (intern "ID#-")) |
| 768 | 768 | (defun generate-unique-identifier (&optional prefix) |
| 769 | 769 | (cond (prefix (let ((so-far (gethash prefix *id-allocation-table*)) |
| 770 | new-id) | |
| 771 | (unless so-far | |
| 772 | (setf so-far | |
| 773 | (setf (gethash prefix *id-allocation-table*) 0))) | |
| 774 | (setf new-id (intern (format nil "~a-~d" prefix so-far))) | |
| 775 | (setf (gethash prefix *id-allocation-table*) | |
| 776 | (1+ (the fixnum so-far))) | |
| 777 | new-id)) | |
| 778 | (t (generate-unique-identifier *gensym-prefix*)))) | |
| 770 | new-id) | |
| 771 | (unless so-far | |
| 772 | (setf so-far | |
| 773 | (setf (gethash prefix *id-allocation-table*) 0))) | |
| 774 | (setf new-id (intern (format nil "~a-~d" prefix so-far))) | |
| 775 | (setf (gethash prefix *id-allocation-table*) | |
| 776 | (1+ (the fixnum so-far))) | |
| 777 | new-id)) | |
| 778 | (t (generate-unique-identifier *gensym-prefix*)))) | |
| 779 | 779 | |
| 780 | 780 | #|| NOT USED |
| 781 | 781 | (defun make-unique-object-identifier (class) |
| 784 | 784 | |
| 785 | 785 | (defun make-class-instance-allocating-id (class-id &optional attrs) |
| 786 | 786 | (let ((id (make-bconst-term *identifier-sort* |
| 787 | (generate-unique-identifier class-id)))) | |
| 787 | (generate-unique-identifier class-id)))) | |
| 788 | 788 | (make-class-instance id class-id attrs))) |
| 789 | 789 | |
| 790 | 790 | (defun make-record-instance (record-id &optional attrs) |
| 791 | 791 | (let* ((record-sort (or (find-sort-in *current-module* record-id) |
| 792 | (error "Internal error no record ~a" record-id))) | |
| 793 | (attr-list (complete-attributes record-sort attrs)) | |
| 794 | (rid-method (crsort-id-method record-sort)) | |
| 795 | (const-method (crsort-constr-method record-sort)) | |
| 796 | (instance nil)) | |
| 792 | (error "Internal error no record ~a" record-id))) | |
| 793 | (attr-list (complete-attributes record-sort attrs)) | |
| 794 | (rid-method (crsort-id-method record-sort)) | |
| 795 | (const-method (crsort-constr-method record-sort)) | |
| 796 | (instance nil)) | |
| 797 | 797 | ;; (break) |
| 798 | 798 | (setf instance |
| 799 | (make-applform record-sort | |
| 800 | const-method | |
| 801 | (list (make-applform (method-coarity rid-method) rid-method nil) | |
| 802 | attr-list))) | |
| 799 | (make-applform record-sort | |
| 800 | const-method | |
| 801 | (list (make-applform (method-coarity rid-method) rid-method nil) | |
| 802 | attr-list))) | |
| 803 | 803 | instance)) |
| 804 | 804 | |
| 805 | 805 | ;;; ** TODO ** TYPE CHECK ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ |
| 810 | 810 | ;; (format t "~& attrs = ") |
| 811 | 811 | ;; (print-chaos-object attrs) |
| 812 | 812 | (let* ((attr-list (cond ((and attrs |
| 813 | (sort= (term-sort attrs) *attribute-list-sort*)) | |
| 814 | (list-ac-subterms attrs (term-method attrs))) | |
| 815 | (attrs (list attrs)) | |
| 816 | (t nil))) | |
| 817 | (specified-slot-names (mapcar #'(lambda (x) | |
| 818 | (car (method-symbol (term-head | |
| 819 | (term-arg-1 x))))) | |
| 820 | attr-list)) | |
| 821 | (slot-info (crsort-slots sort)) | |
| 822 | (all-slot-names (mapcar #'car slot-info)) | |
| 823 | (slots-to-be-filled (set-difference all-slot-names specified-slot-names | |
| 824 | :test #'equal))) | |
| 813 | (sort= (term-sort attrs) *attribute-list-sort*)) | |
| 814 | (list-ac-subterms attrs (term-method attrs))) | |
| 815 | (attrs (list attrs)) | |
| 816 | (t nil))) | |
| 817 | (specified-slot-names (mapcar #'(lambda (x) | |
| 818 | (car (method-symbol (term-head | |
| 819 | (term-arg-1 x))))) | |
| 820 | attr-list)) | |
| 821 | (slot-info (crsort-slots sort)) | |
| 822 | (all-slot-names (mapcar #'car slot-info)) | |
| 823 | (slots-to-be-filled (set-difference all-slot-names specified-slot-names | |
| 824 | :test #'equal))) | |
| 825 | 825 | ;; (format t "~& slots-to-be-filled = ~a" slots-to-be-filled) |
| 826 | 826 | (let ((slots nil)) |
| 827 | 827 | (dolist (s slots-to-be-filled) |
| 828 | (let* ((sinfo (assoc s slot-info :test #'equal)) | |
| 829 | (dvalue (third sinfo)) | |
| 830 | (dterm nil)) | |
| 831 | (unless sinfo (error "Internal error, no slot ~a" s)) | |
| 832 | (cond (dvalue (setq dterm | |
| 833 | (let ((*parse-variables* nil)) | |
| 834 | (simple-parse-from-string* (format nil "~a = ~a" s dvalue) | |
| 835 | *current-module* | |
| 836 | *attribute-sort*))) | |
| 837 | (unless dterm | |
| 838 | (with-output-chaos-error ('invalid-rc-attribute-value) | |
| 839 | (format t | |
| 840 | "invalid initial value ~a for slot ~a of record/class ~a." | |
| 841 | dvalue s (sort-id sort)) | |
| 842 | )) | |
| 843 | (push dterm slots)) | |
| 844 | (t (setq dterm | |
| 845 | (let ((*parse-variables* nil)) | |
| 846 | (simple-parse-from-string* (format nil "~a = void-bottom" s) | |
| 847 | *current-module* | |
| 848 | *attribute-sort*))) | |
| 849 | (push dterm slots))))) | |
| 828 | (let* ((sinfo (assoc s slot-info :test #'equal)) | |
| 829 | (dvalue (third sinfo)) | |
| 830 | (dterm nil)) | |
| 831 | (unless sinfo (error "Internal error, no slot ~a" s)) | |
| 832 | (cond (dvalue (setq dterm | |
| 833 | (let ((*parse-variables* nil)) | |
| 834 | (simple-parse-from-string* (format nil "~a = ~a" s dvalue) | |
| 835 | *current-module* | |
| 836 | *attribute-sort*))) | |
| 837 | (unless dterm | |
| 838 | (with-output-chaos-error ('invalid-rc-attribute-value) | |
| 839 | (format t | |
| 840 | "invalid initial value ~a for slot ~a of record/class ~a." | |
| 841 | dvalue s (sort-id sort)) | |
| 842 | )) | |
| 843 | (push dterm slots)) | |
| 844 | (t (setq dterm | |
| 845 | (let ((*parse-variables* nil)) | |
| 846 | (simple-parse-from-string* (format nil "~a = void-bottom" s) | |
| 847 | *current-module* | |
| 848 | *attribute-sort*))) | |
| 849 | (push dterm slots))))) | |
| 850 | 850 | (if slots |
| 851 | (let ((new-attrs (append attr-list slots))) | |
| 852 | (declare (type list new-attrs)) | |
| 853 | (if (<= 2 (the fixnum (length new-attrs))) | |
| 854 | (make-right-assoc-normal-form *attribute-list-constructor* | |
| 855 | new-attrs) | |
| 856 | (car new-attrs))) | |
| 857 | attrs)))) | |
| 851 | (let ((new-attrs (append attr-list slots))) | |
| 852 | (declare (type list new-attrs)) | |
| 853 | (if (<= 2 (the fixnum (length new-attrs))) | |
| 854 | (make-right-assoc-normal-form *attribute-list-constructor* | |
| 855 | new-attrs) | |
| 856 | (car new-attrs))) | |
| 857 | attrs)))) | |
| 858 | 858 | |
| 859 | 859 | |
| 860 | 860 | ;;; EOF |
| 0 | 0 | ;;;-*-Mode:LISP; Package: CHAOS; Base:10; Syntax:Common-lisp -*- |
| 1 | 1 | ;;; |
| 2 | ;;; Copyright (c) 2000-2014, Toshimi Sawada. All rights reserved. | |
| 2 | ;;; Copyright (c) 2000-2015, Toshimi Sawada. All rights reserved. | |
| 3 | 3 | ;;; |
| 4 | 4 | ;;; Redistribution and use in source and binary forms, with or without |
| 5 | 5 | ;;; modification, are permitted provided that the following conditions |
| 27 | 27 | ;;; |
| 28 | 28 | (in-package :chaos) |
| 29 | 29 | #|============================================================================= |
| 30 | System:CHAOS | |
| 31 | Module:construct | |
| 32 | File:gen-rule.lisp | |
| 30 | System:CHAOS | |
| 31 | Module:construct | |
| 32 | File:gen-rule.lisp | |
| 33 | 33 | =============================================================================|# |
| 34 | 34 | #-:chaos-debug |
| 35 | 35 | (declaim (optimize (speed 3) (safety 0) #-GCL (debug 0))) |
| 36 | 36 | #+:chaos-debug |
| 37 | 37 | (declaim (optimize (speed 1) (safety 3) #-GCL (debug 3))) |
| 38 | 38 | |
| 39 | ;;; (defvar *gen-rule-debug* nil) | |
| 40 | ||
| 41 | 39 | ;;; GENERATE REWRITE RULES module : -> module' |
| 42 | 40 | ;;;----------------------------------------------------------------------------- |
| 43 | 41 | ;;; |
| 44 | 42 | (defun generate-rewrite-rules (module) |
| 45 | 43 | (declare (type module module) |
| 46 | (values t)) | |
| 44 | (values t)) | |
| 47 | 45 | (compute-protected-modules module) |
| 48 | 46 | |
| 49 | ;; reset rewrite rule set. | |
| 50 | ;; (setf (module-all-rules module) nil) | |
| 51 | ||
| 52 | ;; adds axioms for record/class | |
| 53 | (dolist (s (module-sorts module)) | |
| 54 | (cond ((class-sort-p s) | |
| 55 | (declare-class-axioms module s)) | |
| 56 | ((record-sort-p s) | |
| 57 | (declare-record-axioms module s)))) | |
| 58 | ||
| 59 | 47 | ;; install own rules. |
| 60 | 48 | (let ((axiom-set (module-axiom-set module))) |
| 61 | 49 | (dolist (eq (axiom-set$equations axiom-set)) |
| 63 | 51 | (dolist (rule (axiom-set$rules axiom-set)) |
| 64 | 52 | (gen-rule-internal rule module))) |
| 65 | 53 | |
| 66 | ;; install rules of submodules | |
| 67 | ;; (dolist (submodule (module-all-submodules module)) | |
| 68 | ;; (unless (eq 'using (cdr submodule)) | |
| 69 | ;; (transfer-axioms module (car submodule)))) | |
| 70 | ||
| 71 | 54 | ;; specialize rules of sumodules. |
| 72 | 55 | (dolist (rule (gather-submodule-rules module)) |
| 73 | 56 | (let ((r-rule (or (cdr (assq rule (module-axioms-to-be-fixed module))) |
| 74 | rule))) | |
| 57 | rule))) | |
| 75 | 58 | (unless (memq (axiom-type r-rule) '(:pignose-axiom :pignose-goal)) |
| 76 | (specialize-rule r-rule module)))) | |
| 59 | (specialize-rule r-rule module)))) | |
| 77 | 60 | module) |
| 78 | 61 | |
| 79 | 62 | (defun variable-occurs-in (t1 t2) |
| 80 | 63 | (declare (type term t1 t2)) |
| 81 | 64 | (or (term-is-identical t1 t2) |
| 82 | 65 | (and (term-is-application-form? t2) |
| 83 | (dolist (sub (term-subterms t2) nil) | |
| 84 | (when (variable-occurs-in t1 sub) | |
| 85 | (return-from variable-occurs-in t)))) | |
| 86 | )) | |
| 66 | (dolist (sub (term-subterms t2) nil) | |
| 67 | (when (variable-occurs-in t1 sub) | |
| 68 | (return-from variable-occurs-in t)))))) | |
| 87 | 69 | |
| 88 | 70 | (defparameter non-exec-labels '(|:nonexec| |:non-exec| |:no-ex| |:noex| |:noexec|)) |
| 89 | 71 | |
| 90 | 72 | (defun axiom-is-non-exec? (ax) |
| 91 | ;; (format t "~&labels=~s" (axiom-labels ax)) | |
| 92 | 73 | (intersection (axiom-labels ax) non-exec-labels)) |
| 93 | 74 | |
| 94 | 75 | (defun condition-has-match-condition (condition) |
| 97 | 78 | |
| 98 | 79 | (defun gen-rule-internal (ax module &aux (rule ax)) |
| 99 | 80 | (declare (type axiom ax) |
| 100 | (type module module) | |
| 101 | (type axiom rule) | |
| 102 | (values t)) | |
| 81 | (type module module) | |
| 82 | (type axiom rule) | |
| 83 | (values t)) | |
| 103 | 84 | (when (memq (axiom-type ax) '(:pignose-axiom :pignose-goal)) |
| 104 | 85 | (return-from gen-rule-internal nil)) |
| 105 | 86 | ;; |
| 106 | 87 | (setq rule (or (cdr (assq ax (module-axioms-to-be-fixed module))) |
| 107 | ax)) | |
| 88 | ax)) | |
| 108 | 89 | ;; |
| 109 | 90 | (when (axiom-is-non-exec? ax) |
| 110 | 91 | (setf (axiom-non-exec ax) t) |
| 115 | 96 | ;; for trans sole variable on LHS is allowed |
| 116 | 97 | (when (term-is-variable? (axiom-lhs rule)) |
| 117 | 98 | (when (variable-occurs-in (axiom-lhs rule) |
| 118 | (axiom-rhs rule)) | |
| 119 | ;; (format t "..setting rule mark `need-copy'") | |
| 120 | (setf (axiom-need-copy rule) t)) | |
| 121 | ;; | |
| 99 | (axiom-rhs rule)) | |
| 100 | (setf (axiom-need-copy rule) t)) | |
| 122 | 101 | (unless (eq (axiom-type rule) :rule) |
| 123 | (unless (axiom-non-exec rule) | |
| 124 | (with-output-chaos-warning () | |
| 125 | (princ "the LHS of axiom : ") | |
| 126 | (print-next) | |
| 127 | (print-chaos-object rule) | |
| 128 | (print-next) | |
| 129 | (princ " is just a variable, ignored as rewrite rule."))) | |
| 130 | (setf (axiom-kind rule) ':bad-rule) | |
| 131 | (setf (axiom-kind ax) ':bad-rule)) | |
| 102 | (unless (axiom-non-exec rule) | |
| 103 | (with-output-chaos-warning () | |
| 104 | (princ "the LHS of axiom : ") | |
| 105 | (print-next) | |
| 106 | (print-chaos-object rule) | |
| 107 | (print-next) | |
| 108 | (princ " is just a variable, ignored as rewrite rule."))) | |
| 109 | (setf (axiom-kind rule) ':bad-rule) | |
| 110 | (setf (axiom-kind ax) ':bad-rule)) | |
| 132 | 111 | (return-from gen-rule-internal nil)) |
| 133 | ;; | |
| 134 | 112 | (let ((rhs-vars (term-variables (axiom-rhs rule))) |
| 135 | (cond-vars (term-variables (axiom-condition rule)))) | |
| 113 | (cond-vars (term-variables (axiom-condition rule)))) | |
| 136 | 114 | (declare (type list rhs-vars cond-vars)) |
| 137 | 115 | (cond ((and lhsv |
| 138 | (or (not (subsetp rhs-vars lhsv)) | |
| 139 | (not (subsetp cond-vars lhsv)))) | |
| 140 | (when *chaos-verbose* | |
| 141 | (with-output-chaos-warning () | |
| 142 | (princ "the variables in RHS of the axiom : ") | |
| 143 | (print-next) (princ " ") | |
| 144 | (print-chaos-object rule) | |
| 145 | (print-next) | |
| 146 | (princ "is not a subset of variables in LHS, system does not guarantee the result of the rewriting."))) | |
| 147 | ;; (setf (axiom-kind rule) ':bad-rule) | |
| 148 | ;; (setf (axiom-kind ax) ':bad-rule)) | |
| 149 | (add-rule-to-module module rule) | |
| 150 | (unless (term-is-variable? (axiom-lhs rule)) | |
| 151 | (add-associative-extensions module | |
| 152 | (term-head (axiom-lhs rule)) | |
| 153 | rule) | |
| 154 | (specialize-rule rule module))) | |
| 155 | ;; | |
| 156 | ((and (axiom-is-behavioural rule) | |
| 157 | (not (and (term-can-be-in-beh-axiom? (axiom-lhs rule)) | |
| 158 | (term-can-be-in-beh-axiom? (axiom-rhs rule))))) | |
| 159 | (when *chaos-verbose* | |
| 160 | (with-output-chaos-warning () | |
| 161 | (princ "axiom violates context condition of behavioural axiom") | |
| 162 | (print-next) | |
| 163 | (print-chaos-object rule))) | |
| 164 | (if *allow-illegal-beh-axiom* | |
| 165 | (progn | |
| 166 | (setf (axiom-kind rule) ':bad-beh) | |
| 167 | (setf (axiom-kind ax) ':bad-beh) | |
| 168 | (add-rule-to-module module rule) | |
| 169 | (add-associative-extensions module | |
| 170 | (term-head (axiom-lhs rule)) | |
| 171 | rule) | |
| 172 | (specialize-rule rule module)) | |
| 173 | (progn | |
| 174 | (setf (axiom-kind rule) ':bad-rule) | |
| 175 | (setf (axiom-kind ax) ':bad-rule)))) | |
| 176 | ;; | |
| 177 | ;; all is ok, we can use this axiom as a rewrite rule | |
| 178 | (t (add-rule-to-module module rule) | |
| 179 | (unless (term-is-variable? (axiom-lhs rule)) | |
| 180 | (add-associative-extensions module | |
| 181 | (term-head (axiom-lhs rule)) | |
| 182 | rule) | |
| 183 | (specialize-rule rule module))))))) | |
| 116 | (or (not (subsetp rhs-vars lhsv)) | |
| 117 | (not (subsetp cond-vars lhsv)))) | |
| 118 | (unless (or (term-contains-match-op (axiom-rhs rule)) | |
| 119 | (term-contains-match-op (axiom-condition rule))) | |
| 120 | (when *chaos-verbose* | |
| 121 | (with-output-chaos-warning () | |
| 122 | (format t "RHS of the axiom has extra variable(s) which does not occur in LHS.") | |
| 123 | (print-next) | |
| 124 | (print-axiom-brief rule)))) | |
| 125 | (add-rule-to-module module rule) | |
| 126 | (unless (term-is-variable? (axiom-lhs rule)) | |
| 127 | (add-associative-extensions module | |
| 128 | (term-head (axiom-lhs rule)) | |
| 129 | rule) | |
| 130 | (specialize-rule rule module))) | |
| 131 | ((and (axiom-is-behavioural rule) | |
| 132 | (not (and (term-can-be-in-beh-axiom? (axiom-lhs rule)) | |
| 133 | (term-can-be-in-beh-axiom? (axiom-rhs rule))))) | |
| 134 | (when *chaos-verbose* | |
| 135 | (with-output-chaos-warning () | |
| 136 | (princ "axiom violates context condition of behavioural axiom") | |
| 137 | (print-next) | |
| 138 | (print-chaos-object rule))) | |
| 139 | (if *allow-illegal-beh-axiom* | |
| 140 | (progn | |
| 141 | (setf (axiom-kind rule) ':bad-beh) | |
| 142 | (setf (axiom-kind ax) ':bad-beh) | |
| 143 | (add-rule-to-module module rule) | |
| 144 | (add-associative-extensions module | |
| 145 | (term-head (axiom-lhs rule)) | |
| 146 | rule) | |
| 147 | (specialize-rule rule module)) | |
| 148 | (progn | |
| 149 | (setf (axiom-kind rule) ':bad-rule) | |
| 150 | (setf (axiom-kind ax) ':bad-rule)))) | |
| 151 | ;; all is ok, we can use this axiom as a rewrite rule | |
| 152 | (t (add-rule-to-module module rule) | |
| 153 | (unless (term-is-variable? (axiom-lhs rule)) | |
| 154 | (add-associative-extensions module | |
| 155 | (term-head (axiom-lhs rule)) | |
| 156 | rule) | |
| 157 | (specialize-rule rule module))))))) | |
| 184 | 158 | |
| 185 | 159 | (defun gather-submodule-rules (module) |
| 186 | 160 | (declare (type module module) |
| 187 | (values list)) | |
| 161 | (values list)) | |
| 188 | 162 | (labels ((module-specific-rules (mod) |
| 189 | (let ((res nil)) | |
| 190 | (dolist (e (module-own-axioms mod) res) | |
| 191 | #|| | |
| 192 | (let ((new (cdr (assq e (module-axioms-to-be-fixed mod))))) | |
| 193 | (when new (setq e new)) | |
| 194 | (unless (term-is-variable? (axiom-lhs e)) | |
| 195 | (push e res))) | |
| 196 | ||# | |
| 197 | (block next-axiom | |
| 198 | (let ((lhs (rule-lhs e))) | |
| 199 | (when (and (term-is-applform? lhs) | |
| 200 | (method-is-error-method (term-head lhs))) | |
| 201 | (return-from next-axiom nil)) | |
| 202 | (unless (term-is-variable? lhs) | |
| 203 | (push e res)))) | |
| 204 | ))) | |
| 205 | (rule-member? (rule list-of-rule) | |
| 206 | (dolist (e list-of-rule) | |
| 207 | (when (rule-is-similar? rule e) | |
| 208 | (return t)))) | |
| 209 | (union-rules (ax1 ax2) | |
| 210 | (let ((res ax2)) | |
| 211 | (dolist (ex ax1) | |
| 212 | (unless (rule-member? ex res) (push ex res))) | |
| 213 | res) )) | |
| 163 | (let ((res nil)) | |
| 164 | (dolist (e (module-own-axioms mod) res) | |
| 165 | #|| | |
| 166 | (let ((new (cdr (assq e (module-axioms-to-be-fixed mod))))) | |
| 167 | (when new (setq e new)) | |
| 168 | (unless (term-is-variable? (axiom-lhs e)) | |
| 169 | (push e res))) | |
| 170 | ||# | |
| 171 | (block next-axiom | |
| 172 | (let ((lhs (rule-lhs e))) | |
| 173 | (when (and (term-is-applform? lhs) | |
| 174 | (method-is-error-method (term-head lhs))) | |
| 175 | (return-from next-axiom nil)) | |
| 176 | (unless (term-is-variable? lhs) | |
| 177 | (push e res)))) | |
| 178 | ))) | |
| 179 | (rule-member? (rule list-of-rule) | |
| 180 | (dolist (e list-of-rule) | |
| 181 | (when (rule-is-similar? rule e) | |
| 182 | (return t)))) | |
| 183 | (union-rules (ax1 ax2) | |
| 184 | (let ((res ax2)) | |
| 185 | (dolist (ex ax1) | |
| 186 | (unless (rule-member? ex res) (push ex res))) | |
| 187 | res) )) | |
| 214 | 188 | (let ((res nil)) |
| 215 | 189 | (dolist (submodule (module-all-submodules module)) |
| 216 | (unless (or (eq :using (cdr submodule)) | |
| 217 | (eq :modmorph (cdr submodule))) | |
| 218 | (unless (module-is-ready-for-rewriting (car submodule)) | |
| 219 | (compile-module (car submodule))) | |
| 220 | (setf res (union-rules (module-specific-rules (car submodule)) res)))) | |
| 190 | (unless (or (eq :using (cdr submodule)) | |
| 191 | (eq :modmorph (cdr submodule))) | |
| 192 | (unless (module-is-ready-for-rewriting (car submodule)) | |
| 193 | (compile-module (car submodule))) | |
| 194 | (setf res (union-rules (module-specific-rules (car submodule)) res)))) | |
| 221 | 195 | res))) |
| 222 | 196 | |
| 223 | 197 | (defun get-dis-submodule-axioms (mod) |
| 224 | 198 | (declare (type module mod) |
| 225 | (values list)) | |
| 199 | (values list)) | |
| 226 | 200 | (let ((res nil)) |
| 227 | 201 | (dolist (submodule (module-all-submodules mod)) |
| 228 | 202 | (unless (or (eq :using (cdr submodule)) |
| 229 | (eq :modmorph (cdr submodule))) | |
| 230 | (unless (module-is-ready-for-rewriting (car submodule)) | |
| 231 | (compile-module (car submodule))) | |
| 232 | (push (cons (car submodule) | |
| 233 | (module-own-axioms (car submodule))) | |
| 234 | res))) | |
| 203 | (eq :modmorph (cdr submodule))) | |
| 204 | (unless (module-is-ready-for-rewriting (car submodule)) | |
| 205 | (compile-module (car submodule))) | |
| 206 | (push (cons (car submodule) | |
| 207 | (module-own-axioms (car submodule))) | |
| 208 | res))) | |
| 235 | 209 | res)) |
| 236 | 210 | |
| 237 | 211 | ;;; TODO for record/class. |
| 240 | 214 | |
| 241 | 215 | (defun specialize-rule (r mod) |
| 242 | 216 | (declare (type axiom r) |
| 243 | (type module mod) | |
| 244 | (values t)) | |
| 217 | (type module mod) | |
| 218 | (values t)) | |
| 245 | 219 | (let* ((lhs (axiom-lhs r)) |
| 246 | (method (if (term-is-applform? lhs) | |
| 247 | (term-head lhs) | |
| 248 | nil)) | |
| 249 | (mmod (method-module method)) | |
| 250 | (promod (if *ignore-protected-modules* | |
| 251 | nil | |
| 252 | (module-protected-modules mod))) | |
| 253 | (opinfo-table (module-opinfo-table mod))) | |
| 220 | (method (if (term-is-applform? lhs) | |
| 221 | (term-head lhs) | |
| 222 | nil)) | |
| 223 | (mmod (method-module method)) | |
| 224 | (promod (if *ignore-protected-modules* | |
| 225 | nil | |
| 226 | (module-protected-modules mod))) | |
| 227 | (opinfo-table (module-opinfo-table mod))) | |
| 254 | 228 | (when (and method |
| 255 | (null (get-method-info method (module-opinfo-table mod)))) | |
| 229 | (null (get-method-info method (module-opinfo-table mod)))) | |
| 256 | 230 | (return-from specialize-rule nil)) |
| 257 | 231 | ;; |
| 258 | 232 | (when (and method (method-is-error-method method)) |
| 264 | 238 | (specialize-for-methods |
| 265 | 239 | r |
| 266 | 240 | (if (method-is-universal method) |
| 267 | (method-lower-methods method opinfo-table) | |
| 268 | (remove-if #'(lambda (meth) | |
| 269 | (let ((xmod (method-module meth))) | |
| 270 | (and (not (eq xmod mmod)) | |
| 271 | (if (assq mmod (module-all-submodules xmod)) | |
| 272 | (memq mmod (module-protected-modules xmod)) | |
| 273 | (memq xmod promod))))) | |
| 274 | (method-lower-methods method opinfo-table))) | |
| 241 | (method-lower-methods method opinfo-table) | |
| 242 | (remove-if #'(lambda (meth) | |
| 243 | (let ((xmod (method-module meth))) | |
| 244 | (and (not (eq xmod mmod)) | |
| 245 | (if (assq mmod (module-all-submodules xmod)) | |
| 246 | (memq mmod (module-protected-modules xmod)) | |
| 247 | (memq xmod promod))))) | |
| 248 | (method-lower-methods method opinfo-table))) | |
| 275 | 249 | mod)))) |
| 276 | 250 | |
| 277 | 251 | (defun specialize-for-methods (r methods mod) |
| 278 | 252 | (declare (type axiom r) |
| 279 | (type list methods) | |
| 280 | (type module mod) | |
| 281 | (values t)) | |
| 253 | (type list methods) | |
| 254 | (type module mod) | |
| 255 | (values t)) | |
| 282 | 256 | (let ((lhs (axiom-lhs r))) |
| 283 | 257 | (dolist (method methods) |
| 284 | 258 | (when (rule-check-down mod method (term-subterms lhs)) |
| 285 | (add-rule-to-method r method (module-opinfo-table mod)) | |
| 286 | (add-associative-extensions mod method r) | |
| 287 | )) | |
| 259 | (add-rule-to-method r method (module-opinfo-table mod)) | |
| 260 | (add-associative-extensions mod method r) | |
| 261 | )) | |
| 288 | 262 | (add-associative-extensions mod (term-head lhs) r) |
| 289 | 263 | mod)) |
| 290 | 264 | |
| 291 | 265 | (defun add-associative-extensions (mod method r) |
| 292 | 266 | (declare (type module mod) |
| 293 | (type method method) | |
| 294 | (type axiom r) | |
| 295 | (values t)) | |
| 267 | (type method method) | |
| 268 | (type axiom r) | |
| 269 | (values t)) | |
| 296 | 270 | (when (term-is-lisp-form? (rule-rhs r)) |
| 297 | 271 | (return-from add-associative-extensions nil)) |
| 298 | 272 | (when (method-is-associative method) |
| 299 | 273 | (dolist (method-above (list-associative-method-above method)) |
| 300 | 274 | (unless (or (method-is-error-method method-above) |
| 301 | (member r (method-all-rules method-above))) | |
| 302 | (if (method-is-commutative method-above) | |
| 303 | ;; AC extension | |
| 304 | (let ((new-var (make-variable-term (car (method-arity method-above)) | |
| 305 | ;; *cosmos* | |
| 306 | 'ac)) | |
| 307 | ac-rule) | |
| 308 | (setf ac-rule | |
| 309 | (make-rule | |
| 310 | :lhs (make-right-assoc-normal-form method-above | |
| 311 | (cons new-var | |
| 312 | (list-assoc-subterms | |
| 313 | (axiom-lhs r) | |
| 314 | (term-head | |
| 315 | (axiom-lhs r))))) | |
| 316 | :rhs (make-applform (method-coarity method-above) | |
| 317 | method-above | |
| 318 | (list new-var | |
| 319 | ;;(substitution-check-builtin | |
| 320 | ;; (axiom-rhs r)) | |
| 321 | (axiom-rhs r) | |
| 322 | )) | |
| 323 | :condition (axiom-condition r) | |
| 324 | :id-condition (axiom-id-condition r) | |
| 325 | :labels (axiom-labels r) | |
| 326 | :type (axiom-type r) | |
| 327 | :meta-and-or (rule-meta-and-or r) | |
| 328 | :behavioural (axiom-is-behavioural r) | |
| 329 | :kind (if (eq ':id-theorem (axiom-kind r)) | |
| 330 | ':id-ext-theory | |
| 331 | ':ac-theory))) | |
| 332 | ;; (compute-rule-method ac-rule) | |
| 333 | (add-rule-to-method ac-rule method-above (module-opinfo-table mod))) | |
| 334 | ||
| 335 | ;; A extension. | |
| 336 | (let ((new-var (make-variable-term *cosmos* 'a1)) | |
| 337 | (new-var2 (make-variable-term *cosmos* 'a2)) | |
| 338 | a-rule) | |
| 339 | (setf a-rule | |
| 340 | (make-rule | |
| 341 | :lhs (make-right-assoc-normal-form method-above | |
| 342 | (cons new-var | |
| 343 | (list-assoc-subterms | |
| 344 | (axiom-lhs r) | |
| 345 | (term-head | |
| 346 | (axiom-lhs r))))) | |
| 347 | :rhs (make-applform (method-coarity method-above) | |
| 348 | method-above | |
| 349 | (list new-var | |
| 350 | ;;(substitution-check-builtin | |
| 351 | ;;(axiom-rhs r)) | |
| 352 | (axiom-rhs r) | |
| 353 | )) | |
| 354 | :condition (axiom-condition r) | |
| 355 | :id-condition (axiom-id-condition r) | |
| 356 | :labels (axiom-labels r) | |
| 357 | :type (axiom-type r) | |
| 358 | :meta-and-or (rule-meta-and-or r) | |
| 359 | :behavioural (axiom-is-behavioural r) | |
| 360 | :kind (if (eq ':id-theorem (axiom-kind r)) | |
| 361 | ':id-ext-theory | |
| 362 | ':a-left-theory))) | |
| 363 | ;; (compute-rule-method a-rule) | |
| 364 | (add-rule-to-method a-rule method-above (module-opinfo-table mod)) | |
| 365 | ||
| 366 | (setf a-rule | |
| 367 | (make-rule | |
| 368 | :lhs (make-right-assoc-normal-form method-above | |
| 369 | (append | |
| 370 | (list-assoc-subterms | |
| 371 | (axiom-lhs r) | |
| 372 | (term-head (axiom-lhs r))) | |
| 373 | (list new-var))) | |
| 374 | :rhs (make-applform (method-coarity method-above) | |
| 375 | method-above | |
| 376 | (list ;; (substitution-check-builtin (axiom-rhs r)) | |
| 377 | (axiom-rhs r) | |
| 378 | new-var)) | |
| 379 | :condition (axiom-condition r) | |
| 380 | :id-condition (axiom-id-condition r) | |
| 381 | :labels (axiom-labels r) | |
| 382 | :type (axiom-type r) | |
| 383 | :meta-and-or (rule-meta-and-or r) | |
| 384 | :behavioural (axiom-is-behavioural r) | |
| 385 | :kind (if (eq ':id-theorem (axiom-kind r)) | |
| 386 | ':id-ext-theory | |
| 387 | ':a-right-theory))) | |
| 388 | ;; (compute-rule-method a-rule) | |
| 389 | (add-rule-to-method a-rule method-above (module-opinfo-table mod)) | |
| 390 | ||
| 391 | (setf a-rule | |
| 392 | (make-rule | |
| 393 | :lhs (make-right-assoc-normal-form method-above | |
| 394 | (append (list new-var2) | |
| 395 | (list-assoc-subterms | |
| 396 | (axiom-lhs r) | |
| 397 | (term-head | |
| 398 | (axiom-lhs | |
| 399 | r))) | |
| 400 | (list new-var))) | |
| 401 | :rhs (make-right-assoc-normal-form | |
| 402 | method-above | |
| 403 | (list new-var2 | |
| 404 | ;; (substitution-check-built-in (axiom-rhs r)) | |
| 405 | (axiom-rhs r) | |
| 406 | new-var)) | |
| 407 | :condition (axiom-condition r) | |
| 408 | :id-condition (axiom-id-condition r) | |
| 409 | :labels (axiom-labels r) | |
| 410 | :type (axiom-type r) | |
| 411 | :meta-and-or (rule-meta-and-or r) | |
| 412 | :behavioural (axiom-is-behavioural r) | |
| 413 | :kind (if (eq ':id-theorem (axiom-kind r)) | |
| 414 | ':id-ext-theory | |
| 415 | ':a-middle-theory))) | |
| 416 | ;; (compute-rule-method a-rule) | |
| 417 | (add-rule-to-method a-rule method-above (module-opinfo-table mod)))) | |
| 418 | )))) | |
| 275 | (member r (method-all-rules method-above))) | |
| 276 | (if (method-is-commutative method-above) | |
| 277 | ;; AC extension | |
| 278 | (let ((new-var (make-variable-term (car (method-arity method-above)) | |
| 279 | ;; *cosmos* | |
| 280 | 'ac)) | |
| 281 | ac-rule) | |
| 282 | (setf ac-rule | |
| 283 | (make-rule | |
| 284 | :lhs (make-right-assoc-normal-form method-above | |
| 285 | (cons new-var | |
| 286 | (list-assoc-subterms | |
| 287 | (axiom-lhs r) | |
| 288 | (term-head | |
| 289 | (axiom-lhs r))))) | |
| 290 | :rhs (make-applform (method-coarity method-above) | |
| 291 | method-above | |
| 292 | (list new-var | |
| 293 | ;;(substitution-check-builtin | |
| 294 | ;; (axiom-rhs r)) | |
| 295 | (axiom-rhs r) | |
| 296 | )) | |
| 297 | :condition (axiom-condition r) | |
| 298 | :id-condition (axiom-id-condition r) | |
| 299 | :labels (axiom-labels r) | |
| 300 | :type (axiom-type r) | |
| 301 | :meta-and-or (rule-meta-and-or r) | |
| 302 | :behavioural (axiom-is-behavioural r) | |
| 303 | :kind (if (eq ':id-theorem (axiom-kind r)) | |
| 304 | ':id-ext-theory | |
| 305 | ':ac-theory))) | |
| 306 | ;; (compute-rule-method ac-rule) | |
| 307 | (add-rule-to-method ac-rule method-above (module-opinfo-table mod))) | |
| 308 | ||
| 309 | ;; A extension. | |
| 310 | (let ((new-var (make-variable-term *cosmos* 'a1)) | |
| 311 | (new-var2 (make-variable-term *cosmos* 'a2)) | |
| 312 | a-rule) | |
| 313 | (setf a-rule | |
| 314 | (make-rule | |
| 315 | :lhs (make-right-assoc-normal-form method-above | |
| 316 | (cons new-var | |
| 317 | (list-assoc-subterms | |
| 318 | (axiom-lhs r) | |
| 319 | (term-head | |
| 320 | (axiom-lhs r))))) | |
| 321 | :rhs (make-applform (method-coarity method-above) | |
| 322 | method-above | |
| 323 | (list new-var | |
| 324 | ;;(substitution-check-builtin | |
| 325 | ;;(axiom-rhs r)) | |
| 326 | (axiom-rhs r) | |
| 327 | )) | |
| 328 | :condition (axiom-condition r) | |
| 329 | :id-condition (axiom-id-condition r) | |
| 330 | :labels (axiom-labels r) | |
| 331 | :type (axiom-type r) | |
| 332 | :meta-and-or (rule-meta-and-or r) | |
| 333 | :behavioural (axiom-is-behavioural r) | |
| 334 | :kind (if (eq ':id-theorem (axiom-kind r)) | |
| 335 | ':id-ext-theory | |
| 336 | ':a-left-theory))) | |
| 337 | ;; (compute-rule-method a-rule) | |
| 338 | (add-rule-to-method a-rule method-above (module-opinfo-table mod)) | |
| 339 | ||
| 340 | (setf a-rule | |
| 341 | (make-rule | |
| 342 | :lhs (make-right-assoc-normal-form method-above | |
| 343 | (append | |
| 344 | (list-assoc-subterms | |
| 345 | (axiom-lhs r) | |
| 346 | (term-head (axiom-lhs r))) | |
| 347 | (list new-var))) | |
| 348 | :rhs (make-applform (method-coarity method-above) | |
| 349 | method-above | |
| 350 | (list ;; (substitution-check-builtin (axiom-rhs r)) | |
| 351 | (axiom-rhs r) | |
| 352 | new-var)) | |
| 353 | :condition (axiom-condition r) | |
| 354 | :id-condition (axiom-id-condition r) | |
| 355 | :labels (axiom-labels r) | |
| 356 | :type (axiom-type r) | |
| 357 | :meta-and-or (rule-meta-and-or r) | |
| 358 | :behavioural (axiom-is-behavioural r) | |
| 359 | :kind (if (eq ':id-theorem (axiom-kind r)) | |
| 360 | ':id-ext-theory | |
| 361 | ':a-right-theory))) | |
| 362 | (add-rule-to-method a-rule method-above (module-opinfo-table mod)) | |
| 363 | ||
| 364 | (setf a-rule | |
| 365 | (make-rule | |
| 366 | :lhs (make-right-assoc-normal-form method-above | |
| 367 | (append (list new-var2) | |
| 368 | (list-assoc-subterms | |
| 369 | (axiom-lhs r) | |
| 370 | (term-head | |
| 371 | (axiom-lhs | |
| 372 | r))) | |
| 373 | (list new-var))) | |
| 374 | :rhs (make-right-assoc-normal-form | |
| 375 | method-above | |
| 376 | (list new-var2 | |
| 377 | ;; (substitution-check-built-in (axiom-rhs r)) | |
| 378 | (axiom-rhs r) | |
| 379 | new-var)) | |
| 380 | :condition (axiom-condition r) | |
| 381 | :id-condition (axiom-id-condition r) | |
| 382 | :labels (axiom-labels r) | |
| 383 | :type (axiom-type r) | |
| 384 | :meta-and-or (rule-meta-and-or r) | |
| 385 | :behavioural (axiom-is-behavioural r) | |
| 386 | :kind (if (eq ':id-theorem (axiom-kind r)) | |
| 387 | ':id-ext-theory | |
| 388 | ':a-middle-theory))) | |
| 389 | (add-rule-to-method a-rule method-above (module-opinfo-table mod)))))))) | |
| 419 | 390 | |
| 420 | 391 | (defun rule-check-down (mod method terms) |
| 421 | 392 | (declare (ignore mod) |
| 422 | (type module mod) | |
| 423 | (type method method) | |
| 424 | (type list terms) | |
| 425 | (values (or null t))) | |
| 393 | (type module mod) | |
| 394 | (type method method) | |
| 395 | (type list terms) | |
| 396 | (values (or null t))) | |
| 426 | 397 | (not (eq ':fail |
| 427 | (compute-var-info | |
| 428 | (mapcar #'cons terms (method-arity method)) | |
| 429 | nil)))) | |
| 398 | (compute-var-info | |
| 399 | (mapcar #'cons terms (method-arity method)) | |
| 400 | nil)))) | |
| 430 | 401 | |
| 431 | 402 | ;; term-s ::= ( (term . sort) ... ) |
| 432 | 403 | ;; cvi ::= ( (variable . (sort ... )) ... ) |
| 433 | 404 | ;; |
| 434 | 405 | (defun sort-is-general (sort) |
| 435 | 406 | (declare (type sort-struct sort) |
| 436 | (values (or null t))) | |
| 407 | (values (or null t))) | |
| 437 | 408 | (or (sort= sort *cosmos*) |
| 438 | 409 | (sort= sort *universal-sort*) |
| 439 | 410 | (sort= sort *huniversal-sort*))) |
| 440 | 411 | |
| 441 | 412 | (defun compute-var-info (term-s cvi) |
| 442 | 413 | (declare (type list term-s cvi) |
| 443 | (values t)) | |
| 414 | (values t)) | |
| 444 | 415 | (if (null term-s) |
| 445 | 416 | cvi |
| 446 | 417 | (let ((term (caar term-s)) |
| 447 | (sort (cdar term-s))) | |
| 448 | (declare (type term term) | |
| 449 | (type sort* sort)) | |
| 450 | (cond ((term-is-variable? term) | |
| 451 | (let ((vi (cdr (assoc term cvi)))) | |
| 452 | (if vi | |
| 453 | (if (member sort vi) | |
| 454 | (compute-var-info (cdr term-s) cvi) | |
| 455 | (let ((res (if (sort-is-general sort) | |
| 456 | (list sort) | |
| 457 | (max-minorants (cons sort vi) | |
| 458 | *current-sort-order*)))) | |
| 459 | (if res | |
| 460 | (compute-var-info | |
| 461 | (cdr term-s) (cons (cons term res) cvi)) | |
| 462 | ;; don't really need to add new if res = [sort set] vi | |
| 463 | ':fail))) | |
| 464 | (let ((vs (variable-sort term))) | |
| 465 | (if (sort= vs sort) | |
| 466 | (compute-var-info | |
| 467 | (cdr term-s) (cons (cons term (list sort)) cvi)) | |
| 468 | (let ((res (if (sort-is-general vs) | |
| 469 | (list sort) | |
| 470 | (max-minorants (list sort vs) | |
| 471 | *current-sort-order*)))) | |
| 472 | (if res | |
| 473 | (compute-var-info | |
| 474 | (cdr term-s) (cons (cons term res) cvi)) | |
| 475 | ':fail))))))) | |
| 476 | ((term-is-builtin-constant? term) | |
| 477 | (if (sort<= (term-sort term) sort *current-sort-order*) | |
| 478 | (compute-var-info (cdr term-s) cvi) | |
| 479 | ':fail)) | |
| 480 | (t (let ((methods (highest-methods-below (term-head term) sort))) | |
| 481 | (if (null methods) | |
| 482 | ':fail | |
| 483 | (dolist (meth methods ':fail) | |
| 484 | (let ((res (compute-var-info | |
| 485 | (append (mapcar #'cons | |
| 486 | (term-subterms term) | |
| 487 | (method-arity meth)) | |
| 488 | (cdr term-s)) | |
| 489 | cvi))) | |
| 490 | (unless (eq ':fail res) | |
| 491 | (return res))))))))) | |
| 492 | )) | |
| 418 | (sort (cdar term-s))) | |
| 419 | (declare (type term term) | |
| 420 | (type sort* sort)) | |
| 421 | (cond ((term-is-variable? term) | |
| 422 | (let ((vi (cdr (assoc term cvi)))) | |
| 423 | (if vi | |
| 424 | (if (member sort vi) | |
| 425 | (compute-var-info (cdr term-s) cvi) | |
| 426 | (let ((res (if (sort-is-general sort) | |
| 427 | (list sort) | |
| 428 | (max-minorants (cons sort vi) | |
| 429 | *current-sort-order*)))) | |
| 430 | (if res | |
| 431 | (compute-var-info | |
| 432 | (cdr term-s) (cons (cons term res) cvi)) | |
| 433 | ;; don't really need to add new if res = [sort set] vi | |
| 434 | ':fail))) | |
| 435 | (let ((vs (variable-sort term))) | |
| 436 | (if (sort= vs sort) | |
| 437 | (compute-var-info | |
| 438 | (cdr term-s) (cons (cons term (list sort)) cvi)) | |
| 439 | (let ((res (if (sort-is-general vs) | |
| 440 | (list sort) | |
| 441 | (max-minorants (list sort vs) | |
| 442 | *current-sort-order*)))) | |
| 443 | (if res | |
| 444 | (compute-var-info | |
| 445 | (cdr term-s) (cons (cons term res) cvi)) | |
| 446 | ':fail))))))) | |
| 447 | ((term-is-builtin-constant? term) | |
| 448 | (if (sort<= (term-sort term) sort *current-sort-order*) | |
| 449 | (compute-var-info (cdr term-s) cvi) | |
| 450 | ':fail)) | |
| 451 | (t (let ((methods (highest-methods-below (term-head term) sort))) | |
| 452 | (if (null methods) | |
| 453 | ':fail | |
| 454 | (dolist (meth methods ':fail) | |
| 455 | (let ((res (compute-var-info | |
| 456 | (append (mapcar #'cons | |
| 457 | (term-subterms term) | |
| 458 | (method-arity meth)) | |
| 459 | (cdr term-s)) | |
| 460 | cvi))) | |
| 461 | (unless (eq ':fail res) | |
| 462 | (return res))))))))))) | |
| 493 | 463 | |
| 494 | 464 | ;;;----------------------------------------------------------------------------- |
| 495 | 465 | (defun normalize-rules-in (mod) |
| 496 | 466 | mod) |
| 497 | 467 | |
| 498 | 468 | ;;;============================================================================= |
| 499 | ;;; SPECIAL AXIOMS FOR IDEMPOTENT & IDENTITY | |
| 469 | ;;; SPECIAL AXIOMS FOR IDEMPOTENT & IDENTITY | |
| 500 | 470 | ;;;_____________________________________________________________________________ |
| 501 | 471 | |
| 502 | 472 | (let (($rule-counter 0)) |
| 504 | 474 | |
| 505 | 475 | (defun create-rule-name (mod label) |
| 506 | 476 | (declare (ignore mod) |
| 507 | (type simple-string label) | |
| 508 | (values list)) | |
| 477 | (type simple-string label) | |
| 478 | (values list)) | |
| 509 | 479 | (prog1 |
| 510 | (list (intern (format nil "~a~a" label $rule-counter))) | |
| 511 | (incf $rule-counter))) | |
| 512 | ) | |
| 480 | (list (intern (format nil "~a~a" label $rule-counter))) | |
| 481 | (incf $rule-counter)))) | |
| 513 | 482 | |
| 514 | 483 | (defun add-operator-theory-axioms (module opinfo) |
| 515 | 484 | (declare (type module module) |
| 516 | (type list opinfo) | |
| 517 | (values t)) | |
| 485 | (type list opinfo) | |
| 486 | (values t)) | |
| 518 | 487 | (let* ((op (opinfo-operator opinfo)) |
| 519 | thy | |
| 520 | (var nil) | |
| 521 | (l-sort nil) | |
| 522 | (var2 nil) | |
| 523 | (r-sort nil)) | |
| 488 | thy | |
| 489 | (var nil) | |
| 490 | (l-sort nil) | |
| 491 | (var2 nil) | |
| 492 | (r-sort nil)) | |
| 524 | 493 | (dolist (meth (opinfo-methods opinfo)) |
| 525 | 494 | (when (and (eq (method-module meth) module) |
| 526 | (not (method-is-error-method meth))) | |
| 527 | (setf thy (method-theory meth)) | |
| 528 | ;; IDEM | |
| 529 | (when (theory-contains-idempotency thy) | |
| 530 | (setq l-sort (car (method-arity meth))) | |
| 531 | (setq var (make-variable-term l-sort '|U-idem|)) | |
| 532 | (adjoin-axiom-to-module | |
| 533 | module | |
| 534 | (make-rule | |
| 535 | :lhs (make-applform (method-coarity meth) | |
| 536 | meth | |
| 537 | (list var var)) | |
| 538 | :rhs var | |
| 539 | :condition *BOOL-TRUE* | |
| 540 | :labels (create-rule-name module "idem") | |
| 541 | :type ':equation | |
| 542 | :kind ':IDEM-THEORY))) | |
| 543 | ;; IDENT | |
| 544 | (when (and (or (theory-contains-identity thy) (theory-zero thy)) | |
| 545 | (= 2 (the fixnum (operator-num-args op)))) | |
| 546 | (let* ((so (module-sort-order module)) | |
| 547 | (comm (theory-contains-commutativity thy)) | |
| 548 | (id (car (theory-zero thy))) | |
| 549 | (id-sort (cond ((term-is-builtin-constant? id) | |
| 550 | (term-sort id)) | |
| 551 | ((term-is-applform? id) | |
| 552 | (method-coarity (term-head id))) | |
| 553 | (t (error "Internal Error, Illegal identity ~s" id))))) | |
| 554 | (setq l-sort (car (method-arity meth))) | |
| 555 | (setq r-sort (cadr (method-arity meth))) | |
| 556 | (let ((flag nil)) | |
| 557 | (when id | |
| 558 | ;; add axiom: id op x = x | |
| 559 | (when (sort<= id-sort l-sort so) | |
| 560 | (setq flag t) | |
| 561 | (setq var (make-variable-term l-sort 'X-id)) | |
| 562 | (adjoin-axiom-to-module | |
| 563 | module | |
| 564 | (make-rule | |
| 565 | :lhs (make-applform (method-coarity meth) | |
| 566 | meth | |
| 567 | (list id var)) | |
| 568 | :rhs var | |
| 569 | :condition *BOOL-TRUE* | |
| 570 | :type ':equation | |
| 571 | :labels (create-rule-name module "ident") | |
| 572 | :kind ':ID-THEOREM))) | |
| 573 | ;; add axiom: x op id = x (possibly). | |
| 574 | (unless (and flag comm) | |
| 575 | (when (sort<= id-sort r-sort so) | |
| 576 | (setq var2 (make-variable-term l-sort 'Y-id)) | |
| 577 | (adjoin-axiom-to-module | |
| 578 | module | |
| 579 | (make-rule | |
| 580 | :lhs (make-applform (method-coarity meth) | |
| 581 | meth | |
| 582 | (list var2 id)) | |
| 583 | :rhs var2 | |
| 584 | :condition *BOOL-TRUE* | |
| 585 | :labels (create-rule-name module "ident") | |
| 586 | :type ':equation | |
| 587 | :kind ':ID-THEOREM)))))))))))) | |
| 495 | (not (method-is-error-method meth))) | |
| 496 | (setf thy (method-theory meth)) | |
| 497 | ;; IDEM | |
| 498 | (when (theory-contains-idempotency thy) | |
| 499 | (setq l-sort (car (method-arity meth))) | |
| 500 | (setq var (make-variable-term l-sort '|U-idem|)) | |
| 501 | (adjoin-axiom-to-module | |
| 502 | module | |
| 503 | (make-rule | |
| 504 | :lhs (make-applform (method-coarity meth) | |
| 505 | meth | |
| 506 | (list var var)) | |
| 507 | :rhs var | |
| 508 | :condition *BOOL-TRUE* | |
| 509 | :labels (create-rule-name module "idem") | |
| 510 | :type ':equation | |
| 511 | :kind ':IDEM-THEORY))) | |
| 512 | ;; IDENT | |
| 513 | (when (and (or (theory-contains-identity thy) (theory-zero thy)) | |
| 514 | (= 2 (the fixnum (operator-num-args op)))) | |
| 515 | (let* ((so (module-sort-order module)) | |
| 516 | (comm (theory-contains-commutativity thy)) | |
| 517 | (id (car (theory-zero thy))) | |
| 518 | (id-sort (cond ((term-is-builtin-constant? id) | |
| 519 | (term-sort id)) | |
| 520 | ((term-is-applform? id) | |
| 521 | (method-coarity (term-head id))) | |
| 522 | (t (error "Internal Error, Illegal identity ~s" id))))) | |
| 523 | (setq l-sort (car (method-arity meth))) | |
| 524 | (setq r-sort (cadr (method-arity meth))) | |
| 525 | (let ((flag nil)) | |
| 526 | (when id | |
| 527 | ;; add axiom: id op x = x | |
| 528 | (when (sort<= id-sort l-sort so) | |
| 529 | (setq flag t) | |
| 530 | (setq var (make-variable-term l-sort 'X-id)) | |
| 531 | (adjoin-axiom-to-module | |
| 532 | module | |
| 533 | (make-rule | |
| 534 | :lhs (make-applform (method-coarity meth) | |
| 535 | meth | |
| 536 | (list id var)) | |
| 537 | :rhs var | |
| 538 | :condition *BOOL-TRUE* | |
| 539 | :type ':equation | |
| 540 | :labels (create-rule-name module "ident") | |
| 541 | :kind ':ID-THEOREM))) | |
| 542 | ;; add axiom: x op id = x (possibly). | |
| 543 | (unless (and flag comm) | |
| 544 | (when (sort<= id-sort r-sort so) | |
| 545 | (setq var2 (make-variable-term l-sort 'Y-id)) | |
| 546 | (adjoin-axiom-to-module | |
| 547 | module | |
| 548 | (make-rule | |
| 549 | :lhs (make-applform (method-coarity meth) | |
| 550 | meth | |
| 551 | (list var2 id)) | |
| 552 | :rhs var2 | |
| 553 | :condition *BOOL-TRUE* | |
| 554 | :labels (create-rule-name module "ident") | |
| 555 | :type ':equation | |
| 556 | :kind ':ID-THEOREM)))))))))))) | |
| 588 | 557 | |
| 589 | 558 | (defun add-identity-completions (module) |
| 590 | 559 | (declare (type module module) |
| 591 | (values t)) | |
| 560 | (values t)) | |
| 561 | (when *no-id-completion* | |
| 562 | (return-from add-identity-completions nil)) | |
| 592 | 563 | (with-in-module (module) |
| 593 | 564 | (when (some #'(lambda (opinfo) |
| 594 | (dolist (meth (opinfo-methods opinfo)) | |
| 595 | (let ((thy (method-theory meth))) | |
| 596 | (when (and (theory-contains-identity thy) | |
| 597 | (not (cdr (theory-zero thy)))) | |
| 598 | (return t))))) | |
| 599 | (module-all-operators module)) | |
| 565 | (dolist (meth (opinfo-methods opinfo)) | |
| 566 | (let ((thy (method-theory meth))) | |
| 567 | (when (and (theory-contains-identity thy) | |
| 568 | (not (cdr (theory-zero thy)))) | |
| 569 | (return t))))) | |
| 570 | (module-all-operators module)) | |
| 600 | 571 | (dolist (a (axiom-set$equations (module-axiom-set module))) |
| 601 | (add-identity-completions-internal a module)) | |
| 572 | (add-identity-completions-internal a module)) | |
| 602 | 573 | (dolist (r (axiom-set$rules (module-axiom-set module))) |
| 603 | (add-identity-completions-internal r module))))) | |
| 574 | (add-identity-completions-internal r module))))) | |
| 604 | 575 | |
| 605 | 576 | (defun add-identity-completions-internal (r module) |
| 606 | 577 | (declare (type axiom r) |
| 607 | (type module module) | |
| 608 | (values t)) | |
| 578 | (type module module) | |
| 579 | (values t)) | |
| 609 | 580 | (when *gen-rule-debug* |
| 610 | 581 | (format t "~%[id-compl] given rule ~a, of kind ~a " r (axiom-kind r)) |
| 611 | (print-next) | |
| 612 | (print-chaos-object r)) | |
| 582 | (print-next)) | |
| 613 | 583 | (unless (axiom-kind r) |
| 614 | 584 | (let (varval |
| 615 | (res nil) | |
| 616 | (newres (list (list r nil nil))) | |
| 617 | a-axiom | |
| 618 | subst | |
| 619 | val) | |
| 585 | (res nil) | |
| 586 | (newres (list (list r nil nil))) | |
| 587 | a-axiom | |
| 588 | subst | |
| 589 | val) | |
| 620 | 590 | (loop |
| 621 | (setq val (car newres)) | |
| 622 | (setq newres (cdr newres)) | |
| 623 | (setq a-axiom (car val)) | |
| 624 | (setq subst (cadr val)) | |
| 625 | ;; -- res : LIST[rule subst [status]]. | |
| 626 | ;; -- varval : value to substitute in, | |
| 627 | ;; -- a-axiom: rule generating new axioms from | |
| 628 | ;; -- status : bad/good --- in res have status, but not in newres | |
| 629 | (if (test-bad-axiom a-axiom) | |
| 630 | (unless (rule-inf-subst-member subst res) | |
| 631 | (setq res (cons (list a-axiom subst 'bad) res))) | |
| 632 | (progn | |
| 633 | (setq res (cons (list a-axiom subst 'good) res)) | |
| 634 | (let ((donesubst nil) | |
| 635 | sub1 | |
| 636 | new-axiom | |
| 637 | newsubst) | |
| 638 | (loop | |
| 639 | (setq varval | |
| 640 | (compute-var-for-identity-completions | |
| 641 | (axiom-lhs a-axiom) | |
| 642 | donesubst)) | |
| 643 | (unless varval (return)) | |
| 644 | (setq sub1 (cons varval nil)) | |
| 645 | (setq newsubst (substitution-can (cons varval subst))) | |
| 646 | (setq donesubst (cons (car sub1) donesubst)) | |
| 647 | (setq new-axiom (insert-val sub1 a-axiom)) | |
| 648 | (unless (or (null new-axiom) | |
| 649 | (rule-inf-subst-member newsubst res)) | |
| 650 | (setq newres (cons (list new-axiom newsubst) newres))))))) | |
| 651 | (unless newres (return))) | |
| 591 | (setq val (car newres)) | |
| 592 | (setq newres (cdr newres)) | |
| 593 | (setq a-axiom (car val)) | |
| 594 | (setq subst (cadr val)) | |
| 595 | ;; -- res : LIST[rule subst [status]]. | |
| 596 | ;; -- varval : value to substitute in, | |
| 597 | ;; -- a-axiom: rule generating new axioms from | |
| 598 | ;; -- status : bad/good --- in res have status, but not in newres | |
| 599 | (if (test-bad-axiom a-axiom) | |
| 600 | (unless (rule-inf-subst-member subst res) | |
| 601 | (setq res (cons (list a-axiom subst 'bad) res))) | |
| 602 | (progn | |
| 603 | (setq res (cons (list a-axiom subst 'good) res)) | |
| 604 | (let ((donesubst nil) | |
| 605 | sub1 | |
| 606 | new-axiom | |
| 607 | newsubst) | |
| 608 | (loop | |
| 609 | (setq varval | |
| 610 | (compute-var-for-identity-completions | |
| 611 | (axiom-lhs a-axiom) | |
| 612 | donesubst)) | |
| 613 | (unless varval (return)) | |
| 614 | (setq sub1 (cons varval nil)) | |
| 615 | (setq newsubst (substitution-can (cons varval subst))) | |
| 616 | (setq donesubst (cons (car sub1) donesubst)) | |
| 617 | (setq new-axiom (insert-val sub1 a-axiom module)) | |
| 618 | (unless (or (null new-axiom) | |
| 619 | (rule-inf-subst-member newsubst res)) | |
| 620 | (setq newres (cons (list new-axiom newsubst) newres))))))) | |
| 621 | (unless newres (return))) | |
| 652 | 622 | ;; |
| 653 | 623 | (let ((errs nil) |
| 654 | (rules1 nil) | |
| 655 | (rules2 nil) | |
| 656 | badver) | |
| 657 | (dolist (ruli res) | |
| 658 | (let ((rul (car ruli))) | |
| 659 | (if (eq 'bad (nth 2 ruli)) | |
| 660 | (push ruli errs) | |
| 661 | (unless (rule-inf-member rul rules1) | |
| 662 | (push ruli rules1))))) | |
| 663 | ;; | |
| 664 | (setq rules2 (list (list r nil))) | |
| 665 | (dolist (ruli rules1) | |
| 666 | (let ((rul (car ruli))) | |
| 667 | (unless (or (dolist (ruli2 rules2 nil) | |
| 668 | (when (rule-subsumes (car ruli2) rul) | |
| 669 | (return t))) | |
| 670 | (dolist (ruli2 rules1 nil) ;This is horrific | |
| 671 | (let ((rul2 (car ruli2))) | |
| 672 | (when (and (not (eq rul rul2)) | |
| 673 | (rule-strictly-subsumes rul2 rul)) | |
| 674 | (return t))))) | |
| 675 | (push ruli rules2)))) | |
| 676 | ;; | |
| 677 | (dolist (ruli rules2) | |
| 678 | (let ((rul (car ruli)) | |
| 679 | (rulsubst (cadr ruli))) | |
| 680 | (setq badver nil) | |
| 681 | (dolist (bruli errs) | |
| 682 | (when (substitution-subset-list rulsubst (cadr bruli)) | |
| 683 | (push (cadr bruli) badver))) | |
| 684 | (let ((newrule rul) | |
| 685 | (newidcond (make-id-condition | |
| 686 | (term-variables (axiom-lhs rul)) | |
| 687 | badver))) | |
| 688 | (setf (axiom-id-condition newrule) newidcond) | |
| 689 | (when (and (null (axiom-labels newrule)) | |
| 690 | (not (eq r newrule))) | |
| 691 | (setf (axiom-labels newrule) | |
| 692 | (create-rule-name module "compl"))) | |
| 693 | ;; #|| | |
| 694 | (when (axiom-extensions newrule) | |
| 695 | (dolist (e (axiom-a-extensions newrule)) | |
| 696 | (setf (axiom-id-condition e) newidcond)) | |
| 697 | (dolist (e (axiom-AC-extension newrule)) | |
| 698 | (setf (axiom-id-condition e) newidcond))) | |
| 699 | ;; ||# | |
| 700 | (dolist (e (axiom-extensions newrule)) | |
| 701 | (when e | |
| 702 | (setf (axiom-id-condition e) newidcond))) | |
| 703 | ;; | |
| 704 | ;; (break) | |
| 705 | (unless (eq r rul) | |
| 706 | (adjoin-axiom-to-module module newrule))))))))) | |
| 707 | ||
| 624 | (rules1 nil) | |
| 625 | (rules2 nil) | |
| 626 | badver) | |
| 627 | (dolist (ruli res) | |
| 628 | (let ((rul (car ruli))) | |
| 629 | (if (eq 'bad (nth 2 ruli)) | |
| 630 | (push ruli errs) | |
| 631 | (unless (rule-inf-member rul rules1) | |
| 632 | (push ruli rules1))))) | |
| 633 | ;; | |
| 634 | (setq rules2 (list (list r nil))) | |
| 635 | (dolist (ruli rules1) | |
| 636 | (let ((rul (car ruli))) | |
| 637 | (unless (or (dolist (ruli2 rules2 nil) | |
| 638 | (when (rule-subsumes (car ruli2) rul) | |
| 639 | (return t))) | |
| 640 | (dolist (ruli2 rules1 nil) | |
| 641 | (let ((rul2 (car ruli2))) | |
| 642 | (when (and (not (eq rul rul2)) | |
| 643 | (rule-strictly-subsumes rul2 rul)) | |
| 644 | (return t))))) | |
| 645 | (push ruli rules2)))) | |
| 646 | ;; | |
| 647 | (when *chaos-verbose* | |
| 648 | (let ((rs (reverse rules1))) | |
| 649 | (format t "~%** id-completion for rule: ") | |
| 650 | (print-axiom-brief r) | |
| 651 | (let ((*print-indent* (+ 2 *print-indent*))) | |
| 652 | (print-next) | |
| 653 | (princ "-- Generated rules:") | |
| 654 | (print-next) | |
| 655 | (if rs | |
| 656 | (let ((*chaos-verbose* nil)) | |
| 657 | (dolist (r (reverse rs)) | |
| 658 | (print-axiom-brief (car r)) | |
| 659 | (print-next))) | |
| 660 | (progn (princ "none") (print-next))) | |
| 661 | (princ "-- Generated, but invalid rules:") | |
| 662 | (print-next) | |
| 663 | (if errs | |
| 664 | (let ((lst (reverse errs))) | |
| 665 | (loop | |
| 666 | (when (null lst) (return)) | |
| 667 | (unless (rule-inf-member (caar lst) (cdr lst)) | |
| 668 | (print-axiom-brief (caar lst)) | |
| 669 | (print-next)) | |
| 670 | (setq lst (cdr lst)))) | |
| 671 | (progn (princ "none") (print-next))))) | |
| 672 | (flush-all)) | |
| 673 | ;; | |
| 674 | (dolist (ruli rules2) | |
| 675 | (let ((rul (car ruli)) | |
| 676 | (rulsubst (cadr ruli))) | |
| 677 | (setq badver nil) | |
| 678 | (dolist (bruli errs) | |
| 679 | (when (substitution-subset-list rulsubst (cadr bruli)) | |
| 680 | (push (cadr bruli) badver))) | |
| 681 | (let ((newrule rul) | |
| 682 | (newidcond (make-id-condition (term-variables (axiom-lhs rul)) | |
| 683 | badver))) | |
| 684 | (when *chaos-verbose* | |
| 685 | (unless (and (null newidcond) (eq r newrule)) | |
| 686 | (if (eq r newrule) | |
| 687 | (format t "~% -- Modified with Id condition:~% ") | |
| 688 | (if (rule-occurs newrule (module-equations module)) | |
| 689 | (format t "~% -- Required rule: ~% ") | |
| 690 | (format t "~% -- Added rule: ~% ")))) | |
| 691 | (flush-all)) | |
| 692 | ;; | |
| 693 | (setf (axiom-id-condition newrule) newidcond) | |
| 694 | (when (and (null (axiom-labels newrule)) | |
| 695 | (not (eq r newrule))) | |
| 696 | (setf (axiom-labels newrule) | |
| 697 | (create-rule-name module "compl"))) | |
| 698 | (when (axiom-extensions newrule) | |
| 699 | (dolist (e (axiom-a-extensions newrule)) | |
| 700 | (setf (axiom-id-condition e) newidcond)) | |
| 701 | (dolist (e (axiom-AC-extension newrule)) | |
| 702 | (setf (axiom-id-condition e) newidcond))) | |
| 703 | (dolist (e (axiom-extensions newrule)) | |
| 704 | (when e | |
| 705 | (setf (axiom-id-condition e) newidcond))) | |
| 706 | ;; | |
| 707 | (when *chaos-verbose* | |
| 708 | (unless (and (null newidcond) (eq r rul)) | |
| 709 | (print-axiom-brief rul))) | |
| 710 | ;; | |
| 711 | (unless (eq r rul) | |
| 712 | (when *gen-rule-debug* | |
| 713 | (format t "~%[id-compl]=> ") | |
| 714 | (print-chaos-object newrule)) | |
| 715 | (adjoin-axiom-to-module module newrule))))))))) | |
| 716 | ||
| 717 | ;;; mark rules which brings problematic rewrting (LHS is var, infinite loop) as 'bad | |
| 718 | ;;; | |
| 708 | 719 | (defun test-bad-axiom (ax) |
| 709 | 720 | (declare (type axiom ax) |
| 710 | (values (or null t))) | |
| 721 | (values (or null t))) | |
| 711 | 722 | (or (term-is-variable? (axiom-lhs ax)) |
| 712 | 723 | (and (is-true? (axiom-condition ax)) |
| 713 | (term-occurs-as-subterm (axiom-lhs ax) (axiom-rhs ax))) | |
| 724 | (term-occurs-as-subterm (axiom-lhs ax) (axiom-rhs ax))) | |
| 714 | 725 | (term-occurs-as-subterm (axiom-lhs ax) (axiom-condition ax)) |
| 715 | 726 | (term-is-similar? (axiom-lhs ax) (axiom-rhs ax)))) |
| 716 | 727 | |
| 717 | 728 | (defun rule-inf-member (ax riset) |
| 718 | 729 | (declare (type axiom ax) |
| 719 | (type list riset) | |
| 720 | (values (or null t))) | |
| 730 | (type list riset) | |
| 731 | (values (or null t))) | |
| 721 | 732 | (dolist (ax2 riset nil) |
| 722 | 733 | (when (rule-is-similar? ax (car ax2)) |
| 723 | 734 | (return t)))) |
| 724 | 735 | |
| 725 | 736 | (defun rule-inf-subst-member (subst riset) |
| 726 | 737 | (declare (type list subst riset) |
| 727 | (values (or null t))) | |
| 738 | (values (or null t))) | |
| 728 | 739 | (dolist (rul2 riset nil) |
| 729 | 740 | (when (substitution-equal subst (cadr rul2)) |
| 730 | 741 | (return t)))) |
| 734 | 745 | ;;; but we are in a bind, since we don't know them at "this point". |
| 735 | 746 | (defun term-occurs-as-subterm (t1 t2) |
| 736 | 747 | (declare (type term t1 t2) |
| 737 | (values (or null t))) | |
| 748 | (values (or null t))) | |
| 738 | 749 | (when *gen-rule-debug* |
| 739 | 750 | (with-output-simple-msg () |
| 740 | 751 | (format t "[term-occurs-as-subterm]: t1 = ") |
| 745 | 756 | (if (term-is-variable? t2) |
| 746 | 757 | nil |
| 747 | 758 | (if (term-is-applform? t2) |
| 748 | (multiple-value-bind (gst subs nomatch eequal) | |
| 749 | (if (method-is-of-same-operator (term-head t1) (term-head t2)) | |
| 750 | (first-match t1 t2) | |
| 751 | (values nil nil t nil)) | |
| 752 | (declare (ignore gst subs eequal)) | |
| 753 | (if (not nomatch) | |
| 754 | t | |
| 755 | (dolist (t2st (term-subterms t2) nil) | |
| 756 | (when (term-occurs-as-subterm t1 t2st) (return t))))) | |
| 757 | ;; | |
| 758 | nil))) | |
| 759 | (multiple-value-bind (gst subs nomatch eequal) | |
| 760 | (if (method-is-of-same-operator (term-head t1) (term-head t2)) | |
| 761 | (first-match t1 t2) | |
| 762 | (values nil nil t nil)) | |
| 763 | (declare (ignore gst subs eequal)) | |
| 764 | (if (not nomatch) | |
| 765 | t | |
| 766 | (dolist (t2st (term-subterms t2) nil) | |
| 767 | (when (term-occurs-as-subterm t1 t2st) (return t))))) | |
| 768 | ;; | |
| 769 | nil))) | |
| 759 | 770 | |
| 760 | 771 | (defun compute-var-for-identity-completions (term donesubst) |
| 761 | 772 | (declare (type term term) |
| 762 | (type list donesubst)) | |
| 773 | (type list donesubst)) | |
| 763 | 774 | (select-var-for-identity-completions term donesubst)) |
| 764 | 775 | |
| 765 | 776 | (defun select-var-for-identity-completions (term donesubst) |
| 766 | 777 | (declare (type term term) |
| 767 | (type list donesubst)) | |
| 778 | (type list donesubst)) | |
| 768 | 779 | (cond ((or (term-is-variable? term) (term-is-constant? term)) nil) |
| 769 | (t (let* ((meth (term-head term)) | |
| 770 | (thy (method-theory meth)) | |
| 771 | (id-flag (and (theory-contains-identity thy) | |
| 772 | (null (cdr (theory-zero thy))))) | |
| 773 | (id (if id-flag (car (theory-zero thy))))) | |
| 774 | (if id | |
| 775 | (select-var-for-identity-completions-alt2 meth id term donesubst) | |
| 776 | (dolist (sb (term-subterms term)) | |
| 777 | (let ((val (select-var-for-identity-completions sb donesubst))) | |
| 778 | (when val (return val))))))))) | |
| 780 | (t (let* ((meth (term-head term)) | |
| 781 | (thy (method-theory meth)) | |
| 782 | (id-flag (and (theory-contains-identity thy) | |
| 783 | (null (cdr (theory-zero thy))))) | |
| 784 | (id (if id-flag (car (theory-zero thy))))) | |
| 785 | (if id | |
| 786 | (select-var-for-identity-completions-alt2 meth id term donesubst) | |
| 787 | (dolist (sb (term-subterms term)) | |
| 788 | (let ((val (select-var-for-identity-completions sb donesubst))) | |
| 789 | (when val (return val))))))))) | |
| 779 | 790 | |
| 780 | 791 | (defun select-var-for-identity-completions-alt2 (meth id term donesubst) |
| 781 | 792 | (declare (type method meth) |
| 782 | (type t id) | |
| 783 | (type term term) | |
| 784 | (type list donesubst)) | |
| 793 | (type t id) | |
| 794 | (type term term) | |
| 795 | (type list donesubst)) | |
| 785 | 796 | (let ((val1 (select-var-for-identity-completions-alt meth |
| 786 | id | |
| 787 | (term-arg-1 term) | |
| 788 | donesubst))) | |
| 797 | id | |
| 798 | (term-arg-1 term) | |
| 799 | donesubst))) | |
| 789 | 800 | (if val1 |
| 790 | val1 | |
| 801 | val1 | |
| 791 | 802 | (let ((val2 (select-var-for-identity-completions-alt meth |
| 792 | id | |
| 793 | (term-arg-2 term) | |
| 794 | donesubst))) | |
| 795 | val2)))) | |
| 803 | id | |
| 804 | (term-arg-2 term) | |
| 805 | donesubst))) | |
| 806 | val2)))) | |
| 796 | 807 | |
| 797 | 808 | (defun select-var-for-identity-completions-alt (meth id term donesubst) |
| 798 | 809 | (declare (type method meth) |
| 799 | (type t id) | |
| 800 | (type term term) | |
| 801 | (type list donesubst)) | |
| 810 | (type t id) | |
| 811 | (type term term) | |
| 812 | (type list donesubst)) | |
| 802 | 813 | (cond ((term-is-variable? term) |
| 803 | (let ((srt (variable-sort term)) | |
| 804 | (so (module-sort-order *current-module*))) | |
| 805 | (when (and (not (term-is-an-error id)) | |
| 806 | (sort<= (term-sort id) srt so) | |
| 807 | (not (occurs-var-val term id donesubst))) | |
| 808 | (cons term id)))) | |
| 809 | ((term-is-constant? term) nil) | |
| 810 | ((method= meth (term-head term)) | |
| 811 | (select-var-for-identity-completions-alt2 meth id term donesubst)) | |
| 812 | ((theory-is-empty-for-matching (method-theory (term-head term))) | |
| 813 | (select-var-for-identity-completions term donesubst)) | |
| 814 | (t (select-var-for-identity-completions term donesubst)))) | |
| 814 | (let ((srt (variable-sort term)) | |
| 815 | (so (module-sort-order *current-module*))) | |
| 816 | (when (and (not (term-is-an-error id)) | |
| 817 | (sort<= (term-sort id) srt so) | |
| 818 | (not (occurs-var-val term id donesubst))) | |
| 819 | (cons term id)))) | |
| 820 | ((term-is-constant? term) nil) | |
| 821 | ((method= meth (term-head term)) | |
| 822 | (select-var-for-identity-completions-alt2 meth id term donesubst)) | |
| 823 | ((theory-is-empty-for-matching (method-theory (term-head term))) | |
| 824 | (select-var-for-identity-completions term donesubst)) | |
| 825 | (t (select-var-for-identity-completions term donesubst)))) | |
| 815 | 826 | |
| 816 | 827 | (defun occurs-var-val (var val y) |
| 817 | 828 | (declare (type term var val) |
| 818 | (type list y) | |
| 819 | (values (or null t))) | |
| 829 | (type list y) | |
| 830 | (values (or null t))) | |
| 820 | 831 | (dolist (ye y nil) |
| 821 | 832 | (when (and (eq var (car ye)) |
| 822 | (eq val (cdr ye))) | |
| 833 | (eq val (cdr ye))) | |
| 823 | 834 | (return t)))) |
| 824 | 835 | |
| 825 | (defun insert-val (subs rul) | |
| 836 | (defun insert-val (subs rul &optional (module *current-module*)) | |
| 826 | 837 | (declare (type list subs) |
| 827 | (type axiom rul) | |
| 828 | (values (or null axiom))) | |
| 838 | (type axiom rul) | |
| 839 | (values (or null axiom))) | |
| 829 | 840 | (let (($$trace-rewrite nil) |
| 830 | ($$trace-rewrite-whole nil)) | |
| 841 | ($$trace-rewrite-whole nil) | |
| 842 | (*m-pattern-subst* nil)) | |
| 831 | 843 | (let ((newcond (if (is-true? (axiom-condition rul)) |
| 832 | *BOOL-true* | |
| 833 | (term-simplify | |
| 834 | (normalize-for-identity-total | |
| 835 | (substitution-partial-image subs (axiom-condition rul))))))) | |
| 844 | *BOOL-true* | |
| 845 | (term-simplify | |
| 846 | (normalize-for-identity-total | |
| 847 | (substitution-partial-image subs (axiom-condition rul))) | |
| 848 | module)))) | |
| 849 | (when *gen-rule-debug* | |
| 850 | (format t "~%[insert-val]:----------") | |
| 851 | (format t "~% given rule : ") | |
| 852 | (print-axiom-brief rul) | |
| 853 | (format t "~% subst : ") | |
| 854 | (print-substitution subs) | |
| 855 | (format t "~% newcond : ") | |
| 856 | (term-print-with-sort newcond)) | |
| 836 | 857 | (if (is-false? newcond) |
| 837 | nil | |
| 838 | (let ((rule nil) | |
| 839 | (lhs (normalize-for-identity-total | |
| 840 | (substitution-partial-image subs (axiom-lhs rul)))) | |
| 841 | (rhs (term-simplify | |
| 842 | (normalize-for-identity-total | |
| 843 | (substitution-partial-image subs | |
| 844 | (axiom-rhs rul))))) | |
| 845 | (condition (if (is-true? newcond) | |
| 846 | *BOOL-TRUE* | |
| 847 | newcond))) | |
| 848 | (unless (and (term-is-really-well-defined lhs) | |
| 849 | (term-is-really-well-defined rhs) | |
| 850 | (term-is-really-well-defined condition)) | |
| 851 | (return-from insert-val nil)) | |
| 852 | ;; | |
| 853 | (when (term-is-similar? lhs rhs) | |
| 854 | (return-from insert-val nil)) | |
| 855 | ;; | |
| 856 | (setq rule | |
| 857 | (make-rule | |
| 858 | :lhs lhs | |
| 859 | :rhs rhs | |
| 860 | :condition condition | |
| 861 | :type (axiom-type rul) | |
| 862 | :kind ':id-completion | |
| 863 | :meta-and-or (rule-meta-and-or rul) | |
| 864 | :labels (cons (car (create-rule-name 'dummy "idcomp")) (axiom-labels rul)))) | |
| 865 | ;; | |
| 866 | ;; | |
| 867 | (when *gen-rule-debug* | |
| 868 | (format t "~%invert-val: ") | |
| 869 | (format t "~% given rule : ") | |
| 870 | (print-chaos-object rul) | |
| 871 | (format t "~% gen rule : ") | |
| 872 | (print-chaos-object rule)) | |
| 873 | rule))))) | |
| 858 | (progn | |
| 859 | (when *gen-rule-debug* | |
| 860 | (format t "~% newcond = ") | |
| 861 | (term-print-with-sort newcond)) | |
| 862 | nil) | |
| 863 | (let ((rule nil) | |
| 864 | (lhs (normalize-for-identity-total | |
| 865 | (substitution-partial-image subs (axiom-lhs rul)))) | |
| 866 | (rhs (term-simplify | |
| 867 | (normalize-for-identity-total | |
| 868 | (substitution-partial-image subs | |
| 869 | (axiom-rhs rul))) | |
| 870 | module)) | |
| 871 | (condition (if (is-true? newcond) | |
| 872 | *BOOL-TRUE* | |
| 873 | newcond))) | |
| 874 | (unless (and (term-is-really-well-defined lhs) | |
| 875 | (term-is-really-well-defined rhs) | |
| 876 | (term-is-really-well-defined condition)) | |
| 877 | (when *gen-rule-debug* | |
| 878 | (format t "~%<< ill defined axiom: ") | |
| 879 | (format t "~% lhs: ")(term-print-with-sort lhs) | |
| 880 | (format t "~% rhs: ")(term-print-with-sort rhs) | |
| 881 | (format t "~% cnd: ")(term-print-with-sort condition)) | |
| 882 | (return-from insert-val nil)) | |
| 883 | (setq rule | |
| 884 | (make-rule | |
| 885 | :lhs lhs | |
| 886 | :rhs rhs | |
| 887 | :condition condition | |
| 888 | :type (axiom-type rul) | |
| 889 | :kind ':id-completion | |
| 890 | :meta-and-or (rule-meta-and-or rul) | |
| 891 | :labels (cons (car (create-rule-name 'dummy "idcomp")) (axiom-labels rul)))) | |
| 892 | ;; | |
| 893 | (when *gen-rule-debug* | |
| 894 | (format t "~% gen rule : ") | |
| 895 | (print-chaos-object rule)) | |
| 896 | rule))))) | |
| 874 | 897 | |
| 875 | 898 | ;;;============================================================================= |
| 876 | 899 | (defun rule-make-or-list (l) |
| 877 | 900 | (declare (type list l) |
| 878 | (values list)) | |
| 901 | (values list)) | |
| 879 | 902 | (if (null (cdr l)) (car l) (cons 'or l))) |
| 880 | 903 | |
| 881 | 904 | (defun rule-make-and-list (l) |
| 882 | 905 | (declare (type list l) |
| 883 | (values list)) | |
| 906 | (values list)) | |
| 884 | 907 | (if (null (cdr l)) (car l) (cons 'and l))) |
| 885 | 908 | |
| 886 | 909 | (defun rule-make-eqeqeq (x) |
| 887 | 910 | (declare (type list x) |
| 888 | (values list)) | |
| 911 | (values list)) | |
| 889 | 912 | (list 'equal (car x) (cdr x))) |
| 890 | 913 | |
| 891 | 914 | (defun rule-make-or-cond (x y) |
| 892 | 915 | (declare (type list x y) |
| 893 | (values list)) | |
| 916 | (values list)) | |
| 894 | 917 | (if (eq nil y) x |
| 895 | 918 | (if (and (consp y) (eq 'or (car y))) |
| 896 | (list* 'or x (cdr y)) | |
| 897 | (list 'or x y)))) | |
| 919 | (list* 'or x (cdr y)) | |
| 920 | (list 'or x y)))) | |
| 898 | 921 | |
| 899 | 922 | (defun rule-make-and-cond (x y) |
| 900 | 923 | (declare (type t x y) |
| 901 | (values list)) | |
| 924 | (values list)) | |
| 902 | 925 | (if (eq 't y) x |
| 903 | 926 | (if (and (consp y) (eq 'and (car y))) |
| 904 | (list* 'and x (cdr y)) | |
| 905 | (list 'and x y)))) | |
| 906 | ||
| 907 | (defvar *enable-id-condition* nil) | |
| 927 | (list* 'and x (cdr y)) | |
| 928 | (list 'and x y)))) | |
| 929 | ||
| 930 | (defvar *enable-id-condition* t) | |
| 908 | 931 | |
| 909 | 932 | (defun make-id-condition (vars subs) |
| 910 | 933 | (declare (type list vars subs) |
| 911 | (values list)) | |
| 934 | (values list)) | |
| 912 | 935 | (when *enable-id-condition* |
| 913 | 936 | (let ((subs2 nil)) |
| 914 | 937 | (dolist (sub subs) |
| 915 | (when sub | |
| 916 | (let ((subcan (substitution-can (substitution-restrict vars sub)))) | |
| 917 | (when (and subcan | |
| 918 | (not (member subcan subs2 :test #'substitution-equal))) | |
| 919 | (push subcan subs2))))) | |
| 938 | (when sub | |
| 939 | (let ((subcan (substitution-can (substitution-restrict vars sub)))) | |
| 940 | (unless (or (null subcan) | |
| 941 | (member subcan subs2 :test #'substitution-equal)) | |
| 942 | (push subcan subs2))))) | |
| 920 | 943 | (when subs2 |
| 921 | (list 'not (make-improved-id-cond subs2))) | |
| 922 | ))) | |
| 944 | (list 'not (make-improved-id-cond subs2)))))) | |
| 923 | 945 | |
| 924 | 946 | ;;; cond as list of substitutions |
| 925 | 947 | (defun make-improved-id-cond (cond) |
| 926 | 948 | (declare (type (or null term) cond)) |
| 927 | 949 | (if cond |
| 928 | 950 | (let ((atomic (compute-atomic cond))) |
| 929 | (improve-id-cnd (elim-supersets (canonicalize-atomic cond atomic)))) | |
| 951 | (improve-id-cnd (elim-supersets (canonicalize-atomic cond atomic)))) | |
| 930 | 952 | nil)) |
| 931 | 953 | |
| 932 | 954 | ;;; c assumed canonicalized and in DNF |
| 937 | 959 | (rule-make-and-list |
| 938 | 960 | (mapcar #'rule-make-eqeqeq (car c))) |
| 939 | 961 | (let ((freqs (compute-atomic-freq c)) |
| 940 | max | |
| 941 | nxt | |
| 942 | p1 | |
| 943 | p2 | |
| 944 | flag) | |
| 962 | max | |
| 963 | nxt | |
| 964 | p1 | |
| 965 | p2 | |
| 966 | flag) | |
| 945 | 967 | (declare (type (or null fixnum) max)) |
| 946 | 968 | ;; |
| 947 | 969 | (setq nxt (caar freqs)) |
| 948 | 970 | (setq max (cdar freqs)) |
| 949 | 971 | (dolist (e (cdr freqs)) |
| 950 | (when (< (the fixnum max) (the fixnum (cdr e))) | |
| 951 | (setq nxt (car e) max (cdr e)))) | |
| 972 | (when (< (the fixnum max) (the fixnum (cdr e))) | |
| 973 | (setq nxt (car e) max (cdr e)))) | |
| 952 | 974 | (setq p1 nil p2 nil flag t) |
| 953 | 975 | (dolist (s c) |
| 954 | (unless (null s) | |
| 955 | (if (member-atomic nxt s) | |
| 956 | (when flag | |
| 957 | (let ((res (remove-atomic nxt s))) | |
| 958 | (if (null res) | |
| 959 | (setq flag nil | |
| 960 | p1 nil) | |
| 961 | (push res p1)))) | |
| 962 | (push s p2)))) | |
| 976 | (unless (null s) | |
| 977 | (if (member-atomic nxt s) | |
| 978 | (when flag | |
| 979 | (let ((res (remove-atomic nxt s))) | |
| 980 | (if (null res) | |
| 981 | (setq flag nil | |
| 982 | p1 nil) | |
| 983 | (push res p1)))) | |
| 984 | (push s p2)))) | |
| 963 | 985 | (when (and p1 (null flag)) (break "ERR")) |
| 964 | 986 | (if p1 |
| 965 | (setq p1 (improve-id-cnd p1)) | |
| 966 | (setq p1 t)) | |
| 987 | (setq p1 (improve-id-cnd p1)) | |
| 988 | (setq p1 t)) | |
| 967 | 989 | (when p2 (setq p2 (improve-id-cnd p2))) |
| 968 | 990 | (rule-make-or-cond (rule-make-and-cond (rule-make-eqeqeq nxt) p1) |
| 969 | p2)))) | |
| 991 | p2)))) | |
| 970 | 992 | |
| 971 | 993 | ;;; arg is list of substs |
| 972 | 994 | (defun compute-atomic (expr) |
| 974 | 996 | (let ((res nil)) |
| 975 | 997 | (dolist (x expr) |
| 976 | 998 | (dolist (y x) |
| 977 | (unless (member-atomic y res) | |
| 978 | (push y res)))) | |
| 999 | (unless (member-atomic y res) | |
| 1000 | (push y res)))) | |
| 979 | 1001 | res)) |
| 980 | 1002 | |
| 981 | 1003 | ;;; arg is list of substs |
| 982 | 1004 | (defun canonicalize-atomic (e atoms) |
| 983 | 1005 | (declare (type list e atoms) |
| 984 | (values list)) | |
| 1006 | (values list)) | |
| 985 | 1007 | (mapcar #'(lambda (x) |
| 986 | (mapcar #'(lambda (y) | |
| 987 | (or (member-atomic y atoms) | |
| 988 | y)) | |
| 989 | x)) | |
| 990 | e)) | |
| 1008 | (mapcar #'(lambda (y) | |
| 1009 | (or (member-atomic y atoms) | |
| 1010 | y)) | |
| 1011 | x)) | |
| 1012 | e)) | |
| 991 | 1013 | |
| 992 | 1014 | (defun compute-atomic-freq (expr) |
| 993 | 1015 | (declare (type list expr) |
| 994 | (values list)) | |
| 1016 | (values list)) | |
| 995 | 1017 | (let ((res nil)) |
| 996 | 1018 | (dolist (x expr) |
| 997 | 1019 | (dolist (y x) |
| 998 | (let ((val (assoc-atomic y res))) | |
| 999 | (if val (incf (the fixnum (cdr val))) | |
| 1000 | (push (cons y 1) res))))) | |
| 1020 | (let ((val (assoc-atomic y res))) | |
| 1021 | (if val (incf (the fixnum (cdr val))) | |
| 1022 | (push (cons y 1) res))))) | |
| 1001 | 1023 | res)) |
| 1002 | 1024 | |
| 1003 | 1025 | (defun member-atomic (x lst) |
| 1004 | 1026 | (declare (type list lst) |
| 1005 | (type t x) | |
| 1006 | (values (or null t))) | |
| 1027 | (type t x) | |
| 1028 | (values (or null t))) | |
| 1007 | 1029 | (dolist (e lst nil) |
| 1008 | 1030 | (when (same-atomic x e) (return e)))) |
| 1009 | 1031 | |
| 1010 | 1032 | (defun remove-atomic (x lst) |
| 1011 | 1033 | (declare (type t x) |
| 1012 | (type list lst) | |
| 1013 | (values list)) | |
| 1034 | (type list lst) | |
| 1035 | (values list)) | |
| 1014 | 1036 | (let ((res nil)) |
| 1015 | 1037 | (dolist (e lst) |
| 1016 | 1038 | (unless (same-atomic x e) |
| 1017 | (push e res))) | |
| 1039 | (push e res))) | |
| 1018 | 1040 | (nreverse res))) |
| 1019 | 1041 | |
| 1020 | 1042 | (defun assoc-atomic (x alist) |
| 1021 | 1043 | (declare (type t x) |
| 1022 | (list alist) | |
| 1023 | (values (or null t))) | |
| 1044 | (list alist) | |
| 1045 | (values (or null t))) | |
| 1024 | 1046 | (dolist (e alist nil) |
| 1025 | 1047 | (when (same-atomic x (car e)) (return e)))) |
| 1026 | 1048 | |
| 1027 | 1049 | (defun same-atomic (x y) |
| 1028 | 1050 | (declare (type list x y) |
| 1029 | (values (or null t))) | |
| 1051 | (values (or null t))) | |
| 1030 | 1052 | (and (consp x) (consp y) |
| 1031 | 1053 | (term-is-similar? (car x) (car y)) |
| 1032 | 1054 | (term-is-similar? (cdr x) (cdr y))) |
| 1034 | 1056 | |
| 1035 | 1057 | (defun elim-supersets (e) |
| 1036 | 1058 | (declare (type list e) |
| 1037 | (values list)) | |
| 1059 | (values list)) | |
| 1038 | 1060 | (let ((res nil)) |
| 1039 | 1061 | (dolist (x e) |
| 1040 | 1062 | (unless (dolist (y e nil) |
| 1041 | (when (and (not (eq x y)) | |
| 1042 | (substitution-subset y x)) | |
| 1043 | (return t))) | |
| 1044 | (push x res))) | |
| 1063 | (when (and (not (eq x y)) | |
| 1064 | (substitution-subset y x)) | |
| 1065 | (return t))) | |
| 1066 | (push x res))) | |
| 1045 | 1067 | res)) |
| 1046 | 1068 | |
| 1047 | 1069 | (defun make-id-condition-direct (vars subs) |
| 1048 | 1070 | (declare (type list vars subs) |
| 1049 | (values list)) | |
| 1071 | (values list)) | |
| 1050 | 1072 | (let ((subs2 nil)) |
| 1051 | 1073 | (dolist (sub subs) |
| 1052 | 1074 | (when sub |
| 1053 | (let ((subcan (substitution-can (substitution-restrict vars sub)))) | |
| 1054 | (unless (member subcan subs2 :test #'substitution-equal) | |
| 1055 | (push subcan subs2))))) | |
| 1075 | (let ((subcan (substitution-can (substitution-restrict vars sub)))) | |
| 1076 | (unless (member subcan subs2 :test #'substitution-equal) | |
| 1077 | (push subcan subs2))))) | |
| 1056 | 1078 | (if subs2 |
| 1057 | (list | |
| 1058 | 'not | |
| 1059 | (rule-make-or-list | |
| 1060 | (mapcar #'(lambda (sub) | |
| 1061 | (rule-make-and-list | |
| 1062 | (mapcar #'(lambda (si) | |
| 1063 | (list 'equal (car si) (cdr si))) | |
| 1064 | sub))) | |
| 1065 | subs2))) | |
| 1066 | nil))) | |
| 1079 | (list | |
| 1080 | 'not | |
| 1081 | (rule-make-or-list | |
| 1082 | (mapcar #'(lambda (sub) | |
| 1083 | (rule-make-and-list | |
| 1084 | (mapcar #'(lambda (si) | |
| 1085 | (list 'equal (car si) (cdr si))) | |
| 1086 | sub))) | |
| 1087 | subs2))) | |
| 1088 | nil))) | |
| 1067 | 1089 | |
| 1068 | 1090 | (defun normalize-for-identity-total (tm) |
| 1069 | 1091 | (declare (type term tm)) |
| 1070 | 1092 | (theory-standard-form (normalize-for-identity tm))) |
| 1071 | 1093 | |
| 1072 | 1094 | ;;; rules for and or not == =/= identical nonidentical must not have conditions |
| 1073 | (defun term-simplify (tm) | |
| 1095 | (defun term-simplify (tm &optional (module *current-module*)) | |
| 1074 | 1096 | (declare (type term tm) |
| 1075 | (values (or null term))) | |
| 1097 | (values (or null term))) | |
| 1076 | 1098 | (if (term-is-variable? tm) |
| 1077 | 1099 | nil |
| 1078 | (if (term-is-constant? tm) | |
| 1079 | nil | |
| 1080 | (let ((meth (term-head tm))) | |
| 1081 | (dolist (subtm (term-subterms tm)) | |
| 1082 | (term-simplify subtm)) | |
| 1083 | (if (or (eq *BOOL-and* meth) | |
| 1084 | (eq *BOOL-or* meth) | |
| 1085 | (eq *BOOL-not* meth) | |
| 1086 | (eq *BOOL-if* meth)) | |
| 1087 | (simplify-on-top tm) | |
| 1088 | (if (and (or (eq *BOOL-equal* meth) | |
| 1089 | (eq *BOOL-nonequal* meth) | |
| 1090 | (eq *identical* meth) | |
| 1091 | (eq *nonidentical* meth)) | |
| 1092 | (term-is-ground? (term-arg-1 tm)) | |
| 1093 | (term-is-ground? (term-arg-2 tm))) | |
| 1094 | (if (or (eq *BOOL-equal* meth) | |
| 1095 | (eq *identical* meth)) | |
| 1096 | (if (term-is-similar? (term-arg-1 tm) (term-arg-2 tm)) | |
| 1097 | (term-replace tm (simple-copy-term *BOOL-true*)) | |
| 1098 | nil) | |
| 1099 | (if (term-is-similar? (term-arg-1 tm) (term-arg-2 tm)) | |
| 1100 | (term-replace tm (simple-copy-term *BOOL-false*)) | |
| 1101 | nil)) | |
| 1102 | nil)) | |
| 1103 | ))) | |
| 1100 | (if (term-is-constant? tm) | |
| 1101 | nil | |
| 1102 | (let ((meth (term-head tm))) | |
| 1103 | (dolist (subtm (term-subterms tm)) | |
| 1104 | (term-simplify subtm module)) | |
| 1105 | (if (or (eq *BOOL-and* meth) | |
| 1106 | (eq *BOOL-or* meth) | |
| 1107 | (eq *BOOL-not* meth) | |
| 1108 | (eq *BOOL-if* meth)) | |
| 1109 | (simplify-on-top tm module) | |
| 1110 | (if (and (or (eq *BOOL-equal* meth) | |
| 1111 | (eq *BOOL-nonequal* meth) | |
| 1112 | (eq *identical* meth) | |
| 1113 | (eq *nonidentical* meth)) | |
| 1114 | (term-is-ground? (term-arg-1 tm)) | |
| 1115 | (term-is-ground? (term-arg-2 tm))) | |
| 1116 | (if (or (eq *BOOL-equal* meth) | |
| 1117 | (eq *identical* meth)) | |
| 1118 | (if (term-is-similar? (term-arg-1 tm) (term-arg-2 tm)) | |
| 1119 | (term-replace tm (simple-copy-term *BOOL-true*)) | |
| 1120 | nil) | |
| 1121 | (if (term-is-similar? (term-arg-1 tm) (term-arg-2 tm)) | |
| 1122 | (term-replace tm (simple-copy-term *BOOL-false*)) | |
| 1123 | nil)) | |
| 1124 | nil))))) | |
| 1104 | 1125 | tm) |
| 1105 | 1126 | |
| 1106 | 1127 | (defun normalize-for-identity (term) |
| 1107 | 1128 | (declare (type term term)) |
| 1108 | 1129 | (cond ((or (term-is-variable? term) (term-is-constant? term)) |
| 1109 | term) | |
| 1110 | (t (let* ((meth (term-head term)) | |
| 1111 | (thy (method-theory meth)) | |
| 1112 | (id-flag (and (theory-contains-identity thy) | |
| 1113 | (null (cdr (theory-zero thy))))) | |
| 1114 | (id (if id-flag (car (theory-zero thy)))) | |
| 1115 | (subs (mapcar #'normalize-for-identity | |
| 1116 | (term-subterms term)))) | |
| 1117 | (declare (type method meth) | |
| 1118 | (type list thy) | |
| 1119 | (type (or null t) id-flag) | |
| 1120 | (type (or null term) id) | |
| 1121 | (type list subs)) | |
| 1122 | (if id | |
| 1123 | (if (term-is-similar? (car subs) id) | |
| 1124 | (cadr subs) | |
| 1125 | (if (term-is-similar? (cadr subs) id) | |
| 1126 | (car subs) | |
| 1127 | (make-term-with-sort-check meth subs))) | |
| 1128 | (make-term-with-sort-check meth subs)))))) | |
| 1130 | term) | |
| 1131 | (t (let* ((meth (term-head term)) | |
| 1132 | (thy (method-theory meth)) | |
| 1133 | (id-flag (and (theory-contains-identity thy) | |
| 1134 | (null (cdr (theory-zero thy))))) | |
| 1135 | (id (if id-flag (car (theory-zero thy)))) | |
| 1136 | (subs (mapcar #'normalize-for-identity | |
| 1137 | (term-subterms term)))) | |
| 1138 | (declare (type method meth) | |
| 1139 | (type list thy) | |
| 1140 | (type (or null t) id-flag) | |
| 1141 | (type (or null term) id) | |
| 1142 | (type list subs)) | |
| 1143 | (if id | |
| 1144 | (if (term-is-similar? (car subs) id) | |
| 1145 | (cadr subs) | |
| 1146 | (if (term-is-similar? (cadr subs) id) | |
| 1147 | (car subs) | |
| 1148 | (make-term-with-sort-check meth subs))) | |
| 1149 | (make-term-with-sort-check meth subs)))))) | |
| 1129 | 1150 | ;;; EOF |
| 0 | 0 | ;;;-*- Mode:Lisp; Syntax:CommonLisp; Package:CHAOS -*- |
| 1 | 1 | ;;; |
| 2 | ;;; Copyright (c) 2000-2014, Toshimi Sawada. All rights reserved. | |
| 2 | ;;; Copyright (c) 2000-2015, Toshimi Sawada. All rights reserved. | |
| 3 | 3 | ;;; |
| 4 | 4 | ;;; Redistribution and use in source and binary forms, with or without |
| 5 | 5 | ;;; modification, are permitted provided that the following conditions |
| 27 | 27 | ;;; |
| 28 | 28 | (in-package :chaos) |
| 29 | 29 | #|============================================================================== |
| 30 | System:Chaos | |
| 31 | Module:construct | |
| 32 | File:match-method.lisp | |
| 30 | System:Chaos | |
| 31 | Module:construct | |
| 32 | File:match-method.lisp | |
| 33 | 33 | ==============================================================================|# |
| 34 | 34 | #-:chaos-debug |
| 35 | 35 | (declaim (optimize (speed 3) (safety 0) #-GCL (debug 0))) |
| 63 | 63 | ;;; |
| 64 | 64 | (defun choose-match-method (lhs cond knd) |
| 65 | 65 | (declare (type term lhs) |
| 66 | (type term cond) | |
| 67 | (type symbol knd) | |
| 68 | (values list)) | |
| 69 | (cond ((term-is-variable? lhs) *match-empty-method*) | |
| 70 | ((and (memq knd '(:id-theorem :id-ext-theory)) | |
| 71 | (theory-contains-identity (method-theory (term-head lhs)))) | |
| 72 | ;; LHS has Identity theory. | |
| 73 | (let ((meth (term-head lhs))) | |
| 74 | (declare (type method meth)) | |
| 75 | (if (method-is-associative meth) | |
| 76 | (if (is-simple-AC-match-ok? lhs cond) | |
| 77 | (if (method-is-commutative meth) | |
| 78 | *match-id-AC-dep-method* | |
| 79 | *match-id-A-dep-method*) | |
| 80 | (if (method-is-commutative meth) | |
| 81 | *match-id-AC-method* | |
| 82 | *match-id-A-method*)) | |
| 83 | *match-id-gen-method*))) | |
| 66 | (type term cond) | |
| 67 | (type symbol knd) | |
| 68 | (values list)) | |
| 69 | (let (match-method) | |
| 70 | (when *on-operator-debug* | |
| 71 | (format t "~%[choose-match-method]: kind=~s" knd) | |
| 72 | (format t "~%LHS: ") | |
| 73 | (term-print-with-sort lhs) | |
| 74 | (format t "~%CND: ") | |
| 75 | (term-print-with-sort cond)) | |
| 76 | (setq match-method | |
| 77 | (cond ((term-is-variable? lhs) *match-empty-method*) | |
| 78 | ((and (memq knd '(:id-theorem :id-ext-theory)) | |
| 79 | (theory-contains-identity (method-theory (term-head lhs)))) | |
| 80 | ;; LHS has Identity theory. | |
| 81 | (let ((meth (term-head lhs))) | |
| 82 | (declare (type method meth)) | |
| 83 | (if (method-is-associative meth) | |
| 84 | (if (is-simple-AC-match-ok? lhs cond) | |
| 85 | (if (method-is-commutative meth) | |
| 86 | *match-id-AC-dep-method* | |
| 87 | *match-id-A-dep-method*) | |
| 88 | (if (method-is-commutative meth) | |
| 89 | *match-id-AC-method* | |
| 90 | *match-id-A-method*)) | |
| 91 | *match-id-gen-method*))) | |
| 84 | 92 | |
| 85 | ;; Theory is EMPTY and simple syntactical match can be applied. | |
| 86 | ((simple-match-e-ok? lhs cond) *match-empty-method*) | |
| 93 | ;; Theory is EMPTY and simple syntactical match can be applied. | |
| 94 | ((simple-match-e-ok? lhs cond) *match-empty-method*) | |
| 87 | 95 | |
| 88 | ;; Theory has idempotency, and simple (restricted) idem matching | |
| 89 | ;; can be applied. | |
| 90 | ((match-is-idem-ok? lhs cond knd) *match-idem-method*) | |
| 96 | ;; Theory has idempotency, and simple (restricted) idem matching | |
| 97 | ;; can be applied. | |
| 98 | ((match-is-idem-ok? lhs cond knd) *match-idem-method*) | |
| 91 | 99 | |
| 92 | ;; Theory has idempotency, and simple (restricted with an extension) | |
| 93 | ;; idem match can be applied. | |
| 94 | ((match-is-idem-ext-ok? lhs cond knd) *match-idem-ext-method*) | |
| 100 | ;; Theory has idempotency, and simple (restricted with an extension) | |
| 101 | ;; idem match can be applied. | |
| 102 | ((match-is-idem-ext-ok? lhs cond knd) *match-idem-ext-method*) | |
| 95 | 103 | |
| 96 | ;; Theory has AC, and simple AC matching can be applied. | |
| 97 | ((is-simple-AC-match-ok? lhs cond) | |
| 98 | (when (null *match-dep-var*) | |
| 99 | (setq *match-dep-var* (make-new-variable 'REST *cosmos*))) | |
| 100 | *match-dep-method*) | |
| 104 | ;; Theory has AC, and simple AC matching can be applied. | |
| 105 | ((is-simple-AC-match-ok? lhs cond) | |
| 106 | (when (null *match-dep-var*) | |
| 107 | (setq *match-dep-var* (make-new-variable 'REST *cosmos*))) | |
| 108 | *match-dep-method*) | |
| 101 | 109 | |
| 102 | ;; There are no special methods available, we use general matching | |
| 103 | ;; method. | |
| 104 | (t *match-default-method*) ; the default | |
| 105 | )) | |
| 110 | ;; There are no special methods available, we use general matching | |
| 111 | ;; method. | |
| 112 | (t *match-default-method*) ; the default | |
| 113 | )) | |
| 114 | (when *on-operator-debug* | |
| 115 | (format t "~%===> ~s" match-method)) | |
| 116 | match-method)) | |
| 106 | 117 | |
| 107 | 118 | ;;; SPECIALIZED MATCHERS |
| 108 | 119 | |
| 129 | 140 | (declare (type term t1 t2)) |
| 130 | 141 | (first-match-with-theory |
| 131 | 142 | (theory-code-to-info (logandc1 #..Z. |
| 132 | (the fixnum (theory-code (method-theory | |
| 133 | (term-head t1)))))) | |
| 143 | (the fixnum (theory-code (method-theory | |
| 144 | (term-head t1)))))) | |
| 134 | 145 | t1 t2)) |
| 135 | 146 | |
| 136 | 147 | ;;; EOF |
| 0 | 0 | ;;;-*- Mode:LISP; Package:CHAOS; Base:10; Syntax:Common-lisp -*- |
| 1 | 1 | ;;; |
| 2 | ;;; Copyright (c) 2000-2014, Toshimi Sawada. All rights reserved. | |
| 2 | ;;; Copyright (c) 2000-2015, Toshimi Sawada. All rights reserved. | |
| 3 | 3 | ;;; |
| 4 | 4 | ;;; Redistribution and use in source and binary forms, with or without |
| 5 | 5 | ;;; modification, are permitted provided that the following conditions |
| 27 | 27 | ;;; |
| 28 | 28 | (in-package :chaos) |
| 29 | 29 | #|============================================================================== |
| 30 | System: Chaos | |
| 31 | Module: construct | |
| 32 | File: module.lisp | |
| 30 | System: Chaos | |
| 31 | Module: construct | |
| 32 | File: module.lisp | |
| 33 | 33 | ==============================================================================|# |
| 34 | 34 | #-:chaos-debug |
| 35 | 35 | (declaim (optimize (speed 3) (safety 0) #-GCL (debug 0))) |
| 54 | 54 | (declare (type (or null module) mod)) |
| 55 | 55 | (unless mod |
| 56 | 56 | (when *on-debug* |
| 57 | (format t "~&[create-module]: creating brand new")) | |
| 57 | (format t "~%[create-module]: creating brand new")) | |
| 58 | 58 | (setf mod (module* name))) |
| 59 | 59 | (initialize-module mod) |
| 60 | 60 | (when *on-debug* |
| 61 | 61 | (let ((*print-array* nil) (*print-circle* nil)) |
| 62 | (format t "~&[create-module]: object=~a, name= " mod) | |
| 63 | (print-chaos-object name))) | |
| 62 | (format t "~%[create-module]: object=~a, name= " mod) | |
| 63 | (print-chaos-object name))) | |
| 64 | 64 | (setf (module-creation-date mod) (get-universal-time)) |
| 65 | 65 | mod)) |
| 66 | 66 | |
| 68 | 68 | (declare (type t name)) |
| 69 | 69 | (let ((mod nil)) |
| 70 | 70 | (when *on-debug* |
| 71 | (format t "~&[!create-module]: creating brand new")) | |
| 71 | (format t "~%[!create-module]: creating brand new")) | |
| 72 | 72 | (setf mod (module* name)) |
| 73 | 73 | (initialize-module mod) |
| 74 | 74 | (when *on-debug* |
| 75 | 75 | (let ((*print-array* nil) (*print-circle* nil)) |
| 76 | (format t "~&[!create-module]: object=~a, name= " mod) | |
| 77 | (print-chaos-object name))) | |
| 76 | (format t "~%[!create-module]: object=~a, name= " mod) | |
| 77 | (print-chaos-object name))) | |
| 78 | 78 | (setf (module-creation-date mod) (get-universal-time)) |
| 79 | 79 | mod)) |
| 80 | ||
| 81 | ;;; *************** | |
| 82 | ;;; | |
| 83 | 80 | |
| 84 | 81 | ;;; other useful accessors |
| 85 | 82 | (defun module-all-methods (mod &optional (no-error-methods t)) |
| 86 | 83 | (let ((ops (module-all-operators mod)) |
| 87 | (res nil)) | |
| 84 | (res nil)) | |
| 88 | 85 | (dolist (opinfo ops) |
| 89 | 86 | (dolist (m (opinfo-methods opinfo)) |
| 90 | (when (or (not no-error-methods) | |
| 91 | (not (method-is-error-method m))) | |
| 92 | (push m res)))) | |
| 87 | (when (or (not no-error-methods) | |
| 88 | (not (method-is-error-method m))) | |
| 89 | (push m res)))) | |
| 93 | 90 | (nreverse res))) |
| 94 | 91 | |
| 95 | 92 | ;;; methods via signature |
| 99 | 96 | (format t "No context module is specified."))) |
| 100 | 97 | (with-in-module (*current-module*) |
| 101 | 98 | (let ((ops (signature$operators sig)) |
| 102 | (res nil)) | |
| 99 | (res nil)) | |
| 103 | 100 | (dolist (opinfo ops) |
| 104 | (dolist (m (opinfo-methods opinfo)) | |
| 105 | (when (or (not no-error-methods) | |
| 106 | (not (method-is-error-method m))) | |
| 107 | (push m res)))) | |
| 101 | (dolist (m (opinfo-methods opinfo)) | |
| 102 | (when (or (not no-error-methods) | |
| 103 | (not (method-is-error-method m))) | |
| 104 | (push m res)))) | |
| 108 | 105 | (nreverse res)))) |
| 109 | 106 | |
| 110 | 107 | ;;; *********************************** |
| 113 | 110 | |
| 114 | 111 | (defun compute-protected-modules (module) |
| 115 | 112 | (declare (type module module) |
| 116 | (values list)) | |
| 113 | (values list)) | |
| 117 | 114 | (setf (module-protected-modules module) |
| 118 | (do-compute-protected-modules module))) | |
| 119 | ||
| 120 | #| | |
| 115 | (do-compute-protected-modules module))) | |
| 116 | ||
| 117 | ;;; TODO | |
| 121 | 118 | (defun do-compute-protected-modules (module) |
| 122 | 119 | (declare (type module module) |
| 123 | (values list)) | |
| 124 | (let ((res nil)) | |
| 125 | (dolist (mp (module-all-submodules module) res) | |
| 126 | (if (eq ':protecting (cdr mp)) | |
| 127 | (pushnew (car mp) res :test #'eq) | |
| 128 | (if (member (car mp) res) | |
| 129 | (setq res | |
| 130 | (delete (car mp) res))))))) | |
| 131 | |# | |
| 132 | ||
| 133 | (defun do-compute-protected-modules (module) | |
| 134 | (declare (type module module) | |
| 135 | (values list)) | |
| 120 | (values list)) | |
| 136 | 121 | module |
| 137 | 122 | nil) |
| 138 | 123 | |
| 139 | 124 | ;;; |
| 140 | 125 | ;;; AUTOMATIC DEPENDENCY CHECK --> RECONSTRUCTION |
| 141 | 126 | ;;; |
| 142 | ;;; (defvar *on-change-debug* nil) | |
| 143 | ||
| 144 | 127 | (defun reconstruct-module-if-need (module) |
| 145 | 128 | (declare (type module module) |
| 146 | (values module)) | |
| 129 | (values module)) | |
| 147 | 130 | (cond ((module-is-inconsistent module) |
| 148 | (reconstruct-module module) | |
| 149 | module) | |
| 150 | (t module))) | |
| 131 | (reconstruct-module module) | |
| 132 | module) | |
| 133 | (t module))) | |
| 151 | 134 | |
| 152 | 135 | (defun reconstruct-module (module) |
| 153 | 136 | (declare (type module module) |
| 154 | (values t)) | |
| 137 | (values t)) | |
| 155 | 138 | ;; reconstruct module in a bottom up manner |
| 156 | 139 | (when *on-change-debug* |
| 157 | (format t "~&** reconstructing module") | |
| 140 | (format t "~%** reconstructing module") | |
| 158 | 141 | (prin1 module)) |
| 159 | 142 | (dag-dfs (module-dag module) |
| 160 | #'(lambda (node) | |
| 161 | (let* ((datum (dag-node-datum node)) | |
| 162 | (mode (cdr datum)) | |
| 163 | (mod (car datum))) | |
| 164 | (when (and (module-is-inconsistent mod) | |
| 165 | (not (eq mode :modmorph))) | |
| 166 | (let ((decl (module-decl-form mod))) | |
| 167 | (if decl | |
| 168 | (eval-ast decl) | |
| 169 | (with-output-chaos-warning () | |
| 170 | (princ "Specified module is inconsistent due to some changes in its submodule(s).") | |
| 171 | (print-next) | |
| 172 | (princ "The system could not reconstruct it in automatic: ") | |
| 173 | (if (module-name mod) | |
| 174 | (prin1 mod)) | |
| 175 | (print-next) | |
| 176 | (princ "This can happens when you redefine modules.") | |
| 177 | (print-next) | |
| 178 | (princ "Please redfine it from the scratch,") | |
| 179 | (print-next) | |
| 180 | (princ "if you are loading some file, RE-LOAD it again please.") | |
| 181 | (print-next) | |
| 182 | (princ "(If the switch `auto reconstrut' is on, please reset it to `off'.)") | |
| 183 | (chaos-error 'reconstruct-failure))))))))) | |
| 143 | #'(lambda (node) | |
| 144 | (let* ((datum (dag-node-datum node)) | |
| 145 | (mode (cdr datum)) | |
| 146 | (mod (car datum))) | |
| 147 | (when (and (module-is-inconsistent mod) | |
| 148 | (not (eq mode :modmorph))) | |
| 149 | (let ((decl (module-decl-form mod))) | |
| 150 | (if decl | |
| 151 | (eval-ast decl) | |
| 152 | (with-output-chaos-warning () | |
| 153 | (princ "Specified module is inconsistent due to some changes in its submodule(s).") | |
| 154 | (print-next) | |
| 155 | (princ "The system could not reconstruct it in automatic: ") | |
| 156 | (if (module-name mod) | |
| 157 | (prin1 mod)) | |
| 158 | (print-next) | |
| 159 | (princ "This can happens when you redefine modules.") | |
| 160 | (print-next) | |
| 161 | (princ "Please redfine it from the scratch,") | |
| 162 | (print-next) | |
| 163 | (princ "if you are loading some file, RE-LOAD it again please.") | |
| 164 | (print-next) | |
| 165 | (princ "(If the switch `auto reconstrut' is on, please reset it to `off'.)") | |
| 166 | (chaos-error 'reconstruct-failure))))))))) | |
| 184 | 167 | |
| 185 | 168 | ;;; |
| 186 | 169 | ;;; PREPARE-FOR-PARSING |
| 192 | 175 | |
| 193 | 176 | (defun module-indirect-submodules (module) |
| 194 | 177 | (let ((dmods (module-direct-submodules module)) |
| 195 | (res (cons nil nil))) | |
| 178 | (res (cons nil nil))) | |
| 196 | 179 | (dolist (dmod dmods) |
| 197 | 180 | (unless (or (eq (cdr dmod) :modmorph) |
| 198 | (member dmod (car res) :test #'equal) | |
| 199 | (module-is-parameter-theory (car dmod))) | |
| 200 | (gather-submodules (car dmod) res))) | |
| 181 | (member dmod (car res) :test #'equal) | |
| 182 | (module-is-parameter-theory (car dmod))) | |
| 183 | (gather-submodules (car dmod) res))) | |
| 201 | 184 | (car res))) |
| 202 | 185 | |
| 203 | 186 | (defun prepare-for-parsing (module &optional force no-error-sort) |
| 204 | 187 | (declare (type module module) |
| 205 | (type (or null t) force no-error-sort) | |
| 206 | (values t)) | |
| 188 | (type (or null t) force no-error-sort) | |
| 189 | (values t)) | |
| 207 | 190 | (let ((*on-preparing-for-parsing* t)) |
| 208 | 191 | (declare (special *on-preparing-for-parsing*)) |
| 209 | 192 | (when *auto-reconstruct* |
| 210 | 193 | (reconstruct-module-if-need module)) |
| 211 | 194 | (with-in-module (module) |
| 212 | 195 | (when (or (need-parsing-preparation module) force) |
| 213 | (print-in-progress "_") | |
| 214 | (check-submodules module) | |
| 215 | ;; | |
| 216 | (let ((als (module-alias module))) | |
| 217 | (dolist (sub (module-all-submodules module)) | |
| 218 | (unless (or (assoc sub als) | |
| 219 | (not (modexp-is-simple-name (module-name (car sub))))) | |
| 220 | (symbol-table-add (module-symbol-table module) | |
| 221 | (module-name (car sub)) | |
| 222 | (car sub))))) | |
| 223 | ;; regularity check | |
| 224 | (regularize-signature-internal module) | |
| 225 | ;; implicit check regularity | |
| 226 | (setf (module-is-regular module) | |
| 227 | (check-regularity module t)) | |
| 228 | ;; | |
| 229 | (when (and *check-regularity* | |
| 230 | (not (module-is-theory module))) | |
| 231 | (if (not (module-is-regular module)) | |
| 232 | (with-output-chaos-warning () | |
| 233 | (princ "signature of module ") | |
| 234 | (print-mod-name module *standard-output* t) | |
| 235 | (princ " is not regular. ") | |
| 236 | (print-next) | |
| 237 | (princ "try `check regularity' command for details.") | |
| 238 | (print-next)))) | |
| 239 | ;; | |
| 240 | (unless no-error-sort | |
| 241 | (let ((oerrs (generate-err-sorts (module-sort-order module)))) | |
| 242 | (declare (ignore oerrs)) | |
| 243 | (delete-error-operators-in module))) | |
| 244 | ;; setup operators for various semantic relations. | |
| 245 | (setup-sem-relations-in module) | |
| 246 | ;; (setup-if-then-else-in module) | |
| 247 | (declare-sort-id-constants module) | |
| 248 | (make-operator-clusters-in module) | |
| 249 | ;; (declare-sort-memb-predicates module) | |
| 250 | (setup-error-operators-in module) | |
| 251 | (setup-operators-in module) | |
| 252 | ;; do postponed variable declarations of error sorts | |
| 253 | (declare-error-variables-in module) | |
| 254 | ;; sensible check | |
| 255 | (when (and *check-sensibleness* | |
| 256 | (not (module-is-theory module))) | |
| 257 | (check-sensible module t)) ; report on | |
| 258 | ;; coherency check | |
| 259 | (when (and *check-rwl-coherency* | |
| 260 | (not (module-is-theory module))) | |
| 261 | (check-rwl-coherency module t)) | |
| 262 | ||
| 263 | ;; for simple-parser. | |
| 264 | ;; (check-polimorphic-overloading-in module) | |
| 265 | ;; (propagate-attributes module) | |
| 266 | (set-operator-syntactic-properties module) | |
| 267 | (update-parse-information module) | |
| 268 | ;; | |
| 269 | (dolist (hook-fun *prepare-for-parse-hook*) | |
| 270 | (funcall hook-fun module)) | |
| 271 | ;; | |
| 272 | ) | |
| 196 | (print-in-progress "_") | |
| 197 | (check-submodules module) | |
| 198 | ;; | |
| 199 | (let ((als (module-alias module))) | |
| 200 | (dolist (sub (module-all-submodules module)) | |
| 201 | (unless (or (assoc sub als) | |
| 202 | (not (modexp-is-simple-name (module-name (car sub))))) | |
| 203 | (symbol-table-add (module-symbol-table module) | |
| 204 | (module-name (car sub)) | |
| 205 | (car sub))))) | |
| 206 | ;; regularity check | |
| 207 | (regularize-signature-internal module) | |
| 208 | ;; implicit check regularity | |
| 209 | (setf (module-is-regular module) | |
| 210 | (check-regularity module t)) | |
| 211 | ;; | |
| 212 | (when (and *check-regularity* | |
| 213 | (not (module-is-theory module))) | |
| 214 | (if (not (module-is-regular module)) | |
| 215 | (with-output-chaos-warning () | |
| 216 | (princ "signature of module ") | |
| 217 | (print-mod-name module *standard-output* t) | |
| 218 | (princ " is not regular. ") | |
| 219 | (print-next) | |
| 220 | (princ "try `check regularity' command for details.") | |
| 221 | (print-next)))) | |
| 222 | ;; | |
| 223 | (unless no-error-sort | |
| 224 | (let ((oerrs (generate-err-sorts (module-sort-order module)))) | |
| 225 | (declare (ignore oerrs)) | |
| 226 | (delete-error-operators-in module))) | |
| 227 | ;; setup operators for various semantic relations. | |
| 228 | (setup-sem-relations-in module) | |
| 229 | ;; (setup-if-then-else-in module) | |
| 230 | (declare-sort-id-constants module) | |
| 231 | (make-operator-clusters-in module) | |
| 232 | ;; (declare-sort-memb-predicates module) | |
| 233 | (setup-error-operators-in module) | |
| 234 | (setup-operators-in module) | |
| 235 | ;; do postponed variable declarations of error sorts | |
| 236 | (declare-error-variables-in module) | |
| 237 | ;; sensible check | |
| 238 | (when (and *check-sensibleness* | |
| 239 | (not (module-is-theory module))) | |
| 240 | (check-sensible module t)) ; report on | |
| 241 | ;; coherency check | |
| 242 | (when (and *check-rwl-coherency* | |
| 243 | (not (module-is-theory module))) | |
| 244 | (check-rwl-coherency module t)) | |
| 245 | ||
| 246 | ;; for simple-parser. | |
| 247 | ;; (check-polimorphic-overloading-in module) | |
| 248 | ;; (propagate-attributes module) | |
| 249 | (set-operator-syntactic-properties module) | |
| 250 | (update-parse-information module) | |
| 251 | ;; | |
| 252 | (dolist (hook-fun *prepare-for-parse-hook*) | |
| 253 | (funcall hook-fun module)) | |
| 254 | ;; | |
| 255 | ) | |
| 273 | 256 | (mark-module-ready-for-parsing module) |
| 274 | 257 | ;; that's end. |
| 275 | 258 | module))) |
| 279 | 262 | ;;; |
| 280 | 263 | (defvar *do-=*=-proof* t) |
| 281 | 264 | |
| 282 | #|| | |
| 283 | 265 | (defun compile-module (module &optional (force nil)) |
| 284 | 266 | (declare (type module module) |
| 285 | (type (or null t) force) | |
| 286 | (values t)) | |
| 287 | (prepare-for-parsing module force) | |
| 288 | ;; evaluate postponed psort decl. | |
| 289 | (when (module-psort-declaration module) | |
| 290 | (eval-psort-declaration (module-psort-declaration module) module)) | |
| 291 | ;; | |
| 292 | (when (or force (need-rewriting-preparation module)) | |
| 293 | (compile-module-internal module) | |
| 294 | (when *do-=*=-proof* | |
| 295 | (try-beh-proof-in module)) | |
| 296 | ) | |
| 297 | (when (need-rewriting-preparation module) | |
| 298 | (with-in-module (module) | |
| 299 | (generate-rewrite-rules module) | |
| 300 | (mapc #'(lambda (opinfo) | |
| 301 | (compute-rew-strategy module opinfo) | |
| 302 | (fix-strategy-and-rules module opinfo)) | |
| 303 | (module-all-operators module)) | |
| 304 | (when (and *check-compatibility* | |
| 305 | (not (module-is-theory module))) | |
| 306 | (when (check-compatibility module) | |
| 307 | (with-output-chaos-warning () | |
| 308 | (princ "TRS of module ") | |
| 309 | (print-mod-name module) | |
| 310 | (princ "is not compatible.") | |
| 311 | (print-next) | |
| 312 | (princ "please try `check compatible' command for details.")))) | |
| 313 | ;; | |
| 314 | (mark-module-ready-for-rewriting module)))) | |
| 315 | ||# | |
| 316 | ||
| 317 | (defun compile-module (module &optional (force nil)) | |
| 318 | (declare (type module module) | |
| 319 | (type (or null t) force) | |
| 320 | (values t)) | |
| 267 | (type (or null t) force) | |
| 268 | (values t)) | |
| 321 | 269 | (prepare-for-parsing module force) |
| 322 | 270 | ;; evaluate postponed psort decl. |
| 323 | 271 | (when (module-psort-declaration module) |
| 328 | 276 | (when *do-=*=-proof* |
| 329 | 277 | (try-beh-proof-in module)) |
| 330 | 278 | (when (and *check-compatibility* |
| 331 | (not (module-is-theory module))) | |
| 279 | (not (module-is-theory module))) | |
| 332 | 280 | (when (check-compatibility module) |
| 333 | (with-output-chaos-warning () | |
| 334 | (princ "TRS of module ") | |
| 335 | (print-mod-name module *standard-output* t) | |
| 336 | (princ " is not compatible.") | |
| 337 | (print-next) | |
| 338 | (princ "please try `check compatible' command for details."))))) | |
| 281 | (with-output-chaos-warning () | |
| 282 | (princ "TRS of module ") | |
| 283 | (print-mod-name module *standard-output* t) | |
| 284 | (princ " is not compatible.") | |
| 285 | (print-next) | |
| 286 | (princ "please try `check compatible' command for details."))))) | |
| 339 | 287 | module) |
| 340 | 288 | |
| 341 | 289 | (defun !setup-reduction (mod) |
| 342 | (declare (type module mod) | |
| 343 | (values t)) | |
| 344 | (compile-module mod) | |
| 345 | ) | |
| 290 | (declare (type module mod)) | |
| 291 | (compile-module mod)) | |
| 346 | 292 | |
| 347 | 293 | (defun final-setup (module) |
| 348 | 294 | (declare (type module module) |
| 349 | (values t)) | |
| 295 | (values t)) | |
| 350 | 296 | (compile-module module)) |
| 351 | 297 | |
| 352 | 298 | (defun compile-module-internal (module) |
| 353 | 299 | (declare (type module module) |
| 354 | (values t)) | |
| 300 | (values t)) | |
| 355 | 301 | (with-in-module (module) |
| 356 | 302 | (print-in-progress "*") |
| 357 | 303 | ;; add axioms in paramters as theorems if any. |
| 358 | 304 | ;; (add-parameter-theorem module) |
| 359 | 305 | ;; add operator theory axioms |
| 360 | 306 | (unless (and *open-module* |
| 361 | (equal "%" (get-module-print-name module))) | |
| 307 | (equal "%" (get-module-print-name module))) | |
| 362 | 308 | (dolist (oinfo (module-all-operators module)) |
| 363 | (add-operator-theory-axioms module oinfo))) | |
| 309 | (add-operator-theory-axioms module oinfo))) | |
| 364 | 310 | ;; |
| 365 | 311 | (add-identity-completions module) |
| 366 | 312 | ;; add equations for behavioural congruence relation. |
| 372 | 318 | ;; genrate rewrite rules |
| 373 | 319 | (generate-rewrite-rules module) |
| 374 | 320 | (mapc #'(lambda (opinfo) |
| 375 | (compute-rew-strategy module opinfo) | |
| 376 | (fix-strategy-and-rules module opinfo)) | |
| 377 | (module-all-operators module)) | |
| 321 | (compute-rew-strategy module opinfo) | |
| 322 | (fix-strategy-and-rules module opinfo)) | |
| 323 | (module-all-operators module)) | |
| 378 | 324 | ;; TODO. |
| 379 | 325 | (fix-rewrite-rules module) |
| 380 | 326 | (check-behavioural-rules module) |
| 383 | 329 | (check-operator-congruency module) |
| 384 | 330 | ;; |
| 385 | 331 | (let* ((*module-all-rules-every* t) |
| 386 | (axs (get-module-axioms module))) | |
| 332 | (axs (get-module-axioms module))) | |
| 387 | 333 | ;; (format t "~%# axioms=~d" (length axs)) |
| 388 | 334 | (dolist (ax axs) |
| 389 | (let ((labels (axiom-labels ax))) | |
| 390 | (dolist (lab labels) | |
| 391 | ;; (format t " ~a" lab) | |
| 392 | (symbol-table-add (module-symbol-table module) | |
| 393 | lab | |
| 394 | ax))))) | |
| 335 | (let ((labels (axiom-labels ax))) | |
| 336 | (dolist (lab labels) | |
| 337 | ;; (format t " ~a" lab) | |
| 338 | (symbol-table-add (module-symbol-table module) | |
| 339 | lab | |
| 340 | ax))))) | |
| 395 | 341 | ;; set status. |
| 396 | (mark-module-ready-for-rewriting module) | |
| 397 | ;; | |
| 398 | #|| | |
| 399 | (when (featurep :bigpink) | |
| 400 | (create-module-psystem module)) | |
| 401 | ||# | |
| 402 | )) | |
| 342 | (mark-module-ready-for-rewriting module))) | |
| 403 | 343 | |
| 404 | 344 | (defun check-behavioural-rules (module) |
| 405 | 345 | (declare (type module module) |
| 406 | (values (or null t))) | |
| 346 | (values (or null t))) | |
| 407 | 347 | (setf (module-has-behavioural-axioms module) nil) |
| 408 | 348 | (dolist (rule (module-all-rules module)) |
| 409 | 349 | (when (axiom-is-behavioural rule) |
| 412 | 352 | |
| 413 | 353 | (defun fix-error-method-terms (module &optional clean) |
| 414 | 354 | (declare (type module module) |
| 415 | (type (or null t) clean) | |
| 416 | (values t)) | |
| 417 | ;; (check-module-rules module) | |
| 355 | (type (or null t) clean) | |
| 356 | (values t)) | |
| 357 | (check-module-rules module) | |
| 418 | 358 | (when (module-terms-to-be-fixed module) |
| 419 | 359 | (with-in-module (module) |
| 420 | 360 | (let ((name (module-name module)) |
| 421 | (op-map nil) | |
| 422 | (sort-map nil)) | |
| 423 | (cond ((int-instantiation-p name) | |
| 424 | (let ((modmorph (views-to-modmorph | |
| 425 | (int-instantiation-module name) | |
| 426 | (int-instantiation-args name)))) | |
| 427 | (setq op-map (modmorph-op modmorph)) | |
| 428 | (setq sort-map (modmorph-sort modmorph)))) | |
| 429 | ((int-rename-p name) | |
| 430 | (setq op-map (int-rename-op-maps name)) | |
| 431 | (setq sort-map (int-rename-sort-maps name)))) | |
| 432 | ;; | |
| 433 | (dolist (term-pair (module-terms-to-be-fixed module)) | |
| 434 | (replace-error-method module (cdr term-pair) op-map sort-map)) | |
| 435 | (dolist (rule-pair (module-axioms-to-be-fixed module)) | |
| 436 | (compute-rule-method (cdr rule-pair))) | |
| 437 | (when clean | |
| 438 | (setf (module-terms-to-be-fixed module) nil | |
| 439 | (module-axioms-to-be-fixed module) nil)) | |
| 440 | ;; | |
| 441 | )))) | |
| 361 | (op-map nil) | |
| 362 | (sort-map nil)) | |
| 363 | (cond ((int-instantiation-p name) | |
| 364 | (let ((modmorph (views-to-modmorph | |
| 365 | (int-instantiation-module name) | |
| 366 | (int-instantiation-args name)))) | |
| 367 | (setq op-map (modmorph-op modmorph)) | |
| 368 | (setq sort-map (modmorph-sort modmorph)))) | |
| 369 | ((int-rename-p name) | |
| 370 | (setq op-map (int-rename-op-maps name)) | |
| 371 | (setq sort-map (int-rename-sort-maps name)))) | |
| 372 | ;; | |
| 373 | (dolist (term-pair (module-terms-to-be-fixed module)) | |
| 374 | (replace-error-method module (cdr term-pair) op-map sort-map)) | |
| 375 | (dolist (rule-pair (module-axioms-to-be-fixed module)) | |
| 376 | (compute-rule-method (cdr rule-pair))) | |
| 377 | (when clean | |
| 378 | (setf (module-terms-to-be-fixed module) nil | |
| 379 | (module-axioms-to-be-fixed module) nil)))))) | |
| 442 | 380 | |
| 443 | 381 | (defun fix-rewrite-rules (module) |
| 444 | 382 | (declare (type module module) |
| 445 | (values t)) | |
| 383 | (values t)) | |
| 446 | 384 | (let ((res nil) |
| 447 | (tobe-fixed (module-axioms-to-be-fixed module))) | |
| 385 | (tobe-fixed (module-axioms-to-be-fixed module))) | |
| 448 | 386 | (dolist (rl (module-rewrite-rules module)) |
| 449 | 387 | (push (or (cdr (assq rl tobe-fixed)) |
| 450 | rl) | |
| 451 | res)) | |
| 388 | rl) | |
| 389 | res)) | |
| 452 | 390 | (setf (module-rewrite-rules module) |
| 453 | (nreverse res)))) | |
| 391 | (nreverse res)))) | |
| 454 | 392 | |
| 455 | 393 | (defun check-module-rules (module) |
| 456 | 394 | (declare (type module module) |
| 457 | (values t)) | |
| 395 | (values t)) | |
| 458 | 396 | (setf (module-terms-to-be-fixed module) nil) |
| 459 | 397 | (setf (module-axioms-to-be-fixed module) nil) |
| 460 | 398 | (dolist (rule (module-all-rules module)) |
| 462 | 400 | |
| 463 | 401 | (defun module-error-check (module) |
| 464 | 402 | (declare (type module module) |
| 465 | (values t)) | |
| 403 | (values t)) | |
| 466 | 404 | (with-in-module (module) |
| 467 | 405 | ;; check sort cycles |
| 468 | 406 | (maphash #'(lambda (s sl) |
| 469 | (when (memq s (_subsorts sl)) | |
| 470 | (with-output-chaos-warning () | |
| 471 | (princ "!! cycle in sort structure !!") | |
| 472 | (print-next) | |
| 473 | (format t "the sort ") | |
| 474 | (print-chaos-object s) | |
| 475 | (princ " is in a cycle.")))) | |
| 476 | *current-sort-order*) | |
| 477 | ||
| 478 | #|| | |
| 479 | ;; checks theory is proper for operators. not complete. | |
| 480 | (dolist (op-info (module-all-operators module)) | |
| 481 | (dolist (meth (opinfo-methods op-info)) | |
| 482 | (let ((thy (method-theory meth)) | |
| 483 | (coarity (method-coarity meth)) | |
| 484 | (arity (method-arity meth))) | |
| 485 | (when (theory-contains-associativity thy) | |
| 486 | (unless (and (= (length arity) 2) ; redundant ... | |
| 487 | (sort<= coarity (car arity)) | |
| 488 | (sort<= coarity (cadr arity))) | |
| 489 | (with-output-chaos-warning () | |
| 490 | (princ "associative operator ") | |
| 491 | (print-chaos-object meth) | |
| 492 | (princ " has bad rank!")))) | |
| 493 | ||
| 494 | ;; the following is redundant, more strong restrictive check is | |
| 495 | ;; done elsewhere. | |
| 496 | ||
| 497 | (when (theory-contains-commutativity thy) | |
| 498 | (unless (and (= (length arity) 2) | |
| 499 | (is-in-same-connected-component* (car arity) (cadr arity))) | |
| 500 | (with-output-chaos-warning () | |
| 501 | (princ "commutative operator ") | |
| 502 | (print-chaos-object meth) | |
| 503 | (princ " has bad rank!")))) | |
| 504 | ||
| 505 | ;; identity, ?? | |
| 506 | ||
| 507 | (when (theory-contains-identity thy) | |
| 508 | (unless (= (length arity) 2) | |
| 509 | (with-output-chaos-warning () | |
| 510 | (princ "operator with identity ") | |
| 511 | (print-chaos-object meth) | |
| 512 | (princ " has bad rank!"))))))) | |
| 513 | ||# | |
| 514 | )) | |
| 407 | (when (memq s (_subsorts sl)) | |
| 408 | (with-output-chaos-warning () | |
| 409 | (princ "!! cycle in sort structure !!") | |
| 410 | (print-next) | |
| 411 | (format t "the sort ") | |
| 412 | (print-chaos-object s) | |
| 413 | (princ " is in a cycle.")))) | |
| 414 | *current-sort-order*))) | |
| 515 | 415 | |
| 516 | 416 | ;; *todo* must re-import iff necessary. |
| 517 | 417 | ;; |
| 518 | 418 | (defun check-submodules (module) |
| 519 | 419 | (declare (type module module) |
| 520 | (values t)) | |
| 420 | (values t)) | |
| 521 | 421 | (dolist (mod (module-direct-submodules module)) |
| 522 | 422 | (compile-module (car mod)))) |
| 523 | 423 | |
| 525 | 425 | ;;; |
| 526 | 426 | (defun add-parameter-theorem (mod) |
| 527 | 427 | (declare (type module mod) |
| 528 | (values t)) | |
| 428 | (values t)) | |
| 529 | 429 | (let ((params (get-module-imported-parameters mod))) |
| 530 | 430 | (declare (type list params)) |
| 531 | 431 | (dolist (param params) |
| 532 | 432 | (let ((pmod (parameter-theory-module param))) |
| 533 | (dolist (ax (module-equations pmod)) | |
| 534 | (pushnew (check-axiom-error-method mod ax) | |
| 535 | (module-theorems mod) :test #'eq)) | |
| 536 | (dolist (rl (module-rules pmod)) | |
| 537 | (pushnew (check-axiom-error-method mod rl) | |
| 538 | (module-theorems mod) :test #'eq)) | |
| 539 | )))) | |
| 433 | (dolist (ax (module-equations pmod)) | |
| 434 | (pushnew (check-axiom-error-method mod ax) | |
| 435 | (module-theorems mod) :test #'eq)) | |
| 436 | (dolist (rl (module-rules pmod)) | |
| 437 | (pushnew (check-axiom-error-method mod rl) | |
| 438 | (module-theorems mod) :test #'eq)))))) | |
| 540 | 439 | |
| 541 | 440 | ;;;----------------------------------------------------------------------------- |
| 542 | 441 | ;;; DELETING MODULES/VIEWS |
| 548 | 447 | ;;; |
| 549 | 448 | (defun modexp-is-submodule-of (x y) |
| 550 | 449 | (declare (type t x y) |
| 551 | (values (or null t))) | |
| 450 | (values (or null t))) | |
| 552 | 451 | (if (not (module-p y)) |
| 553 | 452 | (and (view-p y) |
| 554 | (or ;; we also lookup in local submodules.. | |
| 555 | ;; | |
| 556 | (modexp-is-submodule-of x (eval-modexp (view-src y) t)) | |
| 557 | (modexp-is-submodule-of x (eval-modexp (view-target y) t)))) | |
| 453 | (or ;; we also lookup in local submodules.. | |
| 454 | ;; | |
| 455 | (modexp-is-submodule-of x (eval-modexp (view-src y) t)) | |
| 456 | (modexp-is-submodule-of x (eval-modexp (view-target y) t)))) | |
| 558 | 457 | (or (assq x (module-submodules y)) |
| 559 | (let ((nm (module-name y))) | |
| 560 | (when (chaos-ast? nm) | |
| 561 | (cond ((%is-instantiation nm) (eq x (%instantiation-module nm))) | |
| 562 | ((%is-rename nm) (eq x (%rename-module nm))) | |
| 563 | (t nil)))) | |
| 564 | (some #'(lambda (sm) | |
| 565 | (or (eq x (car sm)) | |
| 566 | (modexp-is-submodule-of x (car sm)))) | |
| 567 | (module-submodules y)) | |
| 568 | ))) | |
| 569 | ||
| 570 | ;;; | |
| 571 | ;;; | |
| 572 | ;;; | |
| 458 | (let ((nm (module-name y))) | |
| 459 | (when (chaos-ast? nm) | |
| 460 | (cond ((%is-instantiation nm) (eq x (%instantiation-module nm))) | |
| 461 | ((%is-rename nm) (eq x (%rename-module nm))) | |
| 462 | (t nil)))) | |
| 463 | (some #'(lambda (sm) | |
| 464 | (or (eq x (car sm)) | |
| 465 | (modexp-is-submodule-of x (car sm)))) | |
| 466 | (module-submodules y))))) | |
| 573 | 467 | |
| 574 | 468 | (defun propagate-module-change (x) |
| 575 | 469 | (declare (type module x) |
| 576 | (values t)) | |
| 470 | (values t)) | |
| 577 | 471 | (mark-module-as-inconsistent x) |
| 578 | 472 | (when (null (module-name x)) |
| 579 | 473 | (return-from propagate-module-change nil)) |
| 580 | 474 | (let ((exobj (object-all-exporting-objects x))) |
| 581 | 475 | (clean-up-sub-objects exobj)) |
| 582 | 476 | (delete-parameters x) |
| 583 | (delete-object-from-assoc-table *modexp-eval-table* x) | |
| 584 | ) | |
| 477 | (delete-object-from-assoc-table *modexp-eval-table* x)) | |
| 585 | 478 | |
| 586 | 479 | (defun delete-parameters (x) |
| 587 | 480 | (declare (type module x) |
| 588 | (values t)) | |
| 481 | (values t)) | |
| 589 | 482 | (when *on-change-debug* |
| 590 | 483 | (format t "~%** start deleting parameters ~a of module ~a" |
| 591 | (module-parameters x) | |
| 592 | x)) | |
| 484 | (module-parameters x) | |
| 485 | x)) | |
| 593 | 486 | (when (null (module-name x)) |
| 594 | 487 | (return-from delete-parameters nil)) |
| 595 | 488 | ;; |
| 601 | 494 | (delete-object-from-assoc-table *modules-so-far-table* pth) |
| 602 | 495 | (delete-object-from-assoc-table *modexp-local-table* pth) |
| 603 | 496 | (delete-object-from-assoc-table *modexp-normalized-table* |
| 604 | (module-name pth)) | |
| 497 | (module-name pth)) | |
| 605 | 498 | (let ((subs (object-all-exporting-objects pth))) |
| 606 | (clean-up-module pth) | |
| 607 | (clean-up-sub-objects subs))))) | |
| 499 | (clean-up-module pth) | |
| 500 | (clean-up-sub-objects subs))))) | |
| 608 | 501 | |
| 609 | 502 | (defun propagate-view-change (x) |
| 610 | 503 | (declare (type view-struct x) |
| 611 | (values t)) | |
| 504 | (values t)) | |
| 612 | 505 | (mark-object-as-inconsistent x) |
| 613 | 506 | (when (null (view-name x)) |
| 614 | 507 | (return-from propagate-view-change nil)) |
| 617 | 510 | |
| 618 | 511 | (defun clean-up-sub-objects (subs) |
| 619 | 512 | (declare (type list subs) |
| 620 | (values t)) | |
| 513 | (values t)) | |
| 621 | 514 | (dolist (sub subs) |
| 622 | 515 | (let ((object (car sub))) |
| 623 | 516 | (unless (eq (cdr sub) :using) |
| 624 | (unless (object-is-inconsistent object) | |
| 625 | (cond ((module-p object) | |
| 626 | (if (and (module-decl-form object) | |
| 627 | (modexp-is-simple-name (module-name object))) | |
| 628 | (progn (mark-object-as-inconsistent object) | |
| 629 | (delete-parameters object)) | |
| 630 | (delete-module object))) | |
| 631 | ((view-p object) | |
| 632 | (if (view-decl-form object) | |
| 633 | (mark-object-as-inconsistent object) | |
| 634 | (delete-view object))) | |
| 635 | (t (with-output-panic-message () | |
| 636 | (format t "unknown type of exporting object : ") | |
| 637 | (prin1 object) | |
| 638 | (chaos-error 'panic)))) | |
| 639 | ))))) | |
| 517 | (unless (object-is-inconsistent object) | |
| 518 | (cond ((module-p object) | |
| 519 | (if (and (module-decl-form object) | |
| 520 | (modexp-is-simple-name (module-name object))) | |
| 521 | (progn (mark-object-as-inconsistent object) | |
| 522 | (delete-parameters object)) | |
| 523 | (delete-module object))) | |
| 524 | ((view-p object) | |
| 525 | (if (view-decl-form object) | |
| 526 | (mark-object-as-inconsistent object) | |
| 527 | (delete-view object))) | |
| 528 | (t (with-output-panic-message () | |
| 529 | (format t "unknown type of exporting object : ") | |
| 530 | (prin1 object) | |
| 531 | (chaos-error 'panic))))))))) | |
| 640 | 532 | |
| 641 | 533 | (defun delete-module (x) |
| 642 | 534 | (declare (type module x) |
| 643 | (values t)) | |
| 535 | (values t)) | |
| 644 | 536 | (when *on-change-debug* |
| 645 | 537 | (format t "~%!! deleting module ") |
| 646 | 538 | (print x)) |
| 649 | 541 | (delete-object-from-assoc-table *modules-so-far-table* x) |
| 650 | 542 | (delete-object-from-assoc-table *modexp-eval-table* x) |
| 651 | 543 | (delete-parameters x) |
| 652 | (clean-up-module x) | |
| 653 | ) | |
| 544 | (clean-up-module x)) | |
| 654 | 545 | |
| 655 | 546 | (defun delete-view (x) |
| 656 | 547 | (declare (type view-struct x) |
| 657 | (values t)) | |
| 548 | (values t)) | |
| 658 | 549 | (when (null (view-name x)) |
| 659 | 550 | (return-from delete-view nil)) |
| 660 | 551 | (delete-object-from-assoc-table *modexp-view-table* x) |
| 661 | (clean-up-view x) | |
| 662 | ) | |
| 552 | (clean-up-view x)) | |
| 663 | 553 | |
| 664 | 554 | ;;; EOF |
| 0 | 0 | ;;;-*-Mode:LISP; Package: CHAOS; Base:10; Syntax:Common-lisp -*- |
| 1 | 1 | ;;; |
| 2 | ;;; Copyright (c) 2000-2014, Toshimi Sawada. All rights reserved. | |
| 2 | ;;; Copyright (c) 2000-2015, Toshimi Sawada. All rights reserved. | |
| 3 | 3 | ;;; |
| 4 | 4 | ;;; Redistribution and use in source and binary forms, with or without |
| 5 | 5 | ;;; modification, are permitted provided that the following conditions |
| 27 | 27 | ;;; |
| 28 | 28 | (in-package :chaos) |
| 29 | 29 | #|============================================================================= |
| 30 | System:CHAOS | |
| 31 | Module:construct | |
| 32 | File:operator.lisp | |
| 30 | System:CHAOS | |
| 31 | Module:construct | |
| 32 | File:operator.lisp | |
| 33 | 33 | =============================================================================|# |
| 34 | 34 | #-:chaos-debug |
| 35 | 35 | (declaim (optimize (speed 3) (safety 0) #-GCL (debug 0))) |
| 36 | 36 | #+:chaos-debug |
| 37 | 37 | (declaim (optimize (speed 1) (safety 3) #-GCL (debug 3))) |
| 38 | 38 | |
| 39 | ;;; (defvar *on-operator-debug* nil) | |
| 40 | 39 | (defun on-debug-operator () |
| 41 | 40 | (setq *on-operator-debug* t)) |
| 42 | 41 | (defun off-debug-operator () |
| 43 | 42 | (setq *on-operator-debug* nil)) |
| 44 | 43 | |
| 45 | ;;; *TODO, immediately* | |
| 44 | ;;; *TODO* | |
| 46 | 45 | ;;; syntax of an operator can be regular-expression. |
| 47 | 46 | |
| 48 | 47 | ;;; === DESCRIPTION ============================================================ |
| 49 | 48 | ;;; All of the procedures on operator, method. |
| 50 | 49 | |
| 51 | 50 | ;;;============================================================================= |
| 52 | ;;; OPERATOR | |
| 51 | ;;; OPERATOR | |
| 53 | 52 | ;;;============================================================================= |
| 54 | 53 | |
| 55 | 54 | ;;; ***************************** |
| 71 | 70 | #-gcl |
| 72 | 71 | (defun strategy-is-li? (strat len) |
| 73 | 72 | (declare (type list strat) |
| 74 | (type fixnum len) | |
| 75 | (values (or null t))) | |
| 73 | (type fixnum len) | |
| 74 | (values (or null t))) | |
| 76 | 75 | (equal strat (the-default-strategy len))) |
| 77 | 76 | |
| 78 | 77 | #+gcl |
| 86 | 85 | ;;; |
| 87 | 86 | (defun declare-operator-strategy (op strat) |
| 88 | 87 | (declare (type operator op) |
| 89 | (type list strat) | |
| 90 | (values list)) | |
| 88 | (type list strat) | |
| 89 | (values list)) | |
| 91 | 90 | (let ((num-args (operator-num-args op))) |
| 92 | 91 | (declare (type fixnum num-args)) |
| 93 | 92 | (unless (and (listp strat) |
| 94 | (every #'(lambda (x) (and (integerp x) | |
| 95 | (<= (the fixnum x) num-args))) | |
| 96 | strat)) | |
| 93 | (every #'(lambda (x) (and (integerp x) | |
| 94 | (<= (the fixnum x) num-args))) | |
| 95 | strat)) | |
| 97 | 96 | (with-output-chaos-error ('invalid-op-attribute) |
| 98 | (format t "invalid strategy ~a for opeator ~a, ignored." | |
| 99 | strat (operator-name op)) | |
| 100 | )) | |
| 97 | (format t "invalid strategy ~a for opeator ~a, ignored." | |
| 98 | strat (operator-name op)) | |
| 99 | )) | |
| 101 | 100 | ;; |
| 102 | 101 | (setf (operator-strategy op) strat))) |
| 103 | 102 | |
| 104 | 103 | (defun complete-strategy (num-args strat) |
| 105 | 104 | (declare (ignore num-args) |
| 106 | (type fixnum num-args) | |
| 107 | (type list strat) | |
| 108 | (values list)) | |
| 105 | (type fixnum num-args) | |
| 106 | (type list strat) | |
| 107 | (values list)) | |
| 109 | 108 | ;; allow duplicated arg pos. |
| 110 | 109 | ;; (setf strat (remove-duplicates strat)) |
| 111 | 110 | (let ((rest nil)) |
| 112 | 111 | #|| |
| 113 | 112 | (dotimes (x num-args) |
| 114 | 113 | (unless (member (1+ x) strat :test #'(lambda (a b) |
| 115 | (eql (abs a) (abs b)))) | |
| 116 | (push (1+ x) rest))) | |
| 114 | (eql (abs a) (abs b)))) | |
| 115 | (push (1+ x) rest))) | |
| 117 | 116 | ||# |
| 118 | 117 | (append strat |
| 119 | (if (member 0 strat) nil '(0)) | |
| 120 | (nreverse rest)))) | |
| 118 | (if (member 0 strat) nil '(0)) | |
| 119 | (nreverse rest)))) | |
| 121 | 120 | |
| 122 | 121 | ;;; OPERATOR THEORY ____________________________________________________________ |
| 123 | 122 | |
| 126 | 125 | (defvar .theory-code-table. ) |
| 127 | 126 | (eval-when (:execute :load-toplevel :compile-toplevel) |
| 128 | 127 | (setf .theory-code-table. |
| 129 | '((:assoc . #..A.) | |
| 130 | (:comm . #..C.) | |
| 131 | (:idr . #..Z.) | |
| 132 | (:id . #..Z.) | |
| 133 | (:idem . #..I.) | |
| 134 | ))) | |
| 128 | '((:assoc . #..A.) | |
| 129 | (:comm . #..C.) | |
| 130 | (:idr . #..Z.) | |
| 131 | (:id . #..Z.) | |
| 132 | (:idem . #..I.) | |
| 133 | ))) | |
| 135 | 134 | |
| 136 | 135 | ;;; *RESTRICTION*: NOW IDENTITY TERM MUST BE A CONSTANT. |
| 137 | 136 | ;;; *TODO* : |
| 138 | 137 | #|| |
| 139 | 138 | (defun declare-operator-theory (operator theory &optional (module *current-module*)) |
| 140 | 139 | (declare (type operator operator) |
| 141 | (type list theory) | |
| 142 | (type module module) | |
| 143 | (values list)) | |
| 140 | (type list theory) | |
| 141 | (type module module) | |
| 142 | (values list)) | |
| 144 | 143 | (let ((theory (compute-theory-from-attr-decl (operator-num-args operator) |
| 145 | theory | |
| 146 | (operator-theory operator) | |
| 147 | module))) | |
| 144 | theory | |
| 145 | (operator-theory operator) | |
| 146 | module))) | |
| 148 | 147 | (setf (operator-theory operator) theory) )) |
| 149 | 148 | ||# |
| 150 | 149 | |
| 151 | 150 | (defun compute-theory-from-attr-decl (arity theory-decl old-theory &optional (module *current-module*)) |
| 152 | 151 | (declare (type list arity) |
| 153 | (type list theory-decl) | |
| 154 | (type (or null op-theory) old-theory) | |
| 155 | (type module module)) | |
| 152 | (type list theory-decl) | |
| 153 | (type (or null op-theory) old-theory) | |
| 154 | (type module module)) | |
| 156 | 155 | (unless old-theory (setf old-theory *the-empty-theory*)) |
| 157 | 156 | (let ((num-args (length arity)) |
| 158 | (code (theory-code old-theory)) | |
| 159 | (t-code 0) | |
| 160 | (is-iden-r nil) | |
| 161 | (id nil)) | |
| 157 | (code (theory-code old-theory)) | |
| 158 | (t-code 0) | |
| 159 | (is-iden-r nil) | |
| 160 | (id nil)) | |
| 162 | 161 | (declare (type fixnum num-args code) |
| 163 | (type (or null fixnum) t-code)) | |
| 162 | (type (or null fixnum) t-code)) | |
| 164 | 163 | (dolist (theory-elt theory-decl) |
| 165 | 164 | (cond ((symbolp theory-elt) |
| 166 | (setf t-code (cdr (assq theory-elt .theory-code-table.))) | |
| 167 | (unless t-code | |
| 168 | (with-output-chaos-error ('invalid-op-attribute) | |
| 169 | (princ "invalid opertor theory ") | |
| 170 | (princ theory-elt))) | |
| 171 | (setf code (logior code t-code))) | |
| 172 | ((and (listp theory-elt) (= 2 (length theory-elt))) | |
| 173 | (setq t-code | |
| 174 | (cdr (assq (car theory-elt) .theory-code-table.))) | |
| 175 | (unless t-code | |
| 176 | (with-output-chaos-error ('invalid-op-attribute) | |
| 177 | (princ "invalid operator theory ") | |
| 178 | (princ theory-elt))) | |
| 179 | (setq code (logior code t-code)) | |
| 180 | (setq id (if (consp (cadr theory-elt)) (cadr theory-elt) | |
| 181 | (cdr theory-elt))) | |
| 182 | (when (eq (car theory-elt) ':idr) (setq is-iden-r t))) | |
| 183 | (t (with-output-chaos-warning () | |
| 184 | (princ "unknown opertor theory ") | |
| 185 | (princ theory-elt) | |
| 186 | (princ ", ignored."))))) | |
| 165 | (setf t-code (cdr (assq theory-elt .theory-code-table.))) | |
| 166 | (unless t-code | |
| 167 | (with-output-chaos-error ('invalid-op-attribute) | |
| 168 | (princ "invalid opertor theory ") | |
| 169 | (princ theory-elt))) | |
| 170 | (setf code (logior code t-code))) | |
| 171 | ((and (listp theory-elt) (= 2 (length theory-elt))) | |
| 172 | (setq t-code | |
| 173 | (cdr (assq (car theory-elt) .theory-code-table.))) | |
| 174 | (unless t-code | |
| 175 | (with-output-chaos-error ('invalid-op-attribute) | |
| 176 | (princ "invalid operator theory ") | |
| 177 | (princ theory-elt))) | |
| 178 | (setq code (logior code t-code)) | |
| 179 | (setq id (if (consp (cadr theory-elt)) (cadr theory-elt) | |
| 180 | (cdr theory-elt))) | |
| 181 | (when (eq (car theory-elt) ':idr) (setq is-iden-r t))) | |
| 182 | (t (with-output-chaos-warning () | |
| 183 | (princ "unknown opertor theory ") | |
| 184 | (princ theory-elt) | |
| 185 | (princ ", ignored."))))) | |
| 187 | 186 | ;; identity |
| 188 | 187 | (when id |
| 189 | 188 | (prepare-for-parsing module) |
| 190 | 189 | (let ((trm (simple-parse module id (car (maximal-sorts arity *current-sort-order*))))) |
| 191 | (when (term-ill-defined trm) | |
| 192 | (with-output-chaos-error ('invalid-op-attribute) | |
| 193 | (format t "invalid identity term ~a" id))) | |
| 194 | (setq id trm))) | |
| 190 | (when (term-ill-defined trm) | |
| 191 | (with-output-chaos-error ('invalid-op-attribute) | |
| 192 | (format t "invalid identity term ~a" id))) | |
| 193 | (setq id trm))) | |
| 195 | 194 | |
| 196 | 195 | ;; associativity |
| 197 | 196 | (when (test-theory .A. code) |
| 198 | 197 | (unless (= num-args 2) |
| 199 | (with-output-chaos-warning () | |
| 200 | (princ "associativity theory is meaning-less for non-binary operators, ignored") | |
| 201 | (setq code (unset-theory code .A.))))) | |
| 198 | (with-output-chaos-warning () | |
| 199 | (princ "associativity theory is meaning-less for non-binary operators, ignored") | |
| 200 | (setq code (unset-theory code .A.))))) | |
| 202 | 201 | |
| 203 | 202 | ;; commutativity |
| 204 | 203 | (when (test-theory .C. code) |
| 205 | 204 | (unless (= num-args 2) |
| 206 | (with-output-chaos-warning () | |
| 207 | (princ "commutativity theory is meaning-less for non-binary operators, ignored") | |
| 208 | (setq code (unset-theory code .C.))))) | |
| 205 | (with-output-chaos-warning () | |
| 206 | (princ "commutativity theory is meaning-less for non-binary operators, ignored") | |
| 207 | (setq code (unset-theory code .C.))))) | |
| 209 | 208 | |
| 210 | 209 | ;; final result. |
| 211 | 210 | (theory-make (theory-code-to-info code) |
| 212 | (if id (cons id is-iden-r)) ))) | |
| 211 | (if id (cons id is-iden-r)) ))) | |
| 213 | 212 | |
| 214 | 213 | ;;; ASSOCIATIVITY_______________________________________________________________ |
| 215 | 214 | |
| 218 | 217 | |
| 219 | 218 | (defun declare-operator-associativity (op assoc) |
| 220 | 219 | (declare (type operator op) |
| 221 | (type (or simple-string symbol) assoc) | |
| 222 | (values t)) | |
| 220 | (type (or simple-string symbol) assoc) | |
| 221 | (values t)) | |
| 223 | 222 | (if (stringp assoc) |
| 224 | 223 | (setf assoc (intern assoc))) |
| 225 | 224 | (case assoc |
| 228 | 227 | ((:r-assoc |r-assoc| :right-associative |right-associative|) |
| 229 | 228 | (setf (operator-associativity op) ':right)) |
| 230 | 229 | (t (with-output-chaos-warning () |
| 231 | (princ "unknown associativity declaration ") | |
| 232 | (princ assoc) | |
| 233 | (princ " for operator ") | |
| 234 | (princ (operator-name op)) | |
| 235 | (princ ", ignored."))))) | |
| 230 | (princ "unknown associativity declaration ") | |
| 231 | (princ assoc) | |
| 232 | (princ " for operator ") | |
| 233 | (princ (operator-name op)) | |
| 234 | (princ ", ignored."))))) | |
| 236 | 235 | |
| 237 | 236 | ;;; PRECEDENCE__________________________________________________________________ |
| 238 | 237 | ;;; |
| 239 | 238 | |
| 240 | 239 | (defun declare-operator-precedence (op prec) |
| 241 | 240 | (declare (type operator op) |
| 242 | (type (or simple-string fixnum) prec) | |
| 243 | (values t)) | |
| 241 | (type (or simple-string fixnum) prec) | |
| 242 | (values t)) | |
| 244 | 243 | (if (stringp prec) |
| 245 | 244 | (setf prec (read-from-string prec))) |
| 246 | 245 | (unless (and (integerp prec) |
| 247 | (>= prec parser-min-precedence) | |
| 248 | (<= prec parser-max-precedence)) | |
| 246 | (>= prec parser-min-precedence) | |
| 247 | (<= prec parser-max-precedence)) | |
| 249 | 248 | (with-output-chaos-warning () |
| 250 | 249 | (format t "operator precedence must be a natural number less than ~d, but ~d is given, ignored." parser-max-precedence prec) |
| 251 | 250 | (return-from declare-operator-precedence nil))) |
| 254 | 253 | ;;; MEMO________________________________________________________________________ |
| 255 | 254 | ;;; memoize the rewriting result. |
| 256 | 255 | (defun compute-memo (attr) |
| 257 | (if *memo-rewrite* ; (and *memo-rewrite* *always-memo*) | |
| 256 | (if *memo-rewrite* ; (and *memo-rewrite* *always-memo*) | |
| 258 | 257 | t |
| 259 | 258 | (let ((memo-decl (find-if #'(lambda (i) |
| 260 | (unless (atom i) | |
| 261 | (equal "memo" (car i)))) | |
| 262 | attr))) | |
| 259 | (unless (atom i) | |
| 260 | (equal "memo" (car i)))) | |
| 261 | attr))) | |
| 263 | 262 | (if memo-decl t nil)))) |
| 264 | 263 | |
| 265 | 264 | ;; (defun declare-operator-memo-attr (op memo) |
| 279 | 278 | |
| 280 | 279 | (defun declare-method-theory (method attr &optional (info *current-opinfo-table*)) |
| 281 | 280 | (declare (type method method) |
| 282 | (type list attr) | |
| 283 | (type hash-table info) | |
| 284 | (values t)) | |
| 281 | (type list attr) | |
| 282 | (type hash-table info) | |
| 283 | (values t)) | |
| 285 | 284 | (let ((theory (compute-theory-from-attr-decl (method-arity method) |
| 286 | attr | |
| 287 | (operator-theory (method-operator method info))))) | |
| 285 | attr | |
| 286 | (operator-theory (method-operator method info))))) | |
| 288 | 287 | (set-method-theory method theory info))) |
| 289 | 288 | |
| 290 | 289 | (defun set-method-theory (method theory |
| 291 | &optional | |
| 292 | (info *current-opinfo-table*) | |
| 293 | (inherit nil)) | |
| 290 | &optional | |
| 291 | (info *current-opinfo-table*) | |
| 292 | (inherit nil)) | |
| 294 | 293 | (declare (type method method) |
| 295 | (type op-theory theory) | |
| 296 | (type hash-table info) | |
| 297 | (type (or null t) inherit) | |
| 298 | (values op-theory)) | |
| 294 | (type op-theory theory) | |
| 295 | (type hash-table info) | |
| 296 | (type (or null t) inherit) | |
| 297 | (values op-theory)) | |
| 299 | 298 | (let ((new-th (check-method-theory-consistency method theory info inherit))) |
| 300 | 299 | (setf (method-theory method info) new-th) |
| 301 | 300 | (compute-method-theory-info-for-matching method info) |
| 302 | 301 | new-th)) |
| 303 | 302 | |
| 304 | 303 | (defun check-method-theory-consistency (method theory info |
| 305 | &optional inherit | |
| 306 | no-merge) | |
| 304 | &optional inherit | |
| 305 | no-merge) | |
| 307 | 306 | (declare (type method method) |
| 308 | (type op-theory theory) | |
| 309 | (type hash-table info) | |
| 310 | (type (or null t) inherit no-merge) | |
| 311 | (values t)) | |
| 307 | (type op-theory theory) | |
| 308 | (type hash-table info) | |
| 309 | (type (or null t) inherit no-merge) | |
| 310 | (values t)) | |
| 312 | 311 | (let ((arity (method-arity method)) |
| 313 | 312 | (coarity (method-coarity method)) |
| 314 | 313 | (new-code (theory-code theory)) |
| 315 | (old-th (method-theory method info))) | |
| 314 | (old-th (method-theory method info))) | |
| 316 | 315 | (declare (type list arity) |
| 317 | (type sort-struct coarity) | |
| 318 | (type fixnum new-code) | |
| 319 | (type (or null op-theory) old-th)) | |
| 316 | (type sort-struct coarity) | |
| 317 | (type fixnum new-code) | |
| 318 | (type (or null op-theory) old-th)) | |
| 320 | 319 | ;; |
| 321 | 320 | (unless no-merge |
| 322 | 321 | (when (and old-th (not (eq theory old-th))) |
| 323 | (setq theory (merge-operator-theory-in *current-module* | |
| 324 | method | |
| 325 | old-th | |
| 326 | theory | |
| 327 | )) | |
| 328 | (setq new-code (theory-code theory)))) | |
| 322 | (setq theory (merge-operator-theory-in *current-module* | |
| 323 | method | |
| 324 | old-th | |
| 325 | theory)) | |
| 326 | (setq new-code (theory-code theory)))) | |
| 329 | 327 | ;; |
| 330 | 328 | ;; associativity |
| 331 | 329 | ;; |
| 332 | 330 | (when (theory-contains-associativity theory) |
| 333 | 331 | (unless (and (is-in-same-connected-component coarity (car arity) *current-sort-order*) |
| 334 | (is-in-same-connected-component coarity (cadr arity) *current-sort-order*) | |
| 335 | (is-in-same-connected-component (car arity) (cadr arity) *current-sort-order*)) | |
| 336 | ;; should always check | |
| 337 | (unless inherit | |
| 338 | (with-output-chaos-warning () | |
| 339 | (format t "rank of method ") | |
| 340 | (print-chaos-object method) | |
| 341 | (print-next) | |
| 342 | (format t "does not allow it to be associative, ignoring `assoc' attribute."))) | |
| 343 | (setf new-code (unset-theory new-code .A.)))) | |
| 332 | (is-in-same-connected-component coarity (cadr arity) *current-sort-order*) | |
| 333 | (is-in-same-connected-component (car arity) (cadr arity) *current-sort-order*)) | |
| 334 | ;; should always check | |
| 335 | (unless inherit | |
| 336 | (with-output-chaos-warning () | |
| 337 | (format t "rank of method ") | |
| 338 | (print-chaos-object method) | |
| 339 | (print-next) | |
| 340 | (format t "does not allow it to be associative, ignoring `assoc' attribute."))) | |
| 341 | (setf new-code (unset-theory new-code .A.)))) | |
| 344 | 342 | ;; |
| 345 | 343 | ;; commutativity |
| 346 | 344 | ;; |
| 347 | 345 | (when (theory-contains-commutativity theory) |
| 348 | 346 | (unless (is-in-same-connected-component (car arity) (cadr arity) *current-sort-order*) |
| 349 | ;; | |
| 350 | (unless inherit | |
| 351 | (with-output-chaos-warning () | |
| 352 | (princ "commutative operations, their arguments must be of the same connected component.") | |
| 353 | (print-next) | |
| 354 | (princ "`comm' attribute of operation ") | |
| 355 | (print-chaos-object method) | |
| 356 | (princ " is ignored."))) | |
| 357 | (setf new-code (unset-theory new-code .C.)))) | |
| 347 | ;; | |
| 348 | (unless inherit | |
| 349 | (with-output-chaos-warning () | |
| 350 | (princ "commutative operations, their arguments must be of the same connected component.") | |
| 351 | (print-next) | |
| 352 | (princ "`comm' attribute of operation ") | |
| 353 | (print-chaos-object method) | |
| 354 | (princ " is ignored."))) | |
| 355 | (setf new-code (unset-theory new-code .C.)))) | |
| 358 | 356 | ;; |
| 359 | 357 | ;; identity |
| 360 | 358 | ;; |
| 361 | 359 | (when (theory-contains-identity theory) |
| 362 | 360 | (let* ((id (car (theory-zero theory))) |
| 363 | (id-sort (term-sort id))) | |
| 364 | (if (not (and (= 2 (length arity)) | |
| 365 | (is-in-same-connected-component (car arity) (cadr arity) *current-sort-order*) | |
| 366 | (is-in-same-connected-component (car arity) coarity *current-sort-order*))) | |
| 367 | (unless inherit | |
| 368 | (with-output-chaos-warning () | |
| 369 | (princ "id: makes sense only when the operator is binary,") | |
| 370 | (print-next) | |
| 371 | (princ "and its arity sorts and the coarity sort are of same connected components.") | |
| 372 | (print-next) | |
| 373 | (princ "ignoring id:(idr:) attribute of operator ") | |
| 374 | (print-chaos-object method) | |
| 375 | (setf new-code (unset-theory new-code .Z.))) | |
| 376 | (unless (and (sort<= id-sort (car (method-arity method)) | |
| 377 | *current-sort-order*) | |
| 378 | (sort<= id-sort (cadr (method-arity method)) | |
| 379 | *current-sort-order*)) | |
| 380 | (unless inherit | |
| 381 | (with-output-chaos-warning () | |
| 382 | (princ "id: makes sense the identity term belongs to the arity sort.") | |
| 383 | (print-next) | |
| 384 | (princ "ignoreing id:(idr:) attribute of operator ") | |
| 385 | (print-chaos-object method)) | |
| 386 | (setf new-code (unset-theory new-code .Z.)))) )))) | |
| 361 | (id-sort (term-sort id))) | |
| 362 | (if (not (and (= 2 (length arity)) | |
| 363 | (is-in-same-connected-component (car arity) (cadr arity) *current-sort-order*) | |
| 364 | (is-in-same-connected-component (car arity) coarity *current-sort-order*))) | |
| 365 | (unless inherit | |
| 366 | (with-output-chaos-warning () | |
| 367 | (princ "id: makes sense only when the operator is binary,") | |
| 368 | (print-next) | |
| 369 | (princ "and its arity sorts and the coarity sort are of same connected components.") | |
| 370 | (print-next) | |
| 371 | (princ "ignoring id:(idr:) attribute of operator ") | |
| 372 | (print-chaos-object method) | |
| 373 | (setf new-code (unset-theory new-code .Z.))) | |
| 374 | (unless (and (sort<= id-sort (car (method-arity method)) | |
| 375 | *current-sort-order*) | |
| 376 | (sort<= id-sort (cadr (method-arity method)) | |
| 377 | *current-sort-order*)) | |
| 378 | (unless inherit | |
| 379 | (with-output-chaos-warning () | |
| 380 | (princ "id: makes sense the identity term belongs to the arity sort.") | |
| 381 | (print-next) | |
| 382 | (princ "ignoreing id:(idr:) attribute of operator ") | |
| 383 | (print-chaos-object method)) | |
| 384 | (setf new-code (unset-theory new-code .Z.)))) )))) | |
| 387 | 385 | ;; |
| 388 | 386 | (unless (= new-code (theory-code theory)) |
| 389 | 387 | (setf theory (theory-make (theory-code-to-info new-code) |
| 390 | 388 | (if (theory-contains-identity theory) |
| 391 | (theory-zero theory) | |
| 392 | nil)))) | |
| 389 | (theory-zero theory) | |
| 390 | nil)))) | |
| 393 | 391 | ;; (format t "~%** #4 - ~a" new-code) |
| 394 | 392 | (when (and inherit |
| 395 | (theory-contains-associativity theory) | |
| 396 | (null (method-associativity method))) | |
| 393 | (theory-contains-associativity theory) | |
| 394 | (null (method-associativity method))) | |
| 397 | 395 | (setf (method-associativity method) :right)) |
| 398 | 396 | (setf (method-theory method info) theory) |
| 399 | 397 | (compute-method-theory-info-for-matching method info) |
| 402 | 400 | |
| 403 | 401 | (defun merge-operator-theory-in (mod method th1 th2) |
| 404 | 402 | (declare (ignore mod) |
| 405 | (type module mod) | |
| 406 | (type method method) | |
| 407 | (type (or null op-theory) th1 th2) | |
| 408 | (values op-theory)) | |
| 403 | (type module mod) | |
| 404 | (type method method) | |
| 405 | (type (or null op-theory) th1 th2) | |
| 406 | (values op-theory)) | |
| 409 | 407 | (if (null th1) |
| 410 | 408 | th2 |
| 411 | 409 | (let ((code1 (theory-code th1)) |
| 412 | (zero1 (theory-zero th1)) | |
| 413 | (code2 (theory-code th2)) | |
| 414 | (zero2 (theory-zero th2)) | |
| 415 | (new-theory nil)) | |
| 416 | ;; | |
| 417 | (if (= code1 code2) | |
| 418 | th2 | |
| 419 | (let ((new-code (logior code1 code2)) | |
| 420 | (zero nil)) | |
| 421 | (setq new-theory (create-theory new-code nil)) | |
| 422 | (setq zero | |
| 423 | (if (null zero1) | |
| 424 | zero2 | |
| 425 | (if (null zero2) | |
| 426 | zero1 | |
| 427 | (if (equal zero1 zero2) | |
| 428 | zero1 | |
| 429 | (with-output-chaos-warning () | |
| 430 | (format t "variation in identity of method ") | |
| 431 | (print-chaos-object method) | |
| 432 | (print-next) | |
| 433 | (format t "re setting it to ") | |
| 434 | (print-chaos-object zero) | |
| 435 | nil) | |
| 436 | )))) | |
| 437 | (setf (theory-zero new-theory) zero) | |
| 438 | new-theory))))) | |
| 410 | (zero1 (theory-zero th1)) | |
| 411 | (code2 (theory-code th2)) | |
| 412 | (zero2 (theory-zero th2)) | |
| 413 | (new-theory nil)) | |
| 414 | ;; | |
| 415 | (if (= code1 code2) | |
| 416 | th2 | |
| 417 | (let ((new-code (logior code1 code2)) | |
| 418 | (zero nil)) | |
| 419 | (setq new-theory (create-theory new-code nil)) | |
| 420 | (setq zero | |
| 421 | (if (null zero1) | |
| 422 | zero2 | |
| 423 | (if (null zero2) | |
| 424 | zero1 | |
| 425 | (if (equal zero1 zero2) | |
| 426 | zero1 | |
| 427 | (with-output-chaos-warning () | |
| 428 | (format t "variation in identity of method ") | |
| 429 | (print-chaos-object method) | |
| 430 | (print-next) | |
| 431 | (format t "re setting it to ") | |
| 432 | (print-chaos-object zero) | |
| 433 | nil) | |
| 434 | )))) | |
| 435 | (setf (theory-zero new-theory) zero) | |
| 436 | new-theory))))) | |
| 439 | 437 | |
| 440 | 438 | ;;; REWRITE STRATEGY____________________________________________________________ |
| 441 | 439 | |
| 442 | 440 | (defun declare-method-strategy (meth strat &optional (info *current-opinfo-table*)) |
| 443 | 441 | (declare (type method meth) |
| 444 | (type list strat) | |
| 445 | (type hash-table info) | |
| 446 | (values list)) | |
| 442 | (type list strat) | |
| 443 | (type hash-table info) | |
| 444 | (values list)) | |
| 447 | 445 | (let ((num-args (operator-num-args (method-operator meth info)))) |
| 448 | 446 | (declare (type fixnum num-args)) |
| 449 | 447 | (unless (and (listp strat) |
| 450 | (every #'(lambda (x) (and (integerp x) | |
| 451 | (<= (the fixnum x) num-args))) | |
| 452 | strat)) | |
| 448 | (every #'(lambda (x) (and (integerp x) | |
| 449 | (<= (the fixnum x) num-args))) | |
| 450 | strat)) | |
| 453 | 451 | (with-output-chaos-error ('invalid-op-attribute) |
| 454 | (princ "invalid strategy ") | |
| 455 | (princ strat) | |
| 456 | (princ " for operator ") | |
| 457 | (princ (method-symbol meth)) | |
| 458 | )) | |
| 452 | (princ "invalid strategy ") | |
| 453 | (princ strat) | |
| 454 | (princ " for operator ") | |
| 455 | (princ (method-symbol meth)))) | |
| 459 | 456 | ;; complete |
| 460 | 457 | (setf (method-supplied-strategy meth) (complete-strategy num-args strat)))) |
| 461 | 458 | |
| 463 | 460 | |
| 464 | 461 | (defun declare-method-associativity (meth assoc) |
| 465 | 462 | (declare (type method meth) |
| 466 | (type (or simple-string symbol) assoc) | |
| 467 | (values t)) | |
| 463 | (type (or simple-string symbol) assoc) | |
| 464 | (values t)) | |
| 468 | 465 | (if (stringp assoc) |
| 469 | 466 | (setf assoc (intern assoc))) |
| 470 | 467 | (case assoc |
| 473 | 470 | ((:r-assoc |r-assoc| :right-associative |right-associative|) |
| 474 | 471 | (setf (method-associativity meth) ':right)) |
| 475 | 472 | (t (with-output-chaos-warning () |
| 476 | (format t "unknown associativity declaration ~a assoc for operator ~a, ignored" | |
| 477 | assoc | |
| 478 | (method-symbol meth) | |
| 479 | )) | |
| 473 | (format t "unknown associativity declaration ~a assoc for operator ~a, ignored" | |
| 474 | assoc | |
| 475 | (method-symbol meth))) | |
| 480 | 476 | nil))) |
| 481 | 477 | |
| 482 | 478 | ;;; PRECEDENCE ___________________________________________________________________ |
| 483 | 479 | |
| 484 | 480 | (defun declare-method-precedence (meth prec) |
| 485 | 481 | (declare (type method meth) |
| 486 | (type (or simple-string fixnum) prec) | |
| 487 | (values (or null fixnum))) | |
| 482 | (type (or simple-string fixnum) prec) | |
| 483 | (values (or null fixnum))) | |
| 488 | 484 | (if (stringp prec) |
| 489 | 485 | (setf prec (read-from-string prec))) |
| 490 | 486 | (unless (and (integerp prec) |
| 491 | (>= prec parser-min-precedence) | |
| 492 | (<= prec parser-max-precedence)) | |
| 487 | (>= prec parser-min-precedence) | |
| 488 | (<= prec parser-max-precedence)) | |
| 493 | 489 | (with-output-chaos-warning () |
| 494 | 490 | (format t "operator precedence must be a natural number between ~d and ~d, but ~d is given, ignored." |
| 495 | parser-min-precedence parser-max-precedence | |
| 496 | prec) | |
| 491 | parser-min-precedence parser-max-precedence | |
| 492 | prec) | |
| 497 | 493 | (return-from declare-method-precedence nil))) |
| 498 | 494 | (setf (method-precedence meth) prec)) |
| 499 | 495 | |
| 510 | 506 | |
| 511 | 507 | (defun declare-method-constr (method constr) |
| 512 | 508 | (declare (type method method) |
| 513 | (type (or null t) constr) | |
| 514 | (values (or null t))) | |
| 509 | (type (or null t) constr) | |
| 510 | (values (or null t))) | |
| 515 | 511 | (setf (method-constructor method) constr) |
| 516 | 512 | (when constr |
| 517 | 513 | (pushnew method (sort-constructor (method-coarity method)) |
| 518 | :test #'eq)) | |
| 519 | ) | |
| 514 | :test #'eq))) | |
| 520 | 515 | |
| 521 | 516 | ;;; COHERENCY --------------------------------------------------------------------- |
| 522 | 517 | |
| 523 | 518 | (defun declare-method-coherent (method coherent) |
| 524 | 519 | (declare (type method method) |
| 525 | (type (or null t) coherent) | |
| 526 | (values (or null t))) | |
| 520 | (type (or null t) coherent) | |
| 521 | (values (or null t))) | |
| 527 | 522 | (setf (method-coherent method) coherent)) |
| 528 | ||
| 529 | ;;; COPIER ________________________________________________________________________ | |
| 530 | ;;; COPY-METHOD-INFO : from-method to-method | |
| 531 | ;;; | |
| 532 | #|| NOT USED | |
| 533 | (defun copy-method-info (from to) | |
| 534 | (let (sup-strat | |
| 535 | theory | |
| 536 | prec | |
| 537 | memo | |
| 538 | assoc | |
| 539 | constr) | |
| 540 | (when *on-operator-debug* | |
| 541 | (format t "~&[copy-method-info]:") | |
| 542 | (format t "~&-- copy from ") (print-chaos-object from) | |
| 543 | (format t "~& to ") (print-chaos-object to)) | |
| 544 | (let ((from-module (method-module from))) | |
| 545 | (with-in-module (from-module) | |
| 546 | (setf sup-strat (method-supplied-strategy from) | |
| 547 | theory (method-theory from) | |
| 548 | prec (get-method-precedence from) | |
| 549 | memo (method-memo from) | |
| 550 | assoc (method-associativity from) | |
| 551 | constr (method-constructor from)))) | |
| 552 | (let ((to-module (method-module to))) | |
| 553 | (with-in-module (to-module) | |
| 554 | (setf (method-supplied-strategy to) sup-strat | |
| 555 | (method-theory to) theory | |
| 556 | (method-precedence to) prec | |
| 557 | (method-memo to) memo | |
| 558 | (method-associativity to) assoc | |
| 559 | (method-constructor to) constr))) | |
| 560 | )) | |
| 561 | ||
| 562 | ||# | |
| 563 | 523 | |
| 564 | 524 | ;;; ******************** |
| 565 | 525 | ;;; OPERATOR DECLARATION _______________________________________________________ |
| 568 | 528 | ;;; NOTE: *assumption: all sorts are registed in the module |
| 569 | 529 | |
| 570 | 530 | (defun declare-operator-in-module (op-name arity coarity module |
| 571 | &optional | |
| 572 | constructor | |
| 573 | behavioural | |
| 574 | coherent | |
| 575 | error-operator) | |
| 576 | ||
| 531 | &optional | |
| 532 | constructor | |
| 533 | behavioural | |
| 534 | coherent | |
| 535 | error-operator) | |
| 536 | ||
| 577 | 537 | (declare (type t op-name) |
| 578 | (type list arity) | |
| 579 | ;; (type (or symbol sort* list string) coarity) | |
| 580 | (type (or null t) constructor behavioural coherent | |
| 581 | error-operator) | |
| 582 | (values (or null operator) (or null method) (or null t))) | |
| 538 | (type list arity) | |
| 539 | ;; (type (or symbol sort* list string) coarity) | |
| 540 | (type (or null t) constructor behavioural coherent | |
| 541 | error-operator) | |
| 542 | (values (or null operator) (or null method) (or null t))) | |
| 583 | 543 | ;; |
| 584 | 544 | (let* ((mod (if (module-p module) |
| 585 | module | |
| 586 | (find-module-in-env module)))) | |
| 545 | module | |
| 546 | (find-module-in-env module)))) | |
| 587 | 547 | (unless mod |
| 588 | 548 | (with-output-chaos-error ('no-such-module) |
| 589 | (princ "declaring operator, no such module ") | |
| 590 | (princ module) | |
| 591 | )) | |
| 549 | (princ "declaring operator, no such module ") | |
| 550 | (princ module))) | |
| 592 | 551 | |
| 593 | 552 | ;; check arity, coarity |
| 594 | 553 | (with-in-module (mod) |
| 595 | 554 | (let ((r-arity nil) |
| 596 | (r-coarity coarity)) | |
| 597 | (dolist (a arity) | |
| 598 | (let ((s (if (sort-struct-p a) a (find-sort-in mod a)))) | |
| 599 | (when (and (err-sort-p s) | |
| 600 | (not error-operator)) | |
| 601 | (return-from declare-operator-in-module | |
| 602 | (values nil nil t))) | |
| 603 | (unless s | |
| 604 | (cond ((and (not error-operator) | |
| 605 | (may-be-error-sort-ref? a)) | |
| 606 | ;; may declaration of error operator | |
| 607 | ;; the process is postponed | |
| 608 | (return-from declare-operator-in-module | |
| 609 | (values nil nil t))) | |
| 610 | (t (with-output-chaos-error ('no-such-sort) | |
| 611 | (princ "declaring operator, no such sort ") | |
| 612 | (print-sort-ref a) | |
| 613 | )))) | |
| 614 | (push s r-arity))) | |
| 615 | (setf r-coarity (if (sort-struct-p coarity) | |
| 616 | coarity | |
| 617 | (find-sort-in mod coarity))) | |
| 618 | (when (and (err-sort-p r-coarity) | |
| 619 | (not error-operator)) | |
| 620 | (return-from declare-operator-in-module | |
| 621 | (values nil nil t))) | |
| 622 | ;; | |
| 623 | (unless r-coarity | |
| 624 | (cond ((and (not error-operator) | |
| 625 | (may-be-error-sort-ref? coarity)) | |
| 626 | (return-from declare-operator-in-module | |
| 627 | (values nil nil t))) | |
| 628 | (t | |
| 629 | (with-output-chaos-error ('no-such-sort) | |
| 630 | (princ "declaring operator, no such sort ") | |
| 631 | (print-sort-ref coarity) | |
| 632 | )))) | |
| 633 | ;; name conflict check with existing variables | |
| 634 | #|| | |
| 635 | (when (and (null r-arity) | |
| 636 | (find-variable-in module (car op-name))) | |
| 637 | (with-output-chaos-warning () | |
| 638 | (format t "declaring op ~s" op-name) | |
| 639 | (print-next) | |
| 640 | (princ " there already a variable with the same name.") | |
| 641 | (princ " ... ignoring")) | |
| 642 | (return-from declare-operator-in-module (values nil nil nil)) | |
| 643 | ) | |
| 644 | ||# | |
| 645 | ;; | |
| 646 | (multiple-value-bind (x y) | |
| 647 | (add-operator-declaration-to-module op-name | |
| 648 | (nreverse r-arity) | |
| 649 | r-coarity | |
| 650 | mod | |
| 651 | constructor | |
| 652 | behavioural | |
| 653 | coherent | |
| 654 | error-operator | |
| 655 | ) | |
| 656 | (values x y nil)))) | |
| 657 | )) | |
| 555 | (r-coarity coarity)) | |
| 556 | (dolist (a arity) | |
| 557 | (let ((s (if (sort-struct-p a) a (find-sort-in mod a)))) | |
| 558 | (when (and (err-sort-p s) | |
| 559 | (not error-operator)) | |
| 560 | (return-from declare-operator-in-module | |
| 561 | (values nil nil t))) | |
| 562 | (unless s | |
| 563 | (cond ((and (not error-operator) | |
| 564 | (may-be-error-sort-ref? a)) | |
| 565 | ;; may declaration of error operator | |
| 566 | ;; the process is postponed | |
| 567 | (return-from declare-operator-in-module | |
| 568 | (values nil nil t))) | |
| 569 | (t (with-output-chaos-error ('no-such-sort) | |
| 570 | (princ "declaring operator, no such sort ") | |
| 571 | (print-sort-ref a) | |
| 572 | )))) | |
| 573 | (push s r-arity))) | |
| 574 | (setf r-coarity (if (sort-struct-p coarity) | |
| 575 | coarity | |
| 576 | (find-sort-in mod coarity))) | |
| 577 | (when (and (err-sort-p r-coarity) | |
| 578 | (not error-operator)) | |
| 579 | (return-from declare-operator-in-module | |
| 580 | (values nil nil t))) | |
| 581 | ;; | |
| 582 | (unless r-coarity | |
| 583 | (cond ((and (not error-operator) | |
| 584 | (may-be-error-sort-ref? coarity)) | |
| 585 | (return-from declare-operator-in-module | |
| 586 | (values nil nil t))) | |
| 587 | (t | |
| 588 | (with-output-chaos-error ('no-such-sort) | |
| 589 | (princ "declaring operator, no such sort ") | |
| 590 | (print-sort-ref coarity))))) | |
| 591 | (multiple-value-bind (x y) | |
| 592 | (add-operator-declaration-to-module op-name | |
| 593 | (nreverse r-arity) | |
| 594 | r-coarity | |
| 595 | mod | |
| 596 | constructor | |
| 597 | behavioural | |
| 598 | coherent | |
| 599 | error-operator) | |
| 600 | (values x y nil)))))) | |
| 658 | 601 | |
| 659 | 602 | (defun make-operator-in-module (op-name num-args module &optional qual-name) |
| 660 | 603 | (declare (ignore qual-name) |
| 661 | (type t op-name) | |
| 662 | (type fixnum num-args) | |
| 663 | (type module module) | |
| 664 | (type t qual-name) | |
| 665 | (values operator)) | |
| 604 | (type t op-name) | |
| 605 | (type fixnum num-args) | |
| 606 | (type module module) | |
| 607 | (type t qual-name) | |
| 608 | (values operator)) | |
| 666 | 609 | (let ((op (make-operator-internal op-name num-args module))) |
| 667 | 610 | op)) |
| 668 | 611 | |
| 669 | 612 | (defun check-overloading-with-builtin (op-name arity coarity module) |
| 670 | 613 | (unless arity |
| 671 | 614 | (let ((opstr (car op-name)) |
| 672 | (sorts (module-all-sorts module))) | |
| 673 | (dolist (bi sorts) | |
| 674 | (when (sort-is-builtin bi) | |
| 675 | (let ((token-pred (bsort-token-predicate bi))) | |
| 676 | (when (and token-pred | |
| 677 | (funcall token-pred opstr) | |
| 678 | (is-in-same-connected-component* coarity | |
| 679 | bi | |
| 680 | (module-sort-order module))) | |
| 681 | ||
| 682 | (with-output-chaos-warning () | |
| 683 | (format t "operator name ~s is overloaded with built-in constant of sort " opstr) | |
| 684 | (print-sort-name bi module) | |
| 685 | (print-next) | |
| 686 | (princ "... ignored.") | |
| 687 | (return-from check-overloading-with-builtin t) | |
| 688 | )))))) | |
| 689 | ) | |
| 690 | nil) | |
| 615 | (sorts (module-all-sorts module))) | |
| 616 | (dolist (bi sorts nil) | |
| 617 | (when (sort-is-builtin bi) | |
| 618 | (let ((token-pred (bsort-token-predicate bi))) | |
| 619 | (when (and token-pred | |
| 620 | (funcall token-pred opstr) | |
| 621 | (is-in-same-connected-component* coarity | |
| 622 | bi | |
| 623 | (module-sort-order module))) | |
| 624 | ||
| 625 | (with-output-chaos-warning () | |
| 626 | (format t "operator name ~s is overloaded with built-in constant of sort " opstr) | |
| 627 | (print-sort-name bi module) | |
| 628 | (print-next) | |
| 629 | (princ "... ignored.") | |
| 630 | (return-from check-overloading-with-builtin t))))))))) | |
| 691 | 631 | |
| 692 | 632 | (defun add-operator-declaration-to-module (op-name arity coarity module |
| 693 | &optional | |
| 694 | constructor | |
| 695 | behavioural | |
| 696 | coherent | |
| 697 | error-operator) | |
| 633 | &optional | |
| 634 | constructor | |
| 635 | behavioural | |
| 636 | coherent | |
| 637 | error-operator) | |
| 698 | 638 | (declare (type t op-name) |
| 699 | (type list arity) | |
| 700 | (type (or symbol sort-struct) coarity) | |
| 701 | (type t module) | |
| 702 | (type (or null t) | |
| 703 | constructor behavioural coherent error-operator)) | |
| 639 | (type list arity) | |
| 640 | (type (or symbol sort-struct) coarity) | |
| 641 | (type (or null module) module)) | |
| 704 | 642 | (let* ((mod (if (module-p module) |
| 705 | module | |
| 706 | (find-module-in-env module))) | |
| 707 | (op-infos (find-operators-in-module op-name (length arity) mod)) | |
| 708 | (opinfo nil) | |
| 709 | (op nil)) | |
| 643 | module | |
| 644 | (find-module-in-env module))) | |
| 645 | (op-infos (find-operators-in-module op-name (length arity) mod)) | |
| 646 | (opinfo nil) | |
| 647 | (op nil)) | |
| 710 | 648 | (declare (type module mod) |
| 711 | (type list op-infos)) | |
| 649 | (type list op-infos)) | |
| 712 | 650 | ;; |
| 713 | 651 | (when *on-operator-debug* |
| 714 | 652 | (format t "~%[add-operator-declaratoin-to-module]: called with") |
| 715 | 653 | (format t "~% -- op-name = ~a, arity = ~a, coarity = ~a" op-name |
| 716 | arity coarity) | |
| 654 | arity coarity) | |
| 717 | 655 | (format t "~% -- module = ~a, constructor = ~a, behavioural = ~a" |
| 718 | module constructor behavioural) | |
| 719 | (format t "~% -- coherent = ~a, error-operator = ~a" coherent error-operator) | |
| 720 | ) | |
| 656 | module constructor behavioural) | |
| 657 | (format t "~% -- coherent = ~a, error-operator = ~a" coherent error-operator)) | |
| 721 | 658 | ;; checks hidden sort condition |
| 722 | 659 | (let ((hidden? nil)) |
| 723 | 660 | (dolist (as arity) |
| 724 | (when (sort-is-hidden as) | |
| 725 | (if (and hidden? behavioural) | |
| 726 | (with-output-chaos-error ('invalid-op-decl) | |
| 727 | (format t "more than one hidden sort in the declaration of operator \"~{~a~}\"" | |
| 728 | op-name) | |
| 729 | )) | |
| 730 | (setf hidden? t) | |
| 731 | #|| ----------------------------------------------- | |
| 732 | (when (and (not (sort= as *huniversal-sort*)) | |
| 733 | (not (eq module (sort-module as))) | |
| 734 | behavioural) | |
| 735 | (with-output-chaos-warning () | |
| 736 | (format t "behavioural operator \"~{~a~}\" has imported hidden sort " op-name) | |
| 737 | (print-sort-name as) | |
| 738 | (princ " in its arity.") | |
| 739 | )) | |
| 740 | --------------------------------------------------- ||# | |
| 741 | )) | |
| 742 | #|| NULL argument is acceptable...2012/6/28 | |
| 743 | (when (and behavioural (not hidden?)) | |
| 744 | (with-output-chaos-error ('invalid-op-decl) | |
| 745 | (format t "behavioural operator must have exactly one hidden sort in its arity") | |
| 746 | )) | |
| 747 | ||# | |
| 661 | (when (sort-is-hidden as) | |
| 662 | (if (and hidden? behavioural) | |
| 663 | (with-output-chaos-error ('invalid-op-decl) | |
| 664 | (format t "more than one hidden sort in the declaration of operator \"~{~a~}\"" | |
| 665 | op-name) | |
| 666 | )) | |
| 667 | (setf hidden? t))) | |
| 748 | 668 | (when (and behavioural coherent) |
| 749 | (with-output-chaos-error ('invalid-op-decl) | |
| 750 | (format t "coherency is meaningless for behavioural operator.") | |
| 751 | )) | |
| 669 | (with-output-chaos-error ('invalid-op-decl) | |
| 670 | (format t "coherency is meaningless for behavioural operator.") | |
| 671 | )) | |
| 752 | 672 | (when (and coherent (not (some #'(lambda (x) (sort-is-hidden x)) arity))) |
| 753 | (with-output-chaos-error ('invalid-op-decl) | |
| 754 | (format t "coherency is only meaningfull for operator with hidden sort in its arity.") | |
| 755 | )) | |
| 756 | ) | |
| 757 | ||
| 673 | (with-output-chaos-error ('invalid-op-decl) | |
| 674 | (format t "coherency is only meaningfull for operator with hidden sort in its arity.")))) | |
| 758 | 675 | ;; |
| 759 | 676 | (when *builtin-overloading-check* |
| 760 | 677 | (when (check-overloading-with-builtin op-name arity coarity module) |
| 761 | (return-from add-operator-declaration-to-module nil))) | |
| 762 | ;; | |
| 763 | ||
| 678 | (return-from add-operator-declaration-to-module nil))) | |
| 679 | ||
| 764 | 680 | ;; uses pre-existing operator if it is the apropreate one, |
| 765 | 681 | ;; i.e., |
| 766 | 682 | ;; (1) has method with coarity which is in the same connected component. |
| 771 | 687 | ;; |
| 772 | 688 | (when op-infos |
| 773 | 689 | (dolist (x op-infos) |
| 774 | (let ((xcoarity (method-coarity (car (opinfo-methods x))))) | |
| 775 | (when (or (null arity) ; constants always ... | |
| 776 | (equal op-name '("if" "_" "then" "_" "else" "_" "fi")) | |
| 777 | (is-in-same-connected-component* coarity | |
| 778 | xcoarity | |
| 779 | (module-sort-order mod))) | |
| 780 | ||
| 781 | (when *chaos-verbose* ;; *on-operator-debug* | |
| 782 | (with-output-simple-msg () | |
| 783 | (format t "~&declaring overloading operator ~a : " | |
| 784 | (operator-name (opinfo-operator x))) | |
| 785 | (when arity | |
| 786 | (print-sort-list arity mod)) | |
| 787 | (princ " -> ") | |
| 788 | (print-sort-name coarity mod) | |
| 789 | (print-next))) | |
| 790 | ;; | |
| 791 | (setf op (opinfo-operator x)) | |
| 792 | (setf opinfo x) | |
| 793 | (return))))) | |
| 690 | (let ((xcoarity (method-coarity (car (opinfo-methods x))))) | |
| 691 | (when (or (null arity) ; constants always ... | |
| 692 | (equal op-name '("if" "_" "then" "_" "else" "_" "fi")) | |
| 693 | (is-in-same-connected-component* coarity | |
| 694 | xcoarity | |
| 695 | (module-sort-order mod))) | |
| 696 | ||
| 697 | (when *chaos-verbose* | |
| 698 | (with-output-simple-msg () | |
| 699 | (format t "~%declaring overloading operator ~a : " | |
| 700 | (operator-name (opinfo-operator x))) | |
| 701 | (when arity | |
| 702 | (print-sort-list arity mod)) | |
| 703 | (princ " -> ") | |
| 704 | (print-sort-name coarity mod) | |
| 705 | (print-next))) | |
| 706 | ;; | |
| 707 | (setf op (opinfo-operator x)) | |
| 708 | (setf opinfo x) | |
| 709 | (return))))) | |
| 794 | 710 | |
| 795 | 711 | ;; create a new operator iff there is not the same one. |
| 796 | 712 | (unless op |
| 800 | 716 | (push opinfo (module-all-operators mod)) |
| 801 | 717 | (symbol-table-add (module-symbol-table mod) op-name op) |
| 802 | 718 | (when *on-operator-debug* |
| 803 | (format t "~&opdecl: created new operator ~a" (operator-name op))) | |
| 804 | ||
| 805 | ) | |
| 719 | (format t "~%opdecl: created new operator ~a" (operator-name op)))) | |
| 806 | 720 | ;; |
| 807 | 721 | (multiple-value-bind (ent? meth) |
| 808 | (add-operator-declaration-to-table opinfo | |
| 809 | arity | |
| 810 | coarity | |
| 811 | mod | |
| 812 | constructor | |
| 813 | behavioural | |
| 814 | coherent | |
| 815 | error-operator) | |
| 722 | (add-operator-declaration-to-table opinfo | |
| 723 | arity | |
| 724 | coarity | |
| 725 | mod | |
| 726 | constructor | |
| 727 | behavioural | |
| 728 | coherent | |
| 729 | error-operator) | |
| 816 | 730 | (declare (type (or null t) ent?) |
| 817 | (type method meth)) | |
| 731 | (type method meth)) | |
| 818 | 732 | (when ent? (setf (method-module meth) module)) |
| 819 | 733 | (mark-need-parsing-preparation mod) |
| 820 | 734 | (values op meth)))) |
| 825 | 739 | (once-only (?_?opname ?!?number-of-args ?$?module) |
| 826 | 740 | `(or (find-qual-operator-in ,?$?module ,?_?opname ,?!?number-of-args) |
| 827 | 741 | (progn (with-output-chaos-warning () |
| 828 | (princ "no such operator ") | |
| 829 | (print-chaos-object ,?_?opname) | |
| 830 | (princ "in module ") | |
| 831 | (print-mod-name ,?$?module)) | |
| 832 | nil)))) | |
| 742 | (princ "no such operator ") | |
| 743 | (print-chaos-object ,?_?opname) | |
| 744 | (princ "in module ") | |
| 745 | (print-mod-name ,?$?module)) | |
| 746 | nil)))) | |
| 833 | 747 | |
| 834 | 748 | (defun declare-operator-strategy-in-module (op-name number-of-args |
| 835 | strategy | |
| 836 | &optional | |
| 837 | (module *current-module*) ) | |
| 749 | strategy | |
| 750 | &optional | |
| 751 | (module *current-module*) ) | |
| 838 | 752 | (declare (type t op-name) |
| 839 | (type fixnum number-of-args) | |
| 840 | (type list strategy) | |
| 841 | (type module module) | |
| 842 | (values t)) | |
| 753 | (type fixnum number-of-args) | |
| 754 | (type list strategy) | |
| 755 | (type module module) | |
| 756 | (values t)) | |
| 843 | 757 | (let ((opinfo (find-operator-or-warn op-name number-of-args module))) |
| 844 | 758 | (unless opinfo (return-from declare-operator-strategy-in-module nil)) |
| 845 | 759 | (declare-operator-strategy (opinfo-operator opinfo) strategy))) |
| 846 | 760 | |
| 847 | 761 | (defun declare-operator-precedence-in-module (op-name number-of-args |
| 848 | prec | |
| 849 | &optional | |
| 850 | (module | |
| 851 | *current-module*)) | |
| 762 | prec | |
| 763 | &optional | |
| 764 | (module | |
| 765 | *current-module*)) | |
| 852 | 766 | (declare (type t op-name) |
| 853 | (type fixnum number-of-args prec) | |
| 854 | (type module module) | |
| 855 | (values t)) | |
| 767 | (type fixnum number-of-args prec) | |
| 768 | (type module module) | |
| 769 | (values t)) | |
| 856 | 770 | (let ((opinfo (find-operator-or-warn op-name number-of-args module))) |
| 857 | 771 | (unless opinfo (return-from declare-operator-precedence-in-module nil)) |
| 858 | 772 | (declare-operator-precedence (opinfo-operator opinfo) prec))) |
| 859 | 773 | |
| 860 | #|| | |
| 861 | (defun declare-operator-theory-in-module (op-name number-of-args | |
| 862 | theory | |
| 863 | &optional | |
| 864 | (module | |
| 865 | *current-module*)) | |
| 774 | (defun declare-operator-associativity-in-module (op-name number-of-args | |
| 775 | assoc | |
| 776 | &optional | |
| 777 | (module | |
| 778 | *current-module*)) | |
| 866 | 779 | (declare (type t op-name) |
| 867 | (type fixnum number-of-args) | |
| 868 | (type op-theory theory) | |
| 869 | (type module module) | |
| 870 | (values t)) | |
| 871 | (let ((opinfo (find-operator-or-warn op-name number-of-args module))) | |
| 872 | (unless opinfo (return-from declare-operator-theory-in-module nil)) | |
| 873 | (declare-operator-theory (opinfo-operator opinfo) theory))) | |
| 874 | ||# | |
| 875 | ||
| 876 | (defun declare-operator-associativity-in-module (op-name number-of-args | |
| 877 | assoc | |
| 878 | &optional | |
| 879 | (module | |
| 880 | *current-module*)) | |
| 881 | (declare (type t op-name) | |
| 882 | (type fixnum number-of-args) | |
| 883 | (type symbol assoc) | |
| 884 | (type module module) | |
| 885 | (values t)) | |
| 780 | (type fixnum number-of-args) | |
| 781 | (type symbol assoc) | |
| 782 | (type module module) | |
| 783 | (values t)) | |
| 886 | 784 | (let ((opinfo (find-operator-or-warn op-name number-of-args module))) |
| 887 | 785 | (unless opinfo |
| 888 | 786 | (with-output-chaos-error ('invalid-op-name) |
| 889 | (format t "declaring associativity: no such operator ~a" op-name) | |
| 890 | )) | |
| 787 | (format t "declaring associativity: no such operator ~a" op-name) | |
| 788 | )) | |
| 891 | 789 | (declare-operator-associativity (opinfo-operator opinfo) assoc))) |
| 892 | ||
| 790 | ||
| 893 | 791 | |
| 894 | 792 | ;;; ************ |
| 895 | 793 | ;;; METHOD-TABLE |
| 939 | 837 | ;;; |
| 940 | 838 | |
| 941 | 839 | (defun make-method-table (list-of-method |
| 942 | &optional | |
| 943 | (so *current-sort-order*)) | |
| 840 | &optional | |
| 841 | (so *current-sort-order*)) | |
| 944 | 842 | (declare (type list list-of-method) |
| 945 | (type hash-table so) | |
| 946 | (values t)) | |
| 843 | (type hash-table so) | |
| 844 | (values t)) | |
| 947 | 845 | (let ((op (method-operator (car list-of-method)))) |
| 948 | 846 | (make-method-table-internal list-of-method |
| 949 | 0 | |
| 950 | (operator-num-args op) | |
| 951 | so))) | |
| 847 | 0 | |
| 848 | (operator-num-args op) | |
| 849 | so))) | |
| 952 | 850 | |
| 953 | 851 | (defun make-method-table-internal (list-of-method arg-pos num-args so) |
| 954 | 852 | (declare (type list list-of-method) |
| 955 | (type fixnum arg-pos num-args) | |
| 956 | (type hash-table so)) | |
| 957 | ;; | |
| 958 | ;;(debug-msg ("~%====================================================")) | |
| 959 | ;;(debug-msg ("~%arg-pos = ~d") arg-pos) | |
| 960 | ;;(debug-msg ("~%mathods = ~s") list-of-method) | |
| 961 | ;;; | |
| 853 | (type fixnum arg-pos num-args) | |
| 854 | (type hash-table so)) | |
| 962 | 855 | (if (= 0 num-args) |
| 963 | 856 | ;; we assume the signature is regular, thus, constants has only one |
| 964 | 857 | ;; declaration and it has no declaration for erro sort. |
| 965 | 858 | list-of-method |
| 966 | 859 | (if (< arg-pos num-args) |
| 967 | (flet ((get-minimal-methods () | |
| 968 | (let ((sorts (mapcar #'(lambda (arity) (nth arg-pos arity)) | |
| 969 | (mapcar #'(lambda (x) (method-arity x)) | |
| 970 | list-of-method))) | |
| 971 | (res nil)) | |
| 972 | (declare (type list sorts res)) | |
| 973 | (dolist (m list-of-method res) | |
| 974 | ;; (declare (type operator-method m)) | |
| 975 | (let ((m-sort (nth arg-pos (method-arity m)))) | |
| 976 | (when (or (not (intersection (subsorts m-sort so) | |
| 977 | sorts :test #'eq)) | |
| 978 | (and (= arg-pos 0) (or (method-is-error-method m) | |
| 979 | (method-is-universal m)))) | |
| 980 | (let ((pos (assoc m-sort res :test #'eq))) | |
| 981 | (declare (type list pos)) | |
| 982 | (if pos | |
| 983 | (push m (cdr pos)) | |
| 984 | (push (list m-sort m) res)))))))) | |
| 985 | (find-comparable (sort) | |
| 986 | (let ((res nil)) | |
| 987 | (declare (type list res)) | |
| 988 | (dolist (m list-of-method res) | |
| 989 | ;; (declare (type operator-method m)) | |
| 990 | (if (and (or (not (err-sort-p (method-coarity m))) | |
| 991 | (not (or (sort= (method-coarity m) *universal-sort*) | |
| 992 | (sort= (method-coarity m) *huniversal-sort*)))) | |
| 993 | (sort< sort (nth arg-pos (method-arity m)) so)) | |
| 994 | (push m res)))))) | |
| 995 | (let ((minimal-methods (get-minimal-methods))) | |
| 996 | (declare (type list minimal-methods)) | |
| 997 | ;;(debug-msg ("~%minimal-methods: ~s") minimal-methods) | |
| 998 | (let* ((num-entry (length minimal-methods)) | |
| 999 | (result (make-list num-entry))) | |
| 1000 | (declare (type fixnum num-entry) | |
| 1001 | (type list result)) | |
| 1002 | (dotimes (x num-entry) | |
| 1003 | (declare (type fixnum x)) | |
| 1004 | (let* ((s-ms (nth x minimal-methods)) | |
| 1005 | (comparable-methods (find-comparable (car s-ms)))) | |
| 1006 | (declare (type list s-ms comparable-methods)) | |
| 1007 | ;;(debug-msg ("~%comparable-methods: ~s") comparable-methods) | |
| 1008 | (setf (nth x result) | |
| 1009 | (cons (cons (car s-ms) | |
| 1010 | (if (= arg-pos (1- num-args)) | |
| 1011 | (cdr s-ms) | |
| 1012 | (make-method-table-internal | |
| 1013 | (append (cdr s-ms) comparable-methods) | |
| 1014 | (1+ arg-pos) | |
| 1015 | num-args | |
| 1016 | so))) | |
| 1017 | (if comparable-methods | |
| 1018 | (make-method-table-internal comparable-methods | |
| 1019 | arg-pos | |
| 1020 | num-args | |
| 1021 | so) | |
| 1022 | nil))))) | |
| 1023 | result))) | |
| 1024 | ))) | |
| 860 | (flet ((get-minimal-methods () | |
| 861 | (let ((sorts (mapcar #'(lambda (arity) (nth arg-pos arity)) | |
| 862 | (mapcar #'(lambda (x) (method-arity x)) | |
| 863 | list-of-method))) | |
| 864 | (res nil)) | |
| 865 | (declare (type list sorts res)) | |
| 866 | (dolist (m list-of-method res) | |
| 867 | ;; (declare (type operator-method m)) | |
| 868 | (let ((m-sort (nth arg-pos (method-arity m)))) | |
| 869 | (when (or (not (intersection (subsorts m-sort so) | |
| 870 | sorts :test #'eq)) | |
| 871 | (and (= arg-pos 0) (or (method-is-error-method m) | |
| 872 | (method-is-universal m)))) | |
| 873 | (let ((pos (assoc m-sort res :test #'eq))) | |
| 874 | (declare (type list pos)) | |
| 875 | (if pos | |
| 876 | (push m (cdr pos)) | |
| 877 | (push (list m-sort m) res)))))))) | |
| 878 | (find-comparable (sort) | |
| 879 | (let ((res nil)) | |
| 880 | (declare (type list res)) | |
| 881 | (dolist (m list-of-method res) | |
| 882 | ;; (declare (type operator-method m)) | |
| 883 | (if (and (or (not (err-sort-p (method-coarity m))) | |
| 884 | (not (or (sort= (method-coarity m) *universal-sort*) | |
| 885 | (sort= (method-coarity m) *huniversal-sort*)))) | |
| 886 | (sort< sort (nth arg-pos (method-arity m)) so)) | |
| 887 | (push m res)))))) | |
| 888 | (let ((minimal-methods (get-minimal-methods))) | |
| 889 | (declare (type list minimal-methods)) | |
| 890 | (let* ((num-entry (length minimal-methods)) | |
| 891 | (result (make-list num-entry))) | |
| 892 | (declare (type fixnum num-entry) | |
| 893 | (type list result)) | |
| 894 | (dotimes (x num-entry) | |
| 895 | (declare (type fixnum x)) | |
| 896 | (let* ((s-ms (nth x minimal-methods)) | |
| 897 | (comparable-methods (find-comparable (car s-ms)))) | |
| 898 | (declare (type list s-ms comparable-methods)) | |
| 899 | (setf (nth x result) | |
| 900 | (cons (cons (car s-ms) | |
| 901 | (if (= arg-pos (1- num-args)) | |
| 902 | (cdr s-ms) | |
| 903 | (make-method-table-internal | |
| 904 | (append (cdr s-ms) comparable-methods) | |
| 905 | (1+ arg-pos) | |
| 906 | num-args | |
| 907 | so))) | |
| 908 | (if comparable-methods | |
| 909 | (make-method-table-internal comparable-methods | |
| 910 | arg-pos | |
| 911 | num-args | |
| 912 | so) | |
| 913 | nil))))) | |
| 914 | result)))))) | |
| 1025 | 915 | |
| 1026 | ||
| 916 | ||
| 1027 | 917 | ;;; FIND-OPERATOR-METHOD operator arg-sort-list & optional opinfo-table sort-order |
| 1028 | 918 | ;;; |
| 1029 | 919 | (defmacro find-operator-method (?__?op ?__?arg-sort-list |
| 1030 | &optional | |
| 1031 | ;; (opinfo-table '*current-opinfo-table*) | |
| 1032 | (??_??sort-order '*current-sort-order*)) | |
| 920 | &optional | |
| 921 | ;; (opinfo-table '*current-opinfo-table*) | |
| 922 | (??_??sort-order '*current-sort-order*)) | |
| 1033 | 923 | `(find-method-in-table ,?__?arg-sort-list |
| 1034 | 924 | (operator-method-table ,?__?op) |
| 1035 | 925 | ,??_??sort-order)) |
| 1038 | 928 | ;;; |
| 1039 | 929 | (defun find-method-in-table (sort-list method-table sort-order &aux (method nil)) |
| 1040 | 930 | (declare (type list sort-list) |
| 1041 | (type list method-table) | |
| 1042 | (type hash-table sort-order)) | |
| 931 | (type list method-table) | |
| 932 | (type hash-table sort-order)) | |
| 1043 | 933 | (if sort-list |
| 1044 | 934 | (block find |
| 1045 | (dolist (method-entry method-table) | |
| 1046 | ;; check for each incomparable ranks. | |
| 1047 | (cond ((sort<= (car sort-list) (caar method-entry) sort-order) | |
| 1048 | (if (operator-method-p (car (cdar method-entry))) | |
| 1049 | (return-from find (cdar method-entry)) | |
| 1050 | (setf method (find-method-in-table (cdr sort-list) | |
| 1051 | (cdar method-entry) | |
| 1052 | sort-order))) | |
| 1053 | (when method (return-from find method))) | |
| 1054 | (t (setf method | |
| 1055 | (find-method-in-table sort-list (cdr method-entry) sort-order)) | |
| 1056 | (when method (return-from find method)) | |
| 1057 | )))) | |
| 935 | (dolist (method-entry method-table) | |
| 936 | ;; check for each incomparable ranks. | |
| 937 | (cond ((sort<= (car sort-list) (caar method-entry) sort-order) | |
| 938 | (if (operator-method-p (car (cdar method-entry))) | |
| 939 | (return-from find (cdar method-entry)) | |
| 940 | (setf method (find-method-in-table (cdr sort-list) | |
| 941 | (cdar method-entry) | |
| 942 | sort-order))) | |
| 943 | (when method (return-from find method))) | |
| 944 | (t (setf method | |
| 945 | (find-method-in-table sort-list (cdr method-entry) sort-order)) | |
| 946 | (when method (return-from find method)) | |
| 947 | )))) | |
| 1058 | 948 | ;; constant. only one method. |
| 1059 | method-table | |
| 1060 | )) | |
| 1061 | ||
| 949 | method-table)) | |
| 950 | ||
| 1062 | 951 | ;;; ***************** |
| 1063 | 952 | ;;; ADDING NEW METHOD___________________________________________________________ |
| 1064 | 953 | ;;; ***************** |
| 1070 | 959 | ;;; They are declared separately with operator declarations. |
| 1071 | 960 | ;;; |
| 1072 | 961 | (defun add-operator-declaration-to-table (opinfo |
| 1073 | arity | |
| 1074 | coarity | |
| 1075 | &optional | |
| 1076 | (module | |
| 1077 | (or *current-module* *last-module*)) | |
| 1078 | constructor | |
| 1079 | behavioural | |
| 1080 | coherent | |
| 1081 | error-operator) | |
| 962 | arity | |
| 963 | coarity | |
| 964 | &optional | |
| 965 | (module (get-context-module)) | |
| 966 | constructor | |
| 967 | behavioural | |
| 968 | coherent | |
| 969 | error-operator) | |
| 1082 | 970 | (declare (type list opinfo arity) |
| 1083 | (type sort-struct coarity) | |
| 1084 | (type module module) | |
| 1085 | (type (or null t) | |
| 1086 | constructor | |
| 1087 | behavioural | |
| 1088 | coherent | |
| 1089 | error-operator) | |
| 1090 | (values (or null t) method)) | |
| 971 | (type sort-struct coarity) | |
| 972 | (type module module)) | |
| 1091 | 973 | ;; |
| 1092 | 974 | (let ((meth nil)) |
| 1093 | 975 | (dolist (m (opinfo-methods opinfo)) |
| 1094 | 976 | (when (and (sort-list= (method-arity m) arity) |
| 1095 | (sort= (method-coarity m) coarity)) | |
| 1096 | (setq meth m) | |
| 1097 | (return nil))) | |
| 977 | (sort= (method-coarity m) coarity)) | |
| 978 | (setq meth m) | |
| 979 | (return nil))) | |
| 1098 | 980 | (when (and meth |
| 1099 | (not (eq (method-name meth ) | |
| 1100 | (method-name *beh-equal*))) | |
| 1101 | (not (method-is-error-method meth))) | |
| 1102 | ;; (and meth *on-operator-debug*) | |
| 981 | (not (eq (method-name meth ) | |
| 982 | (method-name *beh-equal*))) | |
| 983 | (not (method-is-error-method meth))) | |
| 1103 | 984 | (with-output-chaos-warning () |
| 1104 | (format t "the operator of the same rank has already been declared: ") | |
| 1105 | (print-next) | |
| 1106 | (print-chaos-object meth) | |
| 1107 | (print-next) | |
| 1108 | (format t "~%... ignored.") | |
| 1109 | ;; (print-next) | |
| 1110 | ;; (format t "ignoring this one.") | |
| 1111 | ) | |
| 1112 | #|| | |
| 1113 | (return-from add-operator-declaration-to-table | |
| 1114 | (values nil meth)) | |
| 1115 | ||# | |
| 1116 | ) | |
| 985 | (format t "the operator of the same rank has already been declared: ") | |
| 986 | (print-next) | |
| 987 | (print-chaos-object meth) | |
| 988 | (print-next) | |
| 989 | (format t "~%... ignored."))) | |
| 1117 | 990 | (let ((operator (opinfo-operator opinfo))) |
| 1118 | 991 | (declare (type operator operator)) |
| 1119 | 992 | (when (and meth (not (eq (method-module meth) module))) |
| 1120 | (when (and (not (method-constructor meth)) | |
| 1121 | constructor) | |
| 1122 | (with-output-chaos-warning () | |
| 1123 | (princ "operator ") | |
| 1124 | (print-chaos-object meth) | |
| 1125 | (print-next) | |
| 1126 | (princ "was NOT constructor in module ") | |
| 1127 | (print-simple-mod-name (method-module meth)) | |
| 1128 | (print-next) | |
| 1129 | (princ "but being declared as constructor in ") | |
| 1130 | (print-simple-mod-name module) | |
| 1131 | (print-next) | |
| 1132 | (princ "ignoring `constr' attribute."))) | |
| 1133 | (unless (eq (method-is-behavioural meth) behavioural) | |
| 1134 | (with-output-chaos-warning () | |
| 1135 | (princ "operator ") | |
| 1136 | (print-chaos-object meth) | |
| 1137 | (print-next) | |
| 1138 | (princ "cannot be behvioural and not at the same time") | |
| 1139 | (print-next) | |
| 1140 | (princ "ignoring ..."))) | |
| 1141 | (when (and (not (method-is-coherent meth)) coherent) | |
| 1142 | (with-output-chaos-warning () | |
| 1143 | (princ "operator ") | |
| 1144 | (print-chaos-object meth) | |
| 1145 | (print-next) | |
| 1146 | (princ "was not coherent in module ") | |
| 1147 | (print-simple-mod-name (method-module meth)) | |
| 1148 | (print-next) | |
| 1149 | (princ "but being declared as coherent in ") | |
| 1150 | (print-simple-mod-name module) | |
| 1151 | #|| | |
| 1152 | (print-next) | |
| 1153 | (princ "ignoring this `coherent' attribute.") | |
| 1154 | ||# | |
| 1155 | ))) | |
| 993 | ;; the method is the imported one | |
| 994 | (when (and (not (method-constructor meth)) | |
| 995 | constructor) | |
| 996 | (with-output-chaos-warning () | |
| 997 | (princ "operator ") | |
| 998 | (print-chaos-object meth) | |
| 999 | (print-next) | |
| 1000 | (princ "was NOT constructor in module ") | |
| 1001 | (print-simple-mod-name (method-module meth)) | |
| 1002 | (print-next) | |
| 1003 | (princ "but being declared as constructor in ") | |
| 1004 | (print-simple-mod-name module) | |
| 1005 | (print-next) | |
| 1006 | (princ "ignoring `constr' attribute."))) | |
| 1007 | (unless (eq (method-is-behavioural meth) behavioural) | |
| 1008 | (with-output-chaos-warning () | |
| 1009 | (princ "operator ") | |
| 1010 | (print-chaos-object meth) | |
| 1011 | (print-next) | |
| 1012 | (princ "cannot be behvioural and not at the same time") | |
| 1013 | (print-next) | |
| 1014 | (princ "ignoring ..."))) | |
| 1015 | (when (and (not (method-is-coherent meth)) coherent) | |
| 1016 | (with-output-chaos-warning () | |
| 1017 | (princ "operator ") | |
| 1018 | (print-chaos-object meth) | |
| 1019 | (print-next) | |
| 1020 | (princ "was not coherent in module ") | |
| 1021 | (print-simple-mod-name (method-module meth)) | |
| 1022 | (print-next) | |
| 1023 | (princ "but being declared as coherent in ") | |
| 1024 | (print-simple-mod-name module)))) | |
| 1156 | 1025 | (unless meth |
| 1157 | (setq meth (make-operator-method :name (operator-name operator) | |
| 1158 | :arity arity | |
| 1159 | :coarity coarity | |
| 1160 | ))) | |
| 1026 | (setq meth (make-operator-method :name (operator-name operator) | |
| 1027 | :arity arity | |
| 1028 | :coarity coarity))) | |
| 1161 | 1029 | (when (eq (method-module meth) module) |
| 1162 | (setf (method-constructor meth) constructor) | |
| 1163 | (setf (method-is-behavioural meth) behavioural) | |
| 1164 | ;; (setf (method-is-coherent meth) coherent) | |
| 1165 | (setf (method-is-user-defined-error-method meth) | |
| 1166 | error-operator)) | |
| 1030 | (setf (method-constructor meth) constructor) | |
| 1031 | (setf (method-is-behavioural meth) behavioural) | |
| 1032 | (setf (method-is-user-defined-error-method meth) | |
| 1033 | error-operator)) | |
| 1167 | 1034 | ;; |
| 1168 | 1035 | (let ((res1 (add-method-to-table opinfo meth module))) |
| 1169 | (setf (method-is-coherent meth) coherent) | |
| 1170 | (when constructor | |
| 1171 | (pushnew meth (sort-constructors (method-coarity meth)) | |
| 1172 | :test #'eq)) | |
| 1173 | ;; | |
| 1174 | (values res1 meth))))) | |
| 1036 | (setf (method-is-coherent meth) coherent) | |
| 1037 | (when constructor | |
| 1038 | (pushnew meth (sort-constructors (method-coarity meth)) | |
| 1039 | :test #'eq)) | |
| 1040 | ;; | |
| 1041 | (values res1 meth))))) | |
| 1175 | 1042 | |
| 1176 | 1043 | ;;; ADD-METHOD-TO-TABLE : OPINFO METHOD -> Bool |
| 1177 | 1044 | ;;;----------------------------------------------------------------------------- |
| 1178 | 1045 | |
| 1179 | 1046 | (defun add-method-to-table (opinfo method module) |
| 1180 | 1047 | (declare (type list opinfo) |
| 1181 | (type method method) | |
| 1182 | (type module module) | |
| 1183 | (values (or null t))) | |
| 1048 | (type method method) | |
| 1049 | (type module module) | |
| 1050 | (values (or null t))) | |
| 1184 | 1051 | (let ((method-info-table (module-opinfo-table module))) |
| 1185 | 1052 | (declare (type hash-table method-info-table)) |
| 1186 | 1053 | (if (not (find method (opinfo-methods opinfo) |
| 1187 | :test #'(lambda (x y) | |
| 1188 | (declare (type method x y)) | |
| 1189 | (and (sort-list= (method-arity x) | |
| 1190 | (method-arity y)) | |
| 1191 | (sort= (method-coarity x) | |
| 1192 | (method-coarity y)))))) | |
| 1193 | (progn | |
| 1194 | (when *on-operator-debug* | |
| 1195 | (format t "~& - add ") | |
| 1196 | (print-method method) | |
| 1197 | (format t " ==> ~a." | |
| 1198 | (operator-symbol (opinfo-operator opinfo))) | |
| 1199 | (print-mod-name (operator-module (opinfo-operator opinfo)))) | |
| 1200 | (setf (get-method-info method method-info-table) | |
| 1201 | (make-method-info method | |
| 1202 | module ; was *current-module* | |
| 1203 | (opinfo-operator opinfo))) | |
| 1204 | (push method (opinfo-methods opinfo)) | |
| 1205 | (setf (opinfo-method-table opinfo) nil) | |
| 1206 | (when (and (some #'(lambda (x) (sort-is-hidden x)) | |
| 1207 | (method-arity method)) | |
| 1208 | (or (method-is-user-defined-error-method method) | |
| 1209 | (not (method-is-error-method method)))) | |
| 1210 | (if (method-is-behavioural method) | |
| 1211 | (if (sort-is-hidden (method-coarity method)) | |
| 1212 | (push method (module-beh-methods module)) | |
| 1213 | (push method (module-beh-attributes module))) | |
| 1214 | (if (sort-is-hidden (method-coarity method)) | |
| 1215 | (push method (module-non-beh-methods module)) | |
| 1216 | (push method (module-non-beh-attributes module))))) | |
| 1217 | t) | |
| 1054 | :test #'(lambda (x y) | |
| 1055 | (declare (type method x y)) | |
| 1056 | (and (sort-list= (method-arity x) | |
| 1057 | (method-arity y)) | |
| 1058 | (sort= (method-coarity x) | |
| 1059 | (method-coarity y)))))) | |
| 1060 | (progn | |
| 1061 | (when *on-operator-debug* | |
| 1062 | (format t "~% - add ") | |
| 1063 | (print-method method) | |
| 1064 | (format t " ==> ~a." | |
| 1065 | (operator-symbol (opinfo-operator opinfo))) | |
| 1066 | (print-mod-name (operator-module (opinfo-operator opinfo)))) | |
| 1067 | (setf (get-method-info method method-info-table) | |
| 1068 | (make-method-info method | |
| 1069 | module ; was *current-module* | |
| 1070 | (opinfo-operator opinfo))) | |
| 1071 | (push method (opinfo-methods opinfo)) | |
| 1072 | (setf (opinfo-method-table opinfo) nil) | |
| 1073 | (when (and (some #'(lambda (x) (sort-is-hidden x)) | |
| 1074 | (method-arity method)) | |
| 1075 | (or (method-is-user-defined-error-method method) | |
| 1076 | (not (method-is-error-method method)))) | |
| 1077 | (if (method-is-behavioural method) | |
| 1078 | (if (sort-is-hidden (method-coarity method)) | |
| 1079 | (push method (module-beh-methods module)) | |
| 1080 | (push method (module-beh-attributes module))) | |
| 1081 | (if (sort-is-hidden (method-coarity method)) | |
| 1082 | (push method (module-non-beh-methods module)) | |
| 1083 | (push method (module-non-beh-attributes module))))) | |
| 1084 | t) | |
| 1218 | 1085 | nil))) |
| 1219 | 1086 | |
| 1220 | 1087 | (defun add-method-to-table-fast (opinfo method module) |
| 1221 | 1088 | (declare (type list opinfo) |
| 1222 | (type method method) | |
| 1223 | (type module module) | |
| 1224 | (values t)) | |
| 1089 | (type method method) | |
| 1090 | (type module module) | |
| 1091 | (values t)) | |
| 1225 | 1092 | (let ((method-info-table (module-opinfo-table module))) |
| 1226 | 1093 | (when *on-operator-debug* |
| 1227 | (format t "~& - add ") | |
| 1094 | (format t "~% - add ") | |
| 1228 | 1095 | (print-method method) |
| 1229 | 1096 | (format t " ==> ~a." |
| 1230 | (operator-symbol (opinfo-operator opinfo))) | |
| 1097 | (operator-symbol (opinfo-operator opinfo))) | |
| 1231 | 1098 | (print-mod-name (operator-module (opinfo-operator opinfo)))) |
| 1232 | 1099 | (unless (get-method-info method method-info-table) |
| 1233 | 1100 | (setf (get-method-info method method-info-table) |
| 1234 | (make-method-info method | |
| 1235 | module | |
| 1236 | (opinfo-operator opinfo)))) | |
| 1101 | (make-method-info method | |
| 1102 | module | |
| 1103 | (opinfo-operator opinfo)))) | |
| 1237 | 1104 | (setf (opinfo-method-table opinfo) nil) |
| 1238 | 1105 | (when (and (some #'(lambda (x) (sort-is-hidden x)) (method-arity method)) |
| 1239 | (or (method-is-user-defined-error-method method) | |
| 1240 | (not (method-is-error-method method)))) | |
| 1106 | (or (method-is-user-defined-error-method method) | |
| 1107 | (not (method-is-error-method method)))) | |
| 1241 | 1108 | (if (method-is-behavioural method) |
| 1242 | (if (sort-is-hidden (method-coarity method)) | |
| 1243 | (pushnew method (module-beh-methods module) :test #'eq) | |
| 1244 | (pushnew method (module-beh-attributes module) :test #'eq)) | |
| 1245 | (if (sort-is-hidden (method-coarity method)) | |
| 1246 | (pushnew method (module-non-beh-methods module) :test #'eq) | |
| 1247 | (pushnew method (module-non-beh-attributes module) :test #'eq)) | |
| 1248 | )) | |
| 1249 | (pushnew method (opinfo-methods opinfo) :test #'eq) | |
| 1250 | )) | |
| 1109 | (if (sort-is-hidden (method-coarity method)) | |
| 1110 | (pushnew method (module-beh-methods module) :test #'eq) | |
| 1111 | (pushnew method (module-beh-attributes module) :test #'eq)) | |
| 1112 | (if (sort-is-hidden (method-coarity method)) | |
| 1113 | (pushnew method (module-non-beh-methods module) :test #'eq) | |
| 1114 | (pushnew method (module-non-beh-attributes module) :test #'eq)))) | |
| 1115 | (pushnew method (opinfo-methods opinfo) :test #'eq))) | |
| 1251 | 1116 | |
| 1252 | 1117 | (defun add-method-to-table-very-fast (opinfo method module) |
| 1253 | 1118 | (declare (type list opinfo) |
| 1254 | (type method method) | |
| 1255 | (type module module) | |
| 1256 | (values t)) | |
| 1119 | (type method method) | |
| 1120 | (type module module) | |
| 1121 | (values t)) | |
| 1257 | 1122 | (when (and (some #'(lambda (x) (sort-is-hidden x)) (method-arity method)) |
| 1258 | (or (method-is-user-defined-error-method method) | |
| 1259 | (not (method-is-error-method method)))) | |
| 1123 | (or (method-is-user-defined-error-method method) | |
| 1124 | (not (method-is-error-method method)))) | |
| 1260 | 1125 | (if (method-is-behavioural method) |
| 1261 | (if (sort-is-hidden (method-coarity method)) | |
| 1262 | (push method (module-beh-methods module)) | |
| 1263 | (push method (module-beh-attributes module))) | |
| 1126 | (if (sort-is-hidden (method-coarity method)) | |
| 1127 | (push method (module-beh-methods module)) | |
| 1128 | (push method (module-beh-attributes module))) | |
| 1264 | 1129 | (if (sort-is-hidden (method-coarity method)) |
| 1265 | (push method (module-non-beh-methods module)) | |
| 1266 | (push method (module-non-beh-attributes module))))) | |
| 1267 | (push method (opinfo-methods opinfo)) | |
| 1268 | ) | |
| 1130 | (push method (module-non-beh-methods module)) | |
| 1131 | (push method (module-non-beh-attributes module))))) | |
| 1132 | (push method (opinfo-methods opinfo))) | |
| 1269 | 1133 | |
| 1270 | 1134 | ;;; |
| 1271 | 1135 | ;;; RECREATE-METHOD |
| 1274 | 1138 | ;;; new method. |
| 1275 | 1139 | ;;; ************************************************************ |
| 1276 | 1140 | (defun recreate-method (old-module meth |
| 1277 | new-module | |
| 1278 | op-symbol | |
| 1279 | arity | |
| 1280 | coarity &optional sort-map) | |
| 1141 | new-module | |
| 1142 | op-symbol | |
| 1143 | arity | |
| 1144 | coarity &optional sort-map) | |
| 1281 | 1145 | (let (sup-strat |
| 1282 | theory | |
| 1283 | prec | |
| 1284 | assoc | |
| 1285 | constr | |
| 1286 | behavioural | |
| 1287 | coherent | |
| 1288 | memo | |
| 1289 | id-symbol | |
| 1290 | meta-demod | |
| 1291 | error-operator) | |
| 1146 | theory | |
| 1147 | prec | |
| 1148 | assoc | |
| 1149 | constr | |
| 1150 | behavioural | |
| 1151 | coherent | |
| 1152 | memo | |
| 1153 | id-symbol | |
| 1154 | meta-demod | |
| 1155 | error-operator) | |
| 1292 | 1156 | (with-in-module (old-module) |
| 1293 | 1157 | (setq sup-strat (method-supplied-strategy meth) |
| 1294 | theory (method-theory meth) | |
| 1295 | prec (get-method-precedence meth) | |
| 1296 | assoc (method-associativity meth) | |
| 1297 | constr (method-constructor meth) | |
| 1298 | behavioural (method-behavioural meth) | |
| 1299 | coherent (method-coherent meth) | |
| 1300 | memo (method-has-memo meth) | |
| 1301 | meta-demod (method-is-meta-demod meth) | |
| 1302 | id-symbol (method-id-symbol meth) | |
| 1303 | error-operator (method-is-user-defined-error-method | |
| 1304 | meth))) | |
| 1158 | theory (method-theory meth) | |
| 1159 | prec (get-method-precedence meth) | |
| 1160 | assoc (method-associativity meth) | |
| 1161 | constr (method-constructor meth) | |
| 1162 | behavioural (method-behavioural meth) | |
| 1163 | coherent (method-coherent meth) | |
| 1164 | memo (method-has-memo meth) | |
| 1165 | meta-demod (method-is-meta-demod meth) | |
| 1166 | id-symbol (method-id-symbol meth) | |
| 1167 | error-operator (method-is-user-defined-error-method | |
| 1168 | meth))) | |
| 1305 | 1169 | (with-in-module (new-module) |
| 1306 | 1170 | (when error-operator |
| 1307 | (let* ((o-arity (method-arity meth)) | |
| 1308 | (len (length o-arity)) | |
| 1309 | (new-arity (copy-list arity))) | |
| 1310 | (dotimes (x len) | |
| 1311 | (when (err-sort-p (nth x o-arity)) | |
| 1312 | (setf (nth x new-arity) | |
| 1313 | (find-compatible-err-sort (nth x o-arity) | |
| 1314 | new-module | |
| 1315 | sort-map)))) | |
| 1316 | (setq arity new-arity) | |
| 1317 | (when (err-sort-p (method-coarity meth)) | |
| 1318 | (setq coarity (find-compatible-err-sort (method-coarity meth) | |
| 1319 | new-module | |
| 1320 | sort-map))))) | |
| 1171 | (let* ((o-arity (method-arity meth)) | |
| 1172 | (len (length o-arity)) | |
| 1173 | (new-arity (copy-list arity))) | |
| 1174 | (dotimes (x len) | |
| 1175 | (when (err-sort-p (nth x o-arity)) | |
| 1176 | (setf (nth x new-arity) | |
| 1177 | (find-compatible-err-sort (nth x o-arity) | |
| 1178 | new-module | |
| 1179 | sort-map)))) | |
| 1180 | (setq arity new-arity) | |
| 1181 | (when (err-sort-p (method-coarity meth)) | |
| 1182 | (setq coarity (find-compatible-err-sort (method-coarity meth) | |
| 1183 | new-module | |
| 1184 | sort-map))))) | |
| 1321 | 1185 | ;; |
| 1322 | 1186 | (multiple-value-bind (newop newmeth) |
| 1323 | (declare-operator-in-module op-symbol | |
| 1324 | arity | |
| 1325 | coarity | |
| 1326 | new-module | |
| 1327 | constr | |
| 1328 | behavioural | |
| 1329 | coherent | |
| 1330 | error-operator) | |
| 1331 | (declare (ignore newop)) | |
| 1332 | (setf (method-supplied-strategy newmeth) sup-strat | |
| 1333 | (method-precedence newmeth) prec | |
| 1334 | (method-associativity newmeth) assoc) | |
| 1335 | (setf (method-derived-from newmeth) meth) | |
| 1336 | (setf (method-has-memo newmeth) memo) | |
| 1337 | (setf (method-is-meta-demod newmeth) meta-demod) | |
| 1338 | (setf (method-id-symbol newmeth) id-symbol) | |
| 1339 | ;; | |
| 1340 | ;; check identity in theory | |
| 1341 | (if (theory-contains-identity theory) | |
| 1342 | (let ((zero (theory-zero theory))) | |
| 1343 | (setq zero (cons '%to-rename zero)) | |
| 1344 | (setf (method-theory newmeth) | |
| 1345 | (theory-make (theory-info theory) zero)) | |
| 1346 | (compute-method-theory-info-for-matching newmeth) | |
| 1347 | ) | |
| 1348 | ;; | |
| 1349 | (progn | |
| 1350 | (setf (method-theory newmeth) theory) | |
| 1351 | (compute-method-theory-info-for-matching newmeth) | |
| 1352 | )) | |
| 1353 | ;; | |
| 1354 | newmeth)))) | |
| 1355 | ||
| 1187 | (declare-operator-in-module op-symbol | |
| 1188 | arity | |
| 1189 | coarity | |
| 1190 | new-module | |
| 1191 | constr | |
| 1192 | behavioural | |
| 1193 | coherent | |
| 1194 | error-operator) | |
| 1195 | (declare (ignore newop)) | |
| 1196 | (setf (method-supplied-strategy newmeth) sup-strat | |
| 1197 | (method-precedence newmeth) prec | |
| 1198 | (method-associativity newmeth) assoc) | |
| 1199 | (setf (method-derived-from newmeth) meth) | |
| 1200 | (setf (method-has-memo newmeth) memo) | |
| 1201 | (setf (method-is-meta-demod newmeth) meta-demod) | |
| 1202 | (setf (method-id-symbol newmeth) id-symbol) | |
| 1203 | ;; | |
| 1204 | ;; check identity in theory | |
| 1205 | (if (theory-contains-identity theory) | |
| 1206 | (let ((zero (theory-zero theory))) | |
| 1207 | (setq zero (cons '%to-rename zero)) | |
| 1208 | (setf (method-theory newmeth) | |
| 1209 | (theory-make (theory-info theory) zero)) | |
| 1210 | (compute-method-theory-info-for-matching newmeth) | |
| 1211 | ) | |
| 1212 | ;; | |
| 1213 | (progn | |
| 1214 | (setf (method-theory newmeth) theory) | |
| 1215 | (compute-method-theory-info-for-matching newmeth))) | |
| 1216 | ;; | |
| 1217 | newmeth)))) | |
| 1218 | ||
| 1356 | 1219 | ;;; ****************************** |
| 1357 | 1220 | ;;; PREPARATIONS FOR PARSING TERMS______________________________________________ |
| 1358 | 1221 | ;;; ****************************** |
| 1372 | 1235 | ;;; |
| 1373 | 1236 | (defun method< (meth1 meth2 &optional (so *current-sort-order*)) |
| 1374 | 1237 | (declare (type method meth1 meth2) |
| 1375 | (type hash-table so) | |
| 1376 | (values (or null t))) | |
| 1238 | (type hash-table so) | |
| 1239 | (values (or null t))) | |
| 1377 | 1240 | (let ((coar1 (method-coarity meth1)) |
| 1378 | (coar2 (method-coarity meth2))) | |
| 1241 | (coar2 (method-coarity meth2))) | |
| 1379 | 1242 | (or (sort< coar2 coar1 so) |
| 1380 | (and (sort= coar1 coar2) | |
| 1381 | (sort-list<= (method-arity meth2) (method-arity meth1) so))) | |
| 1382 | )) | |
| 1243 | (and (sort= coar1 coar2) | |
| 1244 | (sort-list<= (method-arity meth2) (method-arity meth1) so))))) | |
| 1383 | 1245 | |
| 1384 | 1246 | ;;; |
| 1385 | 1247 | ;;; DELETE-ERROR-OPERATORS-IN |
| 1386 | 1248 | ;;; |
| 1387 | (defun delete-error-operators-in (&optional (module (or *current-module* | |
| 1388 | *last-module*))) | |
| 1249 | (defun delete-error-operators-in (&optional (module (get-context-module))) | |
| 1389 | 1250 | (declare (type module module) |
| 1390 | (values t)) | |
| 1251 | (values t)) | |
| 1391 | 1252 | (let ((minfo (module-opinfo-table module)) |
| 1392 | (err-ops nil)) | |
| 1253 | (err-ops nil)) | |
| 1393 | 1254 | (maphash #'(lambda (meth info) |
| 1394 | (declare (ignore info)) | |
| 1395 | (when (and (method-is-error-method meth) | |
| 1396 | (not (method-is-user-defined-error-method meth))) | |
| 1397 | (push meth err-ops))) | |
| 1398 | minfo) | |
| 1255 | (declare (ignore info)) | |
| 1256 | (when (and (method-is-error-method meth) | |
| 1257 | (not (method-is-user-defined-error-method meth))) | |
| 1258 | (push meth err-ops))) | |
| 1259 | minfo) | |
| 1399 | 1260 | (dolist (m err-ops) |
| 1400 | 1261 | (remhash m minfo)) |
| 1401 | 1262 | (dolist (opinfo (module-all-operators module)) |
| 1402 | 1263 | (setf (opinfo-methods opinfo) |
| 1403 | (delete-if #'(lambda (x) | |
| 1404 | (and (method-is-error-method x) | |
| 1405 | (not (method-is-user-defined-error-method x)))) | |
| 1406 | (opinfo-methods opinfo)))) | |
| 1407 | )) | |
| 1264 | (delete-if #'(lambda (x) | |
| 1265 | (and (method-is-error-method x) | |
| 1266 | (not (method-is-user-defined-error-method x)))) | |
| 1267 | (opinfo-methods opinfo)))))) | |
| 1408 | 1268 | |
| 1409 | 1269 | ;;; |
| 1410 | 1270 | ;;; MAKE-OPERATOR-CLUSTERS-IN |
| 1411 | 1271 | ;;; |
| 1412 | (defun make-operator-clusters-in (&optional (module (or *current-module* | |
| 1413 | *last-module*))) | |
| 1272 | (defun make-operator-clusters-in (&optional (module (get-context-module))) | |
| 1414 | 1273 | (declare (type module module) |
| 1415 | (values t)) | |
| 1274 | (values t)) | |
| 1416 | 1275 | (let ((result nil) |
| 1417 | (infos (module-all-operators module)) | |
| 1418 | (sort-order (module-sort-order module))) | |
| 1276 | (infos (module-all-operators module)) | |
| 1277 | (sort-order (module-sort-order module))) | |
| 1419 | 1278 | (when *on-operator-debug* |
| 1420 | 1279 | (format t "~%**-- all operators in module: ") |
| 1421 | 1280 | (print-chaos-object infos)) |
| 1422 | 1281 | (do* ((op-infos infos (cdr op-infos)) |
| 1423 | (info (car op-infos) (car op-infos))) | |
| 1424 | ((endp op-infos)) | |
| 1282 | (info (car op-infos) (car op-infos))) | |
| 1283 | ((endp op-infos)) | |
| 1425 | 1284 | (when (opinfo-methods info) |
| 1426 | (let ((proto-method nil) | |
| 1427 | (name nil) | |
| 1428 | (coar nil)) | |
| 1429 | (setq proto-method | |
| 1430 | (or (find-if #'(lambda (x) (method-is-universal* x)) | |
| 1431 | (opinfo-methods info)) | |
| 1432 | (find-if #'(lambda (x) (method-is-error-method x)) | |
| 1433 | (opinfo-methods info)) | |
| 1434 | (car (opinfo-methods info)))) | |
| 1435 | (setq name (method-name proto-method)) | |
| 1436 | (setq coar (method-coarity proto-method)) | |
| 1437 | (when *on-operator-debug* | |
| 1438 | (format t "~%-- proto-method = ") | |
| 1439 | (print-chaos-object proto-method) | |
| 1440 | (format t "~% name = ~s" name) | |
| 1441 | (format t "~% coar = ") | |
| 1442 | (print-chaos-object coar)) | |
| 1443 | (let ((pre (find-if #'(lambda (x) | |
| 1444 | (let ((m (car (opinfo-methods x)))) | |
| 1445 | (and (equal (method-name m) name) | |
| 1446 | (or (equal name | |
| 1447 | '(("if" "_" "then" "_" | |
| 1448 | "else" "_" "fi") | |
| 1449 | . 3)) | |
| 1450 | (is-in-same-connected-component | |
| 1451 | (method-coarity m) | |
| 1452 | coar | |
| 1453 | sort-order))))) | |
| 1454 | result))) | |
| 1455 | (if pre | |
| 1456 | (progn | |
| 1457 | (when *on-operator-debug* | |
| 1458 | (let ((*print-indent* (+ 2 *print-indent*))) | |
| 1459 | (format t "~%** merging operators : ") | |
| 1460 | (print-next) | |
| 1461 | (princ "- pre = ") | |
| 1462 | (print-chaos-object pre) | |
| 1463 | (print-next) | |
| 1464 | (princ "- with : ") | |
| 1465 | (print-chaos-object info))) | |
| 1466 | (setf (opinfo-methods pre) | |
| 1467 | (delete-duplicates | |
| 1468 | (nconc (opinfo-methods pre) | |
| 1469 | (opinfo-methods info)))) | |
| 1470 | (when *on-operator-debug* | |
| 1471 | (let ((*print-indent* (+ 2 *print-indent*))) | |
| 1472 | (fresh-line) | |
| 1473 | (princ "-- the result : ") | |
| 1474 | (print-chaos-object pre))) | |
| 1475 | ) | |
| 1476 | (push info result)))))) | |
| 1285 | (let ((proto-method nil) | |
| 1286 | (name nil) | |
| 1287 | (coar nil)) | |
| 1288 | (setq proto-method | |
| 1289 | (or (find-if #'(lambda (x) (method-is-universal* x)) | |
| 1290 | (opinfo-methods info)) | |
| 1291 | (find-if #'(lambda (x) (method-is-error-method x)) | |
| 1292 | (opinfo-methods info)) | |
| 1293 | (car (opinfo-methods info)))) | |
| 1294 | (setq name (method-name proto-method)) | |
| 1295 | (setq coar (method-coarity proto-method)) | |
| 1296 | (when *on-operator-debug* | |
| 1297 | (format t "~%-- proto-method = ") | |
| 1298 | (print-chaos-object proto-method) | |
| 1299 | (format t "~% name = ~s" name) | |
| 1300 | (format t "~% coar = ") | |
| 1301 | (print-chaos-object coar)) | |
| 1302 | (let ((pre (find-if #'(lambda (x) | |
| 1303 | (let ((m (car (opinfo-methods x)))) | |
| 1304 | (and (equal (method-name m) name) | |
| 1305 | (or (equal name | |
| 1306 | '(("if" "_" "then" "_" | |
| 1307 | "else" "_" "fi") | |
| 1308 | . 3)) | |
| 1309 | (is-in-same-connected-component | |
| 1310 | (method-coarity m) | |
| 1311 | coar | |
| 1312 | sort-order))))) | |
| 1313 | result))) | |
| 1314 | (if pre | |
| 1315 | (progn | |
| 1316 | (when *on-operator-debug* | |
| 1317 | (let ((*print-indent* (+ 2 *print-indent*))) | |
| 1318 | (format t "~%** merging operators : ") | |
| 1319 | (print-next) | |
| 1320 | (princ "- pre = ") | |
| 1321 | (print-chaos-object pre) | |
| 1322 | (print-next) | |
| 1323 | (princ "- with : ") | |
| 1324 | (print-chaos-object info))) | |
| 1325 | (setf (opinfo-methods pre) | |
| 1326 | (delete-duplicates | |
| 1327 | (nconc (opinfo-methods pre) | |
| 1328 | (opinfo-methods info)))) | |
| 1329 | (when *on-operator-debug* | |
| 1330 | (let ((*print-indent* (+ 2 *print-indent*))) | |
| 1331 | (fresh-line) | |
| 1332 | (princ "-- the result : ") | |
| 1333 | (print-chaos-object pre)))) | |
| 1334 | (push info result)))))) | |
| 1477 | 1335 | ;; |
| 1478 | 1336 | (setf (module-all-operators module) |
| 1479 | (nreverse result)))) | |
| 1337 | (nreverse result)))) | |
| 1480 | 1338 | |
| 1481 | 1339 | ;;; METHOD-SELECT-MOST-GENERAL-VERSION-OF |
| 1482 | 1340 | ;;; used for computing method's syntactic properties for `simple-parser'. |
| 1484 | 1342 | ;;; |
| 1485 | 1343 | |
| 1486 | 1344 | (defun method-select-most-general-version-of (method methods |
| 1487 | sort-order | |
| 1488 | &rest ignore) | |
| 1489 | ; opinfo-table | |
| 1490 | ; &optional mod | |
| 1345 | sort-order | |
| 1346 | &rest ignore) | |
| 1347 | ; opinfo-table | |
| 1348 | ; &optional mod | |
| 1491 | 1349 | (declare (ignore ignore) |
| 1492 | (type method method) | |
| 1493 | (type list methods) | |
| 1494 | (type hash-table sort-order) | |
| 1495 | (values method)) | |
| 1350 | (type method method) | |
| 1351 | (type list methods) | |
| 1352 | (type hash-table sort-order) | |
| 1353 | (values method)) | |
| 1496 | 1354 | ;; |
| 1497 | 1355 | (let ((res-method method)) |
| 1498 | 1356 | (dolist (meth2 methods) |
| 1499 | 1357 | (when (or (and (method-is-universal meth2) |
| 1500 | (method-is-of-same-operator res-method meth2)) | |
| 1501 | (method-is-instance-of res-method meth2 sort-order)) | |
| 1502 | (setq res-method meth2))) | |
| 1358 | (method-is-of-same-operator res-method meth2)) | |
| 1359 | (method-is-instance-of res-method meth2 sort-order)) | |
| 1360 | (setq res-method meth2))) | |
| 1503 | 1361 | res-method)) |
| 1504 | 1362 | |
| 1505 | 1363 | ;;; METHOD-MOST-GENERAL-NO-ERROR methd method-list module |
| 1506 | 1364 | ;;; |
| 1507 | 1365 | (defun method-most-general-no-error (method methods |
| 1508 | &optional | |
| 1509 | (module (or *current-module* | |
| 1510 | *last-module*))) | |
| 1366 | &optional | |
| 1367 | (module (get-context-module))) | |
| 1511 | 1368 | (declare (type method method) |
| 1512 | (type list methods) | |
| 1513 | (type module module) | |
| 1514 | (values method)) | |
| 1369 | (type list methods) | |
| 1370 | (type module module) | |
| 1371 | (values method)) | |
| 1515 | 1372 | (let ((res-method method) |
| 1516 | (so (module-sort-order module))) | |
| 1373 | (so (module-sort-order module))) | |
| 1517 | 1374 | (dolist (meth2 methods) |
| 1518 | 1375 | (when (and (not (method-is-error-method meth2)) |
| 1519 | (method-is-instance-of res-method meth2 so)) | |
| 1520 | (setq res-method meth2))) | |
| 1376 | (method-is-instance-of res-method meth2 so)) | |
| 1377 | (setq res-method meth2))) | |
| 1521 | 1378 | res-method)) |
| 1522 | 1379 | ;;; |
| 1523 | 1380 | ;;; SETUP-ERROR-OPERATORS-IN |
| 1524 | 1381 | ;;; *NOTE* assumption : no error operators are generated in the module yet. |
| 1525 | ;;; | |
| 1382 | ;;; TODO-------- | |
| 1526 | 1383 | (defun get-new-error-sort-name-in (module sort-name) |
| 1527 | 1384 | (declare (type module module) |
| 1528 | (type (or simple-string symbol) sort-name)) | |
| 1385 | (type (or simple-string symbol) sort-name)) | |
| 1529 | 1386 | #|| |
| 1530 | 1387 | (let ((err-sort (find-error-sort-in module sort-name))) |
| 1531 | 1388 | (if err-sort |
| 1532 | (string (sort-name err-sort)) | |
| 1389 | (string (sort-name err-sort)) | |
| 1533 | 1390 | sort-name)) |
| 1534 | 1391 | ||# |
| 1535 | 1392 | module |
| 1538 | 1395 | |
| 1539 | 1396 | (defun setup-user-defined-error-operators-in (module) |
| 1540 | 1397 | (dolist (decl (remove-duplicates (module-error-op-decl module) |
| 1541 | :test #'equal)) | |
| 1398 | :test #'equal)) | |
| 1542 | 1399 | (eval-ast decl))) |
| 1543 | 1400 | |
| 1544 | (defun setup-error-operators-in (&optional (module (or *current-module* | |
| 1545 | *last-module*))) | |
| 1401 | (defun setup-error-operators-in (&optional (module (get-context-module))) | |
| 1546 | 1402 | (declare (type module module) |
| 1547 | (values t)) | |
| 1403 | (values t)) | |
| 1548 | 1404 | (let ((all-error-operators nil)) |
| 1549 | 1405 | ;; first we create error operators explicitly declared by user |
| 1550 | 1406 | (with-in-module (module) |
| 1551 | 1407 | (dolist (eop-decl (module-error-op-decl module)) |
| 1552 | (let ((proto-arity (%op-decl-arity eop-decl)) | |
| 1553 | (proto-coarity (%op-decl-coarity eop-decl))) | |
| 1554 | (when *on-operator-debug* | |
| 1555 | (format t "~%[setup-error-operators-in]:BEFORE") | |
| 1556 | (format t "~& arity=~s" proto-arity) | |
| 1557 | (format t "~& coarity=~s" proto-coarity)) | |
| 1558 | #|| | |
| 1559 | (setq proto-arity | |
| 1560 | (mapcar #'(lambda (sref) | |
| 1561 | (if (%is-sort-ref sref) | |
| 1562 | (let ((name (%sort-ref-name sref))) | |
| 1563 | (setf (%sort-ref-name sref) | |
| 1564 | (get-new-error-sort-name-in module name))) | |
| 1565 | (get-new-error-sort-name-in module sref))) | |
| 1566 | proto-arity)) | |
| 1567 | (if (%is-sort-ref proto-coarity) | |
| 1568 | (setf (%sort-ref-name proto-coarity) | |
| 1569 | (get-new-error-sort-name-in module | |
| 1570 | (%sort-ref-name proto-coarity))) | |
| 1571 | (setq proto-coarity | |
| 1572 | (get-new-error-sort-name-in module proto-coarity))) | |
| 1573 | (setf (%op-decl-arity eop-decl) proto-arity) | |
| 1574 | (setf (%op-decl-coarity eop-decl) proto-coarity) | |
| 1575 | ||# | |
| 1576 | (when *on-operator-debug* | |
| 1577 | (format t "~%[setup-error-operators-in]: declaring user defind errr op") | |
| 1578 | (format t "~% by decl : ") (print-chaos-object eop-decl)) | |
| 1579 | (let ((res (declare-operator eop-decl t))) | |
| 1580 | (if (null res) | |
| 1581 | (with-output-chaos-error ('invalid-op-decl) | |
| 1582 | (format t "could not define error operator : ") | |
| 1583 | (print-next) | |
| 1584 | (print-ast res) | |
| 1585 | ) | |
| 1586 | (push res all-error-operators)))))) | |
| 1408 | (let ((proto-arity (%op-decl-arity eop-decl)) | |
| 1409 | (proto-coarity (%op-decl-coarity eop-decl))) | |
| 1410 | (when *on-operator-debug* | |
| 1411 | (format t "~%[setup-error-operators-in]:BEFORE") | |
| 1412 | (format t "~& arity=~s" proto-arity) | |
| 1413 | (format t "~& coarity=~s" proto-coarity)) | |
| 1414 | (when *on-operator-debug* | |
| 1415 | (format t "~%[setup-error-operators-in]: declaring user defind errr op") | |
| 1416 | (format t "~% by decl : ") (print-chaos-object eop-decl)) | |
| 1417 | (let ((res (declare-operator eop-decl t))) | |
| 1418 | (if (null res) | |
| 1419 | (with-output-chaos-error ('invalid-op-decl) | |
| 1420 | (format t "could not define error operator : ") | |
| 1421 | (print-next) | |
| 1422 | (print-ast res) | |
| 1423 | ) | |
| 1424 | (push res all-error-operators)))))) | |
| 1587 | 1425 | ;; then, generates implicit ones. |
| 1588 | 1426 | (dolist (opinfo (module-all-operators module)) |
| 1589 | 1427 | (setq all-error-operators |
| 1590 | (nconc all-error-operators | |
| 1591 | (setup-error-operator opinfo module)))) | |
| 1428 | (nconc all-error-operators | |
| 1429 | (setup-error-operator opinfo module)))) | |
| 1592 | 1430 | (setf (module-error-methods module) all-error-operators))) |
| 1593 | 1431 | |
| 1594 | 1432 | (defun setup-error-operator (opinfo module) |
| 1595 | 1433 | (declare (type list opinfo) |
| 1596 | (type module module) | |
| 1597 | (values t)) | |
| 1434 | (type module module) | |
| 1435 | (values t)) | |
| 1598 | 1436 | (when *on-operator-debug* |
| 1599 | 1437 | (format t "~%[generate-err-op]: ") |
| 1600 | 1438 | (print-chaos-object (car opinfo))) |
| 1601 | 1439 | |
| 1602 | 1440 | ;; avoid generate if there already ... |
| 1603 | ||
| 1604 | ;;#|| | |
| 1605 | 1441 | (when (some #'(lambda (x) |
| 1606 | (method-is-error-method x)) | |
| 1607 | (opinfo-methods opinfo)) | |
| 1442 | (method-is-error-method x)) | |
| 1443 | (opinfo-methods opinfo)) | |
| 1608 | 1444 | (when *on-operator-debug* |
| 1609 | 1445 | (format t "~% * already exists")) |
| 1610 | 1446 | (return-from setup-error-operator nil)) |
| 1611 | ;;||# | |
| 1612 | 1447 | ;; |
| 1613 | 1448 | (let ((method-info-table (module-opinfo-table module)) |
| 1614 | (sort-order (module-sort-order module)) | |
| 1615 | (pre-errs (module-error-methods module)) | |
| 1616 | (all-errs nil) | |
| 1617 | ) | |
| 1449 | (sort-order (module-sort-order module)) | |
| 1450 | (pre-errs (module-error-methods module)) | |
| 1451 | (all-errs nil)) | |
| 1618 | 1452 | ;; NOTE: |
| 1619 | 1453 | ;; all coarities of methods are in the same connected component. |
| 1620 | 1454 | (let ((proto-method nil) |
| 1621 | (method-name nil) | |
| 1622 | (err-coarity nil) | |
| 1623 | (new-arities nil) | |
| 1624 | (coherent nil) | |
| 1625 | ) | |
| 1455 | (method-name nil) | |
| 1456 | (err-coarity nil) | |
| 1457 | (new-arities nil) | |
| 1458 | (coherent nil)) | |
| 1626 | 1459 | ;; |
| 1627 | 1460 | (setq proto-method |
| 1628 | (find-if #'(lambda (x) (method-is-universal* x)) | |
| 1629 | (opinfo-methods opinfo))) | |
| 1461 | (find-if #'(lambda (x) (method-is-universal* x)) | |
| 1462 | (opinfo-methods opinfo))) | |
| 1630 | 1463 | (unless proto-method |
| 1631 | (setq proto-method (car (opinfo-methods opinfo)))) | |
| 1464 | (setq proto-method (car (opinfo-methods opinfo)))) | |
| 1632 | 1465 | |
| 1633 | 1466 | ;; dont need error method for constants. <-- why? |
| 1634 | 1467 | (unless (method-arity proto-method) |
| 1635 | (when (or (module-is-theory module) | |
| 1636 | (module-is-regular module)) | |
| 1637 | (return-from setup-error-operator nil))) | |
| 1468 | (when (or (module-is-theory module) | |
| 1469 | (module-is-regular module)) | |
| 1470 | (return-from setup-error-operator nil))) | |
| 1638 | 1471 | ;; |
| 1639 | 1472 | (setq method-name (method-name proto-method)) |
| 1640 | 1473 | (setq err-coarity (the-err-sort (method-coarity proto-method) |
| 1641 | sort-order)) | |
| 1474 | sort-order)) | |
| 1642 | 1475 | (unless err-coarity |
| 1643 | (with-output-panic-message () | |
| 1644 | (format t "setup error operator: error sort of ") | |
| 1645 | (print-sort-name (method-coarity proto-method)) | |
| 1646 | (format t " is not yet prepared!.") | |
| 1647 | (format t "~& object=~s" (method-coarity proto-method)) | |
| 1648 | (format t "~% so=~s" sort-order) | |
| 1649 | (pp-sort-order sort-order))) | |
| 1476 | (with-output-panic-message () | |
| 1477 | (format t "setup error operator: error sort of ") | |
| 1478 | (print-sort-name (method-coarity proto-method)) | |
| 1479 | (format t " is not yet prepared!.") | |
| 1480 | (format t "~& object=~s" (method-coarity proto-method)) | |
| 1481 | (format t "~% so=~s" sort-order) | |
| 1482 | (pp-sort-order sort-order))) | |
| 1650 | 1483 | (when *on-operator-debug* |
| 1651 | (format t "~% * proto-method = ") | |
| 1652 | (print-chaos-object proto-method) | |
| 1653 | (format t "~% * err-coarity = ") | |
| 1654 | (print-sort-name err-coarity module)) | |
| 1484 | (format t "~% * proto-method = ") | |
| 1485 | (print-chaos-object proto-method) | |
| 1486 | (format t "~% * err-coarity = ") | |
| 1487 | (print-sort-name err-coarity module)) | |
| 1655 | 1488 | |
| 1656 | 1489 | (dolist (meth (opinfo-methods opinfo)) |
| 1657 | (block next-method | |
| 1658 | (when (method-is-universal* meth) | |
| 1659 | (return-from next-method nil)) ; skip universal | |
| 1660 | (let ((coarity (method-coarity meth))) | |
| 1661 | (when (or (sort= coarity *universal-sort*) | |
| 1662 | (sort= coarity *huniversal-sort*) | |
| 1663 | (sort= coarity *cosmos*) | |
| 1664 | (sort= coarity *bottom-sort*)) | |
| 1665 | (return-from next-method nil)) | |
| 1666 | (let ((ar (mapcar #'(lambda (x) | |
| 1667 | (the-err-sort x sort-order)) | |
| 1668 | (method-arity meth)))) | |
| 1669 | (pushnew ar new-arities :test #'equal)) | |
| 1670 | (setq coherent | |
| 1671 | (or coherent (method-is-coherent meth))) | |
| 1672 | ))) | |
| 1490 | (block next-method | |
| 1491 | (when (method-is-universal* meth) | |
| 1492 | (return-from next-method nil)) ; skip universal | |
| 1493 | (let ((coarity (method-coarity meth))) | |
| 1494 | (when (or (sort= coarity *universal-sort*) | |
| 1495 | (sort= coarity *huniversal-sort*) | |
| 1496 | (sort= coarity *cosmos*) | |
| 1497 | (sort= coarity *bottom-sort*)) | |
| 1498 | (return-from next-method nil)) | |
| 1499 | (let ((ar (mapcar #'(lambda (x) | |
| 1500 | (the-err-sort x sort-order)) | |
| 1501 | (method-arity meth)))) | |
| 1502 | (pushnew ar new-arities :test #'equal)) | |
| 1503 | (setq coherent | |
| 1504 | (or coherent (method-is-coherent meth)))))) | |
| 1673 | 1505 | (dolist (arity new-arities) |
| 1674 | (when *on-operator-debug* | |
| 1675 | (format t "~% * try for arity ") | |
| 1676 | (print-sort-list arity module)) | |
| 1677 | (let ((pre (find-if #'(lambda (x) | |
| 1678 | (and (equal method-name | |
| 1679 | (method-name x)) | |
| 1680 | (sort-list= arity | |
| 1681 | (method-arity x)) | |
| 1682 | (sort= err-coarity | |
| 1683 | (method-coarity x)))) | |
| 1684 | pre-errs))) | |
| 1685 | (if pre | |
| 1686 | ;; we already have error-method imported. | |
| 1687 | ;; just resuse this. | |
| 1688 | (progn | |
| 1689 | (when *on-operator-debug* | |
| 1690 | (format t "~% * found pre defined ") | |
| 1691 | (print-chaos-object pre)) | |
| 1692 | (push pre all-errs) | |
| 1693 | (add-method-to-table-very-fast opinfo pre module) | |
| 1694 | ;; we must generate new opinfo always. | |
| 1695 | (setf (get-method-info pre method-info-table) | |
| 1696 | (make-method-info pre | |
| 1697 | module | |
| 1698 | (opinfo-operator opinfo))) | |
| 1699 | (setf (method-theory pre method-info-table) | |
| 1700 | *the-empty-theory*) | |
| 1701 | ;; there can be axioms for pre-defined methods. | |
| 1702 | ;; | |
| 1703 | (unless (eq (method-module pre) module) | |
| 1704 | (let ((from-opinfo (module-opinfo-table | |
| 1705 | (method-module pre))) | |
| 1706 | (to-opinfo (module-opinfo-table module)) | |
| 1707 | (all-rules (module-all-rules module))) | |
| 1708 | (dolist (r (reverse (method-rules-with-different-top | |
| 1709 | pre | |
| 1710 | from-opinfo))) | |
| 1711 | (when (or (not (memq r all-rules)) | |
| 1712 | (eq pre (term-head (axiom-lhs r)))) | |
| 1713 | (add-rule-to-method (check-axiom-error-method module r) | |
| 1714 | pre | |
| 1715 | to-opinfo) | |
| 1716 | (pushnew r (module-all-rules module) | |
| 1717 | :test #'rule-is-similar?))))) | |
| 1718 | ;; | |
| 1719 | (compute-method-theory-info-for-matching | |
| 1720 | pre | |
| 1721 | method-info-table) | |
| 1722 | (setf (method-is-coherent pre) coherent) | |
| 1723 | ) | |
| 1724 | ;; not yet have, generate a new one. | |
| 1725 | (multiple-value-bind (ent? meth) | |
| 1726 | (add-operator-declaration-to-table opinfo | |
| 1727 | arity | |
| 1728 | err-coarity | |
| 1729 | module | |
| 1730 | nil | |
| 1731 | nil | |
| 1732 | nil) | |
| 1733 | (when *on-operator-debug* | |
| 1734 | (format t "~% * generatd new: ") | |
| 1735 | (print-chaos-object meth) | |
| 1736 | (format t "~% -- entered? ~a" ent?)) | |
| 1737 | (when ent? | |
| 1738 | ;; | |
| 1739 | (push meth all-errs) | |
| 1740 | (setf (method-theory meth method-info-table) | |
| 1741 | *the-empty-theory* | |
| 1742 | (method-is-behavioural meth) | |
| 1743 | (method-is-behavioural proto-method)) | |
| 1744 | (setf (method-is-coherent meth) coherent) | |
| 1745 | (compute-method-theory-info-for-matching | |
| 1746 | meth method-info-table) | |
| 1747 | ))) | |
| 1748 | )) | |
| 1506 | (when *on-operator-debug* | |
| 1507 | (format t "~% * try for arity ") | |
| 1508 | (print-sort-list arity module)) | |
| 1509 | (let ((pre (find-if #'(lambda (x) | |
| 1510 | (and (equal method-name | |
| 1511 | (method-name x)) | |
| 1512 | (sort-list= arity | |
| 1513 | (method-arity x)) | |
| 1514 | (sort= err-coarity | |
| 1515 | (method-coarity x)))) | |
| 1516 | pre-errs))) | |
| 1517 | (if pre | |
| 1518 | ;; we already have error-method imported. | |
| 1519 | ;; just resuse this. | |
| 1520 | (progn | |
| 1521 | (when *on-operator-debug* | |
| 1522 | (format t "~% * found pre defined ") | |
| 1523 | (print-chaos-object pre)) | |
| 1524 | (push pre all-errs) | |
| 1525 | (add-method-to-table-very-fast opinfo pre module) | |
| 1526 | ;; we must generate new opinfo always. | |
| 1527 | (setf (get-method-info pre method-info-table) | |
| 1528 | (make-method-info pre | |
| 1529 | module | |
| 1530 | (opinfo-operator opinfo))) | |
| 1531 | (setf (method-theory pre method-info-table) | |
| 1532 | *the-empty-theory*) | |
| 1533 | ;; there can be axioms for pre-defined methods. | |
| 1534 | ;; | |
| 1535 | (unless (eq (method-module pre) module) | |
| 1536 | (let ((from-opinfo (module-opinfo-table | |
| 1537 | (method-module pre))) | |
| 1538 | (to-opinfo (module-opinfo-table module)) | |
| 1539 | (all-rules (module-all-rules module))) | |
| 1540 | (dolist (r (reverse (method-rules-with-different-top | |
| 1541 | pre | |
| 1542 | from-opinfo))) | |
| 1543 | (when (or (not (memq r all-rules)) | |
| 1544 | (eq pre (term-head (axiom-lhs r)))) | |
| 1545 | (add-rule-to-method (check-axiom-error-method module r) | |
| 1546 | pre | |
| 1547 | to-opinfo) | |
| 1548 | (pushnew r (module-all-rules module) | |
| 1549 | :test #'rule-is-similar?))))) | |
| 1550 | ;; | |
| 1551 | (compute-method-theory-info-for-matching | |
| 1552 | pre | |
| 1553 | method-info-table) | |
| 1554 | (setf (method-is-coherent pre) coherent)) | |
| 1555 | ;; not yet have, generate a new one. | |
| 1556 | (multiple-value-bind (ent? meth) | |
| 1557 | (add-operator-declaration-to-table opinfo | |
| 1558 | arity | |
| 1559 | err-coarity | |
| 1560 | module | |
| 1561 | nil | |
| 1562 | nil | |
| 1563 | nil) | |
| 1564 | (when *on-operator-debug* | |
| 1565 | (format t "~% * generatd new: ") | |
| 1566 | (print-chaos-object meth) | |
| 1567 | (format t "~% -- entered? ~a" ent?)) | |
| 1568 | (when ent? | |
| 1569 | (push meth all-errs) | |
| 1570 | (setf (method-theory meth method-info-table) | |
| 1571 | *the-empty-theory* | |
| 1572 | (method-is-behavioural meth) | |
| 1573 | (method-is-behavioural proto-method)) | |
| 1574 | (setf (method-is-coherent meth) coherent) | |
| 1575 | (compute-method-theory-info-for-matching | |
| 1576 | meth method-info-table)))))) | |
| 1749 | 1577 | ;; returns the list of error operators. |
| 1750 | 1578 | all-errs))) |
| 1751 | 1579 | |
| 1752 | 1580 | (defun make-sem-relation-op (module meth arity coarity) |
| 1753 | 1581 | (declare (type module module) |
| 1754 | (type method meth) | |
| 1755 | (type list arity) | |
| 1756 | (type sort-struct coarity) | |
| 1757 | (values t)) | |
| 1582 | (type method meth) | |
| 1583 | (type list arity) | |
| 1584 | (type sort-struct coarity) | |
| 1585 | (values t)) | |
| 1758 | 1586 | (with-in-module (module) |
| 1759 | 1587 | (multiple-value-bind (op new-meth) |
| 1760 | (declare-operator-in-module (operator-symbol (method-operator meth)) | |
| 1761 | arity | |
| 1762 | coarity | |
| 1763 | module) | |
| 1588 | (declare-operator-in-module (operator-symbol (method-operator meth)) | |
| 1589 | arity | |
| 1590 | coarity | |
| 1591 | module) | |
| 1764 | 1592 | (declare (ignore op)) |
| 1765 | 1593 | ;; |
| 1766 | 1594 | (setf (method-constructor new-meth) |
| 1767 | (method-constructor meth)) | |
| 1595 | (method-constructor meth)) | |
| 1768 | 1596 | (setf (method-is-behavioural new-meth) |
| 1769 | (method-is-behavioural meth)) | |
| 1597 | (method-is-behavioural meth)) | |
| 1770 | 1598 | (setf (method-supplied-strategy new-meth) |
| 1771 | (method-supplied-strategy meth)) | |
| 1599 | (method-supplied-strategy meth)) | |
| 1772 | 1600 | (setf (method-precedence new-meth) |
| 1773 | (method-precedence meth)) | |
| 1601 | (method-precedence meth)) | |
| 1774 | 1602 | (setf (method-associativity new-meth) |
| 1775 | (method-associativity meth)) | |
| 1603 | (method-associativity meth)) | |
| 1776 | 1604 | (setf (method-theory new-meth) |
| 1777 | (method-theory meth)) | |
| 1605 | (method-theory meth)) | |
| 1778 | 1606 | (setf (method-theory-info-for-matching new-meth) |
| 1779 | (method-theory-info-for-matching meth)) | |
| 1780 | ))) | |
| 1607 | (method-theory-info-for-matching meth))))) | |
| 1781 | 1608 | |
| 1782 | 1609 | (defun make-if-then-else-op (module sort) |
| 1783 | 1610 | (declare (type module module) |
| 1784 | (type sort-struct sort) | |
| 1785 | (values t)) | |
| 1611 | (type sort-struct sort) | |
| 1612 | (values t)) | |
| 1786 | 1613 | (with-in-module (module) |
| 1787 | 1614 | (multiple-value-bind (op new-meth) |
| 1788 | (declare-operator-in-module (operator-symbol *bool-if*) | |
| 1789 | (list *bool-sort* sort sort) | |
| 1790 | sort | |
| 1791 | module) | |
| 1615 | (declare-operator-in-module (operator-symbol *bool-if*) | |
| 1616 | (list *bool-sort* sort sort) | |
| 1617 | sort | |
| 1618 | module) | |
| 1792 | 1619 | (declare (ignore op)) |
| 1793 | 1620 | ;; |
| 1794 | 1621 | (setf (method-constructor new-meth) |
| 1795 | (method-constructor *bool-if*)) | |
| 1622 | (method-constructor *bool-if*)) | |
| 1796 | 1623 | (setf (method-is-behavioural new-meth) |
| 1797 | (method-is-behavioural *bool-if*)) | |
| 1624 | (method-is-behavioural *bool-if*)) | |
| 1798 | 1625 | (setf (method-supplied-strategy new-meth) |
| 1799 | (method-supplied-strategy *bool-if*)) | |
| 1626 | (method-supplied-strategy *bool-if*)) | |
| 1800 | 1627 | (setf (method-precedence new-meth) |
| 1801 | (method-precedence *bool-if*)) | |
| 1628 | (method-precedence *bool-if*)) | |
| 1802 | 1629 | (setf (method-associativity new-meth) |
| 1803 | (method-associativity *bool-if*)) | |
| 1630 | (method-associativity *bool-if*)) | |
| 1804 | 1631 | (setf (method-theory new-meth) |
| 1805 | (method-theory *bool-if*)) | |
| 1632 | (method-theory *bool-if*)) | |
| 1806 | 1633 | (setf (method-theory-info-for-matching new-meth) |
| 1807 | (method-theory-info-for-matching *bool-if*)) | |
| 1808 | ))) | |
| 1634 | (method-theory-info-for-matching *bool-if*))))) | |
| 1809 | 1635 | |
| 1810 | 1636 | (defun setup-if-then-else-in (module) |
| 1811 | 1637 | (declare (type module module) |
| 1812 | (values t)) | |
| 1638 | (values t)) | |
| 1813 | 1639 | (when (assq *truth-module* (module-all-submodules module)) |
| 1814 | 1640 | (let ((sorts (get-module-top-sorts module))) |
| 1815 | 1641 | (dolist (es sorts) |
| 1816 | (make-if-then-else-op module es))))) | |
| 1642 | (make-if-then-else-op module es))))) | |
| 1817 | 1643 | |
| 1818 | #|| | |
| 1819 | 1644 | (defun setup-sem-relations-in (module) |
| 1645 | (declare (type module module) | |
| 1646 | (values t)) | |
| 1820 | 1647 | (when (assq *truth-module* (module-all-submodules module)) |
| 1821 | 1648 | (let ((sorts (get-module-top-sorts module))) |
| 1822 | 1649 | (dolist (es sorts) |
| 1823 | (if (sort-is-hidden es) | |
| 1824 | (progn | |
| 1825 | ;; _=*=_ | |
| 1826 | (make-sem-relation-op module | |
| 1827 | *beh-equal* | |
| 1828 | (list es es) | |
| 1829 | *bool-sort*) | |
| 1830 | ;; _=b=_ | |
| 1831 | (make-sem-relation-op module | |
| 1832 | *beh-eq-pred* | |
| 1833 | (list es es) | |
| 1834 | *bool-sort*)) | |
| 1835 | (progn | |
| 1836 | ;; _==_ | |
| 1837 | (make-sem-relation-op module | |
| 1838 | *bool-equal* | |
| 1839 | (list es es) | |
| 1840 | *bool-sort*) | |
| 1841 | ;; _=/=_ | |
| 1842 | (make-sem-relation-op module | |
| 1843 | *bool-nonequal* | |
| 1844 | (list es es) | |
| 1845 | *bool-sort*) | |
| 1846 | )) | |
| 1847 | ))) | |
| 1848 | (when (assq *rwl-module* (module-all-submodules module)) | |
| 1849 | ;; _==>_ | |
| 1850 | (let ((sorts (get-module-top-sorts module))) | |
| 1851 | (dolist (s sorts) | |
| 1852 | (make-sem-relation-op module | |
| 1853 | *rwl-predicate* | |
| 1854 | (list s s) | |
| 1855 | *bool-sort*)))) | |
| 1856 | ) | |
| 1857 | ||
| 1858 | ||# | |
| 1859 | ||
| 1860 | (defun setup-sem-relations-in (module) | |
| 1861 | (declare (type module module) | |
| 1862 | (values t)) | |
| 1863 | (when (assq *truth-module* (module-all-submodules module)) | |
| 1864 | (let ((sorts (get-module-top-sorts module))) | |
| 1865 | (dolist (es sorts) | |
| 1866 | (if (sort-is-hidden es) | |
| 1867 | ;; _=*=_ | |
| 1868 | (make-sem-relation-op module | |
| 1869 | *beh-equal* | |
| 1870 | (list es es) | |
| 1871 | *bool-sort*) | |
| 1872 | ))))) | |
| 1650 | (if (sort-is-hidden es) | |
| 1651 | ;; _=*=_ | |
| 1652 | (make-sem-relation-op module | |
| 1653 | *beh-equal* | |
| 1654 | (list es es) | |
| 1655 | *bool-sort*)))))) | |
| 1873 | 1656 | |
| 1874 | 1657 | (defparameter memb-predicate-name-template |
| 1875 | 1658 | '("_" ":" 'sort-name)) |
| 1881 | 1664 | |
| 1882 | 1665 | (defun make-sort-memb-decl-form (sort) |
| 1883 | 1666 | (let ((name (string (sort-id sort))) |
| 1884 | (pred-name (copy-tree memb-predicate-name-template)) | |
| 1885 | (decl-form (copy-tree memb-predicate-decl-template))) | |
| 1667 | (pred-name (copy-tree memb-predicate-name-template)) | |
| 1668 | (decl-form (copy-tree memb-predicate-decl-template))) | |
| 1886 | 1669 | (setf (third pred-name) name) |
| 1887 | 1670 | (setf (second decl-form) pred-name) |
| 1888 | 1671 | (setf (third decl-form) |
| 1889 | (list (%sort-ref* (concatenate 'string "?" name) nil))) | |
| 1672 | (list (%sort-ref* (concatenate 'string "?" name) nil))) | |
| 1890 | 1673 | decl-form)) |
| 1891 | 1674 | |
| 1892 | 1675 | (defun declare-sort-memb-predicates (module) |
| 1893 | (dolist (s (module-sorts module)) ; only for own sorts, others should be | |
| 1894 | ; imported. | |
| 1676 | (dolist (s (module-sorts module)) ; only for own sorts, others should be | |
| 1677 | ; imported. | |
| 1895 | 1678 | (let ((decl-form (make-sort-memb-decl-form s))) |
| 1896 | 1679 | (pushnew decl-form (module-error-op-decl module) |
| 1897 | :test #'equal)))) | |
| 1680 | :test #'equal)))) | |
| 1898 | 1681 | |
| 1899 | 1682 | (defun declare-sort-id-constants (module) |
| 1900 | 1683 | (when (memq *sort-id-sort* (module-all-sorts module)) |
| 1901 | 1684 | (dolist (sort (module-sorts module)) |
| 1902 | 1685 | (let ((op-name (list (string (sort-id sort))))) |
| 1903 | (unless (find-method-in module op-name nil *sort-id-sort*) | |
| 1904 | (declare-operator-in-module op-name | |
| 1905 | nil | |
| 1906 | *sort-id-sort* | |
| 1907 | module | |
| 1908 | t ; constructor | |
| 1909 | )))))) | |
| 1686 | (unless (find-method-in module op-name nil *sort-id-sort*) | |
| 1687 | (declare-operator-in-module op-name | |
| 1688 | nil | |
| 1689 | *sort-id-sort* | |
| 1690 | module | |
| 1691 | t ; constructor | |
| 1692 | )))))) | |
| 1910 | 1693 | |
| 1911 | 1694 | (defun setup-operators-in (module) |
| 1912 | 1695 | (declare (type module module) |
| 1913 | (values t)) | |
| 1696 | (values t)) | |
| 1914 | 1697 | (with-in-module (module) |
| 1915 | 1698 | (let ((method-info-table (module-opinfo-table module)) |
| 1916 | (sort-order (module-sort-order module))) | |
| 1699 | (sort-order (module-sort-order module))) | |
| 1917 | 1700 | (flet ((compute-lower-methods (method methods &aux (meth-list nil)) |
| 1918 | (dolist (m methods) | |
| 1919 | (when (method-is-restriction-of m method sort-order) | |
| 1920 | (push m meth-list))) | |
| 1921 | (let ((res (topo-sort meth-list #'method-is-restriction-of))) | |
| 1922 | res) | |
| 1923 | ) | |
| 1924 | (compute-overloaded-methods (method methods &aux (meth-list nil)) | |
| 1925 | (dolist (m methods) | |
| 1926 | (when (method-is-in-same-component method m sort-order) | |
| 1927 | (push m meth-list))) | |
| 1928 | ;;*** NOTE *** overloaded method is sorted | |
| 1929 | ;; lower -> higher | |
| 1930 | (nreverse (topo-sort meth-list #'method<)))) | |
| 1931 | ;; | |
| 1932 | (dolist (opinfo (module-all-operators module)) | |
| 1933 | (let ((op (opinfo-operator opinfo)) | |
| 1934 | (methods (opinfo-methods opinfo))) | |
| 1935 | ;; | |
| 1936 | ;; compute default values of attributes for operator (not methods). | |
| 1937 | ;; | |
| 1938 | (when (or (eq (operator-module op) *current-module*) | |
| 1939 | (null (operator-computed-precedence op))) | |
| 1940 | (setf (operator-computed-precedence op) | |
| 1941 | (compute-operator-precedence op)) | |
| 1942 | (unless (operator-associativity op) | |
| 1943 | (if (operator-is-associative op) | |
| 1944 | (setf (operator-associativity op) | |
| 1945 | :right))) | |
| 1946 | ) | |
| 1947 | ;; set (1) lowers and highers, | |
| 1948 | ;; (2) memo property | |
| 1949 | ;; (3) match theory. | |
| 1950 | ;; (2) and (3) are module independent, | |
| 1951 | ;; thus we compute these only for methods of | |
| 1952 | ;; current-module. imported methods already has these values | |
| 1953 | ;; set properly. | |
| 1954 | (let (;; (strat (operator-strategy op)) | |
| 1955 | ;; strategy must be computed later. | |
| 1956 | (theory (operator-theory op))) | |
| 1957 | (dolist (m methods) | |
| 1958 | (setf (method-lower-methods m) | |
| 1959 | (compute-lower-methods m methods)) | |
| 1960 | (setf (method-overloaded-methods m) | |
| 1961 | (compute-overloaded-methods m methods)) | |
| 1962 | (when (eq (method-module m) *current-module*) | |
| 1963 | #|| | |
| 1964 | ;; (2) memo is now obsolete | |
| 1965 | (unless (method-has-memo m) | |
| 1966 | (setf (method-has-memo m) memo)) | |
| 1967 | ||# | |
| 1968 | ;; ** the rewrite strategy for default methods are always eager. | |
| 1969 | ;; we set the value here. | |
| 1970 | (when (method-is-error-method m) | |
| 1971 | (setf (method-rewrite-strategy m) | |
| 1972 | (the-default-strategy (operator-num-args op)))) | |
| 1973 | ||
| 1974 | ;; (3) equational theory | |
| 1975 | (unless (method-is-error-method m) | |
| 1976 | (let ((m-th (method-theory m method-info-table))) | |
| 1977 | (if (and m-th (not (eq m-th *the-empty-theory*))) | |
| 1978 | (progn | |
| 1979 | ;; we take logical or | |
| 1980 | (setf (theory-info m-th) | |
| 1981 | (theory-code-to-info (logior (theory-code theory) | |
| 1982 | (theory-code m-th)))) | |
| 1983 | ;; | |
| 1984 | (if (theory-zero theory) | |
| 1985 | (setf (theory-zero m-th) | |
| 1986 | (theory-zero theory)))) | |
| 1987 | ;; set the default value inherited from operator. | |
| 1988 | (progn | |
| 1989 | (setf (method-theory m method-info-table) theory) | |
| 1990 | (compute-method-theory-info-for-matching | |
| 1991 | m | |
| 1992 | method-info-table)) | |
| 1993 | )) | |
| 1994 | )) | |
| 1995 | )) | |
| 1996 | ||
| 1997 | ;; setup method lookup table. | |
| 1998 | ;; *** NOT USED NOW *** | |
| 1999 | ;; (setf (opinfo-method-table opinfo) | |
| 2000 | ;; (make-method-table (opinfo-methods opinfo) | |
| 2001 | ;; *current-sort-order*)) | |
| 2002 | ;; | |
| 2003 | #|| | |
| 2004 | ;; compute syntactic properties for each methods. | |
| 2005 | (compute-method-syntactic-properties opinfo method-info-table) | |
| 2006 | ;; set syntactic properties for error methods. | |
| 2007 | (compute-error-method-syntactic-properties opinfo | |
| 2008 | method-info-table) | |
| 2009 | ||# | |
| 2010 | )) | |
| 2011 | )))) | |
| 1701 | (dolist (m methods) | |
| 1702 | (when (method-is-restriction-of m method sort-order) | |
| 1703 | (push m meth-list))) | |
| 1704 | (let ((res (topo-sort meth-list #'method-is-restriction-of))) | |
| 1705 | res) | |
| 1706 | ) | |
| 1707 | (compute-overloaded-methods (method methods &aux (meth-list nil)) | |
| 1708 | (dolist (m methods) | |
| 1709 | (when (method-is-in-same-component method m sort-order) | |
| 1710 | (push m meth-list))) | |
| 1711 | ;;*** NOTE *** overloaded method is sorted | |
| 1712 | ;; lower -> higher | |
| 1713 | (nreverse (topo-sort meth-list #'method<)))) | |
| 1714 | ;; | |
| 1715 | (dolist (opinfo (module-all-operators module)) | |
| 1716 | (let ((op (opinfo-operator opinfo)) | |
| 1717 | (methods (opinfo-methods opinfo))) | |
| 1718 | ;; | |
| 1719 | ;; compute default values of attributes for operator (not methods). | |
| 1720 | ;; | |
| 1721 | (when (or (eq (operator-module op) *current-module*) | |
| 1722 | (null (operator-computed-precedence op))) | |
| 1723 | (setf (operator-computed-precedence op) | |
| 1724 | (compute-operator-precedence op)) | |
| 1725 | (unless (operator-associativity op) | |
| 1726 | (if (operator-is-associative op) | |
| 1727 | (setf (operator-associativity op) | |
| 1728 | :right)))) | |
| 1729 | ;; set (1) lowers and highers, | |
| 1730 | ;; (2) memo property | |
| 1731 | ;; (3) match theory. | |
| 1732 | ;; (2) and (3) are module independent, | |
| 1733 | ;; thus we compute these only for methods of | |
| 1734 | ;; current-module. imported methods already has these values | |
| 1735 | ;; set properly. | |
| 1736 | (let (;; (strat (operator-strategy op)) | |
| 1737 | ;; strategy must be computed later. | |
| 1738 | (theory (operator-theory op))) | |
| 1739 | (dolist (m methods) | |
| 1740 | (setf (method-lower-methods m) | |
| 1741 | (compute-lower-methods m methods)) | |
| 1742 | (setf (method-overloaded-methods m) | |
| 1743 | (compute-overloaded-methods m methods)) | |
| 1744 | (when (eq (method-module m) *current-module*) | |
| 1745 | ;; ** the rewrite strategy for default methods are always eager. | |
| 1746 | ;; we set the value here. | |
| 1747 | (when (method-is-error-method m) | |
| 1748 | (setf (method-rewrite-strategy m) | |
| 1749 | (the-default-strategy (operator-num-args op)))) | |
| 1750 | ||
| 1751 | ;; (3) equational theory | |
| 1752 | (unless (method-is-error-method m) | |
| 1753 | (let ((m-th (method-theory m method-info-table))) | |
| 1754 | (if (and m-th (not (eq m-th *the-empty-theory*))) | |
| 1755 | (progn | |
| 1756 | ;; we take logical or | |
| 1757 | (setf (theory-info m-th) | |
| 1758 | (theory-code-to-info (logior (theory-code theory) | |
| 1759 | (theory-code m-th)))) | |
| 1760 | ;; | |
| 1761 | (if (theory-zero theory) | |
| 1762 | (setf (theory-zero m-th) | |
| 1763 | (theory-zero theory)))) | |
| 1764 | ;; set the default value inherited from operator. | |
| 1765 | (progn | |
| 1766 | (setf (method-theory m method-info-table) theory) | |
| 1767 | (compute-method-theory-info-for-matching | |
| 1768 | m | |
| 1769 | method-info-table)))))))))))))) | |
| 2012 | 1770 | |
| 2013 | 1771 | (defun set-operator-syntactic-properties (module) |
| 2014 | 1772 | (with-in-module (module) |
| 2015 | 1773 | (let ((method-info-table (module-opinfo-table module))) |
| 2016 | 1774 | (dolist (opinfo (module-all-operators module)) |
| 2017 | ;; compute syntactic properties for each methods. | |
| 2018 | (compute-method-syntactic-properties opinfo method-info-table) | |
| 2019 | ;; set syntactic properties for error methods. | |
| 2020 | (compute-error-method-syntactic-properties opinfo | |
| 2021 | method-info-table) | |
| 2022 | )))) | |
| 1775 | ;; compute syntactic properties for each methods. | |
| 1776 | (compute-method-syntactic-properties opinfo method-info-table) | |
| 1777 | ;; set syntactic properties for error methods. | |
| 1778 | (compute-error-method-syntactic-properties opinfo | |
| 1779 | method-info-table))))) | |
| 2023 | 1780 | |
| 2024 | 1781 | (defun make-standard-token-seq (op-name-token number-of-args) |
| 2025 | 1782 | (declare (type fixnum number-of-args) |
| 2026 | (values list)) | |
| 1783 | (values list)) | |
| 2027 | 1784 | (if (zerop number-of-args) |
| 2028 | 1785 | op-name-token |
| 2029 | 1786 | (let ((res nil)) |
| 2030 | (push "(" res) | |
| 2031 | (dotimes (x number-of-args) | |
| 2032 | (push t res) | |
| 2033 | (if (< x (1- number-of-args)) | |
| 2034 | (push "," res))) | |
| 2035 | (push ")" res) | |
| 2036 | (append op-name-token (nreverse res))))) | |
| 1787 | (push "(" res) | |
| 1788 | (dotimes (x number-of-args) | |
| 1789 | (push t res) | |
| 1790 | (if (< x (1- number-of-args)) | |
| 1791 | (push "," res))) | |
| 1792 | (push ")" res) | |
| 1793 | (append op-name-token (nreverse res))))) | |
| 2037 | 1794 | |
| 2038 | 1795 | (defun compute-method-syntactic-properties (opinfo |
| 2039 | method-info-table) | |
| 1796 | method-info-table) | |
| 2040 | 1797 | (declare (type list opinfo) |
| 2041 | (type hash-table method-info-table) | |
| 2042 | (values t)) | |
| 1798 | (type hash-table method-info-table) | |
| 1799 | (values t)) | |
| 2043 | 1800 | ;; here we construct a info about form of terms, |
| 2044 | 1801 | ;; used by our bottom up term parser. |
| 2045 | 1802 | ;; |
| 2046 | 1803 | ;; ** how can we manipulate variable length arguments? |
| 2047 | 1804 | ;; any smart ways? |
| 2048 | 1805 | (let* ((op (opinfo-operator opinfo)) |
| 2049 | (methods (opinfo-methods opinfo)) | |
| 2050 | (op-prec (operator-computed-precedence op)) | |
| 2051 | (op-assoc (operator-associativity op)) | |
| 2052 | (token-sequence (operator-token-sequence op)) | |
| 2053 | ) | |
| 1806 | (methods (opinfo-methods opinfo)) | |
| 1807 | (op-prec (operator-computed-precedence op)) | |
| 1808 | (op-assoc (operator-associativity op)) | |
| 1809 | (token-sequence (operator-token-sequence op))) | |
| 2054 | 1810 | (unless (operator-is-mixfix op) |
| 2055 | 1811 | ;; operator has a standard application form. |
| 2056 | 1812 | (setf token-sequence (make-standard-token-seq token-sequence |
| 2057 | (operator-num-args op)))) | |
| 1813 | (operator-num-args op)))) | |
| 2058 | 1814 | ;; NOTE : if we do not allow overloaded methods to have different syntactic |
| 2059 | 1815 | ;; properties, things will be very simple. to be considered. |
| 2060 | 1816 | ;; |
| 2061 | 1817 | (dolist (method methods) |
| 2062 | 1818 | (let* ((prec (or (method-precedence method) op-prec)) |
| 2063 | (lower-prec (if (zerop prec) | |
| 2064 | 0 | |
| 2065 | (1- prec))) | |
| 2066 | (assoc-decl (or (method-associativity method) | |
| 2067 | (setf (method-associativity method) | |
| 2068 | ;; assoc theory is interpreted as right-associative | |
| 2069 | (if (and (method-is-associative method | |
| 2070 | method-info-table) | |
| 2071 | (null op-assoc) | |
| 2072 | ) | |
| 2073 | ':right | |
| 2074 | op-assoc))))) | |
| 2075 | (declare (type fixnum prec lower-prec) | |
| 2076 | (type symbol assoc-decl)) | |
| 2077 | ;; | |
| 2078 | (let* ((arity-list (method-arity method)) | |
| 2079 | (cur-item nil) | |
| 2080 | (last-item nil) | |
| 2081 | (next-item nil) | |
| 2082 | (form nil) | |
| 2083 | (res nil) | |
| 2084 | (token-seq token-sequence) | |
| 2085 | (gathering (compute-gathering method token-seq assoc-decl))) | |
| 2086 | (declare (type list arity-list res token-seq gathering form)) | |
| 2087 | ;; | |
| 2088 | (loop (when (null token-seq) | |
| 2089 | (setq form (nreverse res)) | |
| 2090 | (return)) | |
| 2091 | (setq last-item cur-item) | |
| 2092 | (setq cur-item (car token-seq)) | |
| 2093 | (setq next-item (cadr token-seq)) | |
| 2094 | (cond ((eq t cur-item) | |
| 2095 | (push (list* 'argument | |
| 2096 | (if (eq '& (car gathering)) | |
| 2097 | parser-max-precedence | |
| 2098 | (if (and last-item | |
| 2099 | (not (eq t last-item)) | |
| 2100 | next-item | |
| 2101 | (not (eq t next-item))) | |
| 2102 | parser-max-precedence | |
| 2103 | (if (eq ':right (car gathering)) | |
| 2104 | lower-prec | |
| 2105 | (if (eq ':left (car gathering)) | |
| 2106 | prec | |
| 2107 | 0)))) | |
| 2108 | (car arity-list)) | |
| 2109 | res) | |
| 2110 | (setq arity-list (cdr arity-list) | |
| 2111 | gathering (cdr gathering))) | |
| 2112 | (t (push (cons 'token cur-item) res))) | |
| 2113 | (setq token-seq (cdr token-seq))) | |
| 2114 | ;; | |
| 2115 | ; (terpri) | |
| 2116 | ; (print-chaos-object method) | |
| 2117 | ; (format t " :form= ~S" form) | |
| 2118 | ;; | |
| 2119 | (setf (method-form method) form)))))) | |
| 1819 | (lower-prec (if (zerop prec) | |
| 1820 | 0 | |
| 1821 | (1- prec))) | |
| 1822 | (assoc-decl (or (method-associativity method) | |
| 1823 | (setf (method-associativity method) | |
| 1824 | ;; assoc theory is interpreted as right-associative | |
| 1825 | (if (and (method-is-associative method | |
| 1826 | method-info-table) | |
| 1827 | (null op-assoc)) | |
| 1828 | ':right | |
| 1829 | op-assoc))))) | |
| 1830 | (declare (type fixnum prec lower-prec) | |
| 1831 | (type symbol assoc-decl)) | |
| 1832 | ;; | |
| 1833 | (let* ((arity-list (method-arity method)) | |
| 1834 | (cur-item nil) | |
| 1835 | (last-item nil) | |
| 1836 | (next-item nil) | |
| 1837 | (form nil) | |
| 1838 | (res nil) | |
| 1839 | (token-seq token-sequence) | |
| 1840 | (gathering (compute-gathering method token-seq assoc-decl))) | |
| 1841 | (declare (type list arity-list res token-seq gathering form)) | |
| 1842 | ;; | |
| 1843 | (loop (when (null token-seq) | |
| 1844 | (setq form (nreverse res)) | |
| 1845 | (return)) | |
| 1846 | (setq last-item cur-item) | |
| 1847 | (setq cur-item (car token-seq)) | |
| 1848 | (setq next-item (cadr token-seq)) | |
| 1849 | (cond ((eq t cur-item) | |
| 1850 | (push (list* 'argument | |
| 1851 | (if (eq '& (car gathering)) | |
| 1852 | parser-max-precedence | |
| 1853 | (if (and last-item | |
| 1854 | (not (eq t last-item)) | |
| 1855 | next-item | |
| 1856 | (not (eq t next-item))) | |
| 1857 | parser-max-precedence | |
| 1858 | (if (eq ':right (car gathering)) | |
| 1859 | lower-prec | |
| 1860 | (if (eq ':left (car gathering)) | |
| 1861 | prec | |
| 1862 | 0)))) | |
| 1863 | (car arity-list)) | |
| 1864 | res) | |
| 1865 | (setq arity-list (cdr arity-list) | |
| 1866 | gathering (cdr gathering))) | |
| 1867 | (t (push (cons 'token cur-item) res))) | |
| 1868 | (setq token-seq (cdr token-seq))) | |
| 1869 | (setf (method-form method) form)))))) | |
| 2120 | 1870 | |
| 2121 | 1871 | (defun compute-error-method-syntactic-properties (opinfo method-info-table) |
| 2122 | 1872 | (declare (type list opinfo) |
| 2123 | (type hash-table method-info-table) | |
| 2124 | (values t)) | |
| 1873 | (type hash-table method-info-table) | |
| 1874 | (values t)) | |
| 2125 | 1875 | (dolist (meth (opinfo-methods opinfo)) |
| 2126 | 1876 | (when (method-is-error-method meth) |
| 2127 | 1877 | (let ((ms (method-lower-methods meth method-info-table))) |
| 2128 | ;; assumption, lower methods (when the mehthod is strictly | |
| 2129 | ;; overloaded) are ordered ... | |
| 2130 | (when ms | |
| 2131 | (let ((assoc (method-associativity (car ms))) | |
| 2132 | (prec (get-method-precedence (car ms) method-info-table)) | |
| 2133 | (form (method-form (car ms)))) | |
| 2134 | (setf (method-associativity meth) assoc) | |
| 2135 | (setf (method-precedence meth) prec) | |
| 2136 | (setf (method-form meth) | |
| 2137 | (compute-error-method-form meth form)))))))) | |
| 1878 | ;; assumption, lower methods (when the mehthod is strictly | |
| 1879 | ;; overloaded) are ordered ... | |
| 1880 | (when ms | |
| 1881 | (let ((assoc (method-associativity (car ms))) | |
| 1882 | (prec (get-method-precedence (car ms) method-info-table)) | |
| 1883 | (form (method-form (car ms)))) | |
| 1884 | (setf (method-associativity meth) assoc) | |
| 1885 | (setf (method-precedence meth) prec) | |
| 1886 | (setf (method-form meth) | |
| 1887 | (compute-error-method-form meth form)))))))) | |
| 2138 | 1888 | |
| 2139 | 1889 | (defun compute-error-method-form (method form) |
| 2140 | 1890 | (declare (type method method) |
| 2141 | (type list form) | |
| 2142 | (values list)) | |
| 1891 | (type list form) | |
| 1892 | (values list)) | |
| 2143 | 1893 | (let ((new-form nil) |
| 2144 | (arg-num 0) | |
| 2145 | (arity (method-arity method))) | |
| 1894 | (arg-num 0) | |
| 1895 | (arity (method-arity method))) | |
| 2146 | 1896 | (dolist (elt form) |
| 2147 | 1897 | (if (eq (car elt) 'argument) |
| 2148 | (progn | |
| 2149 | (push (cons (car elt) | |
| 2150 | (cons (second elt) | |
| 2151 | (nth arg-num arity))) | |
| 2152 | new-form) | |
| 2153 | (incf arg-num)) | |
| 2154 | (push elt new-form))) | |
| 1898 | (progn | |
| 1899 | (push (cons (car elt) | |
| 1900 | (cons (second elt) | |
| 1901 | (nth arg-num arity))) | |
| 1902 | new-form) | |
| 1903 | (incf arg-num)) | |
| 1904 | (push elt new-form))) | |
| 2155 | 1905 | (nreverse new-form))) |
| 2156 | 1906 | |
| 2157 | 1907 | (defun compute-gathering (method token-seq assoc-decl) |
| 2158 | 1908 | (declare (type method method) |
| 2159 | (type list token-seq) | |
| 2160 | (type symbol assoc-decl) | |
| 2161 | (values list)) | |
| 2162 | ;; | |
| 2163 | ; (terpri) | |
| 2164 | ; (print-chaos-object method) | |
| 2165 | ; (format t " : assoc=~S" (method-is-associative method)) | |
| 2166 | ;; | |
| 1909 | (type list token-seq) | |
| 1910 | (type symbol assoc-decl) | |
| 1911 | (values list)) | |
| 2167 | 1912 | (if assoc-decl |
| 2168 | 1913 | (if (eq assoc-decl ':left) |
| 2169 | '(:left :right) | |
| 2170 | '(:right :left)) | |
| 1914 | '(:left :right) | |
| 1915 | '(:right :left)) | |
| 2171 | 1916 | ;; if unary prefix use :left not :right |
| 2172 | 1917 | (if (not (operator-is-mixfix (method-operator method))) |
| 2173 | (mapcar #'(lambda (x) (declare (ignore x)) '&) (method-arity method)) | |
| 2174 | (if (and (eq t (car (last token-seq))) | |
| 2175 | (not (member t (butlast token-seq)))) | |
| 2176 | '(:left) | |
| 2177 | (if (method-is-associative method) | |
| 2178 | '(:right :left) | |
| 2179 | (mapcar #'(lambda (x) (declare (ignore x)) ':left) | |
| 2180 | (method-arity method))))))) | |
| 1918 | (mapcar #'(lambda (x) (declare (ignore x)) '&) (method-arity method)) | |
| 1919 | (if (and (eq t (car (last token-seq))) | |
| 1920 | (not (member t (butlast token-seq)))) | |
| 1921 | '(:left) | |
| 1922 | (if (method-is-associative method) | |
| 1923 | '(:right :left) | |
| 1924 | (mapcar #'(lambda (x) (declare (ignore x)) ':left) | |
| 1925 | (method-arity method))))))) | |
| 2181 | 1926 | |
| 2182 | 1927 | ;;; |
| 2183 | 1928 | ;;; CHECK-POLIMORHIC-OVERLODING-IN |
| 2184 | 1929 | ;;; |
| 2185 | (defun check-polimorphic-overloading-in (&optional (module (or *current-module* | |
| 2186 | *last-module*))) | |
| 1930 | (defun check-polimorphic-overloading-in (&optional (module (get-context-module))) | |
| 2187 | 1931 | (declare (type module module) |
| 2188 | (values t)) | |
| 1932 | (values t)) | |
| 2189 | 1933 | (with-in-module (module) |
| 2190 | 1934 | (dolist (opinfo (module-all-operators module)) |
| 2191 | 1935 | (unless (methods-strictly-overloading (opinfo-methods opinfo)) |
| 2192 | (dolist (m (opinfo-methods opinfo)) | |
| 2193 | (setf (method-strictly-overloaded m) nil)))))) | |
| 1936 | (dolist (m (opinfo-methods opinfo)) | |
| 1937 | (setf (method-strictly-overloaded m) nil)))))) | |
| 2194 | 1938 | |
| 2195 | 1939 | (defun methods-strictly-overloading (methods) |
| 2196 | 1940 | (declare (type list methods) |
| 2197 | (values (or null t))) | |
| 1941 | (values (or null t))) | |
| 2198 | 1942 | (do* ((ms methods (cdr ms)) |
| 2199 | (method (car ms) (car ms))) | |
| 1943 | (method (car ms) (car ms))) | |
| 2200 | 1944 | ((endp ms) t) |
| 2201 | 1945 | (unless (every #'(lambda (x) |
| 2202 | (or (method-is-restriction-of method | |
| 2203 | x | |
| 2204 | *current-sort-order*) | |
| 2205 | (method-is-restriction-of x | |
| 2206 | method | |
| 2207 | *current-sort-order*))) | |
| 2208 | ms) | |
| 1946 | (or (method-is-restriction-of method | |
| 1947 | x | |
| 1948 | *current-sort-order*) | |
| 1949 | (method-is-restriction-of x | |
| 1950 | method | |
| 1951 | *current-sort-order*))) | |
| 1952 | ms) | |
| 2209 | 1953 | (return-from methods-strictly-overloading nil)))) |
| 2210 | 1954 | |
| 2211 | 1955 | ;;; ******************** |
| 2240 | 1984 | |
| 2241 | 1985 | (defun the-default-strategy (num-args) |
| 2242 | 1986 | (declare (type fixnum num-args) |
| 2243 | (values list)) | |
| 1987 | (values list)) | |
| 2244 | 1988 | (case num-args |
| 2245 | 1989 | (0 '(0)) |
| 2246 | 1990 | (1 '(1 0)) |
| 2250 | 1994 | (5 '(1 2 3 4 5 0)) |
| 2251 | 1995 | (6 '(1 2 3 4 5 6 0)) |
| 2252 | 1996 | (t (let ((res nil)) |
| 2253 | (dotimes (x num-args) (declare (type fixnum x )) (push (1+ x) res)) | |
| 2254 | (nreverse (cons 0 res)))))) | |
| 1997 | (dotimes (x num-args) (declare (type fixnum x )) (push (1+ x) res)) | |
| 1998 | (nreverse (cons 0 res)))))) | |
| 2255 | 1999 | |
| 2256 | 2000 | (defun complete-method-strategy (meth strat) |
| 2257 | 2001 | (declare (ignore meth) |
| 2258 | (type list strat) | |
| 2259 | (values list)) | |
| 2002 | (type list strat) | |
| 2003 | (values list)) | |
| 2260 | 2004 | (if (and strat (not (eql (car (last strat)) 0))) |
| 2261 | 2005 | (append strat '(0)) |
| 2262 | 2006 | strat)) |
| 2263 | 2007 | |
| 2264 | 2008 | (defun compute-rew-strategy (mod opinfo) |
| 2265 | 2009 | (declare (type module mod) |
| 2266 | (type list opinfo) | |
| 2267 | (values list)) | |
| 2010 | (type list opinfo) | |
| 2011 | (values list)) | |
| 2268 | 2012 | (with-in-module (mod) |
| 2269 | 2013 | (let ((op (opinfo-operator opinfo)) |
| 2270 | (methods (opinfo-methods opinfo))) | |
| 2014 | (methods (opinfo-methods opinfo))) | |
| 2271 | 2015 | (dolist (meth methods) |
| 2272 | ;; first inherits operator's strategy | |
| 2273 | (unless (method-supplied-strategy meth) | |
| 2274 | (setf (method-supplied-strategy meth) (operator-rewrite-strategy op))) | |
| 2275 | ;; if the strategy is specified by the user, we don't modify it | |
| 2276 | ;; this covers in particular cases 1, 2, 3, 4 | |
| 2277 | ;; | |
| 2278 | (when (method-supplied-strategy meth) | |
| 2279 | (setf (method-rewrite-strategy meth) | |
| 2280 | ;; patch: use supplied strategy as is. | |
| 2281 | ;; (complete-method-strategy meth (method-supplied-strategy meth)) | |
| 2282 | (method-supplied-strategy meth))) | |
| 2283 | ||
| 2284 | ;; compute strategy | |
| 2285 | (unless (method-rewrite-strategy meth) | |
| 2286 | ; this condition also covers the | |
| 2287 | ; case of default method. | |
| 2288 | (cond ((and (null (method-rules-with-different-top meth)) | |
| 2289 | (rule-ring-is-empty (method-rules-with-same-top meth))) | |
| 2290 | ;; the method has no rewrite rules | |
| 2291 | ;; --> cases 5.a and 6: the operator is free from axioms. | |
| 2292 | ;; *NOTE* complete-method-strategy is not neccessary here. | |
| 2293 | ;; *also* the-default-strategy returns nil when num-args = 0 . | |
| 2294 | (setf (method-rewrite-strategy meth) | |
| 2295 | ; (butlast (the-default-strategy (operator-num-args op))) | |
| 2296 | (the-default-strategy (operator-num-args op)))) | |
| 2297 | ||
| 2298 | ;; the method has some rewrite rules associated with it. | |
| 2299 | ((or | |
| 2300 | ;; case 7 : has some equational theory | |
| 2301 | (not (theory-is-empty-for-matching (method-theory meth))) | |
| 2302 | ;; case 8 : the method is not free constructor. | |
| 2303 | (null (method-rules-with-different-top meth)) | |
| 2304 | ;; case 5.b : has rules with different top and constant | |
| 2305 | ;; --> non-free constructor | |
| 2306 | (null (method-arity meth))) | |
| 2307 | ;; then the strategy is bottom up: | |
| 2308 | (setf (method-rewrite-strategy meth) | |
| 2309 | (the-default-strategy (operator-num-args op)))) | |
| 2310 | ||
| 2311 | (t | |
| 2312 | ;; case 9: the real work begins here. | |
| 2313 | ;; this is a rather huristic optimization of reduction process. | |
| 2314 | ;; the | |
| 2315 | (let ((strategy nil) | |
| 2316 | (end-strategy nil) | |
| 2317 | (l-ar (operator-num-args op))) | |
| 2318 | (declare (type fixnum l-ar)) | |
| 2319 | (do ((occ 0 (1+ occ))) | |
| 2320 | ((<= l-ar occ)) | |
| 2321 | (declare (type fixnum occ)) | |
| 2322 | (block is-variable | |
| 2323 | (let ((rr (method-rules-with-same-top meth))) | |
| 2324 | (do ((rule (initialize-rule-ring rr) (rule-ring-next rr))) | |
| 2325 | ((end-of-rule-ring rr)) | |
| 2326 | (unless (term-is-variable? | |
| 2327 | (term-arg-n (rule-lhs rule) occ)) | |
| 2328 | ;; we eagarly evaluate non-variable argument. | |
| 2329 | (push (1+ occ) strategy) | |
| 2330 | ;; check next argument | |
| 2331 | (return-from is-variable)))) | |
| 2332 | ;; we come here iff | |
| 2333 | ;; the arguments in lhs of all rules-with-same-top are | |
| 2334 | ;; variables or no rules-with-same-top. | |
| 2335 | (dolist (rule (method-rules-with-different-top meth)) | |
| 2336 | (When | |
| 2337 | (let ((argn (term-arg-n (rule-lhs rule) occ)) | |
| 2338 | (m (term-head (rule-lhs rule)))) | |
| 2339 | (or (not (term-is-variable? argn)) | |
| 2340 | ;; argn is not a variable. | |
| 2341 | (rule-is-builtin rule) | |
| 2342 | (not (and | |
| 2343 | ;; method is maximal? | |
| 2344 | ;; overloaded is necessarily a superset | |
| 2345 | ;; of lower. Note, overloaded always include | |
| 2346 | ;; self + default method, but lower not. | |
| 2347 | ;; thus #lower = #overloaded - 2 means the | |
| 2348 | ;; method is maximal. | |
| 2349 | (= (length (method-lower-methods meth)) | |
| 2350 | (- (length (method-overloaded-methods meth)) 2)) | |
| 2351 | (sort<= (nth occ (method-arity m)) | |
| 2352 | (term-sort argn)) | |
| 2353 | )))) | |
| 2354 | ;; method of lhs is not maximal, | |
| 2355 | ;; eagarly evaluates the non-variable argument. | |
| 2356 | (push (1+ occ) strategy) | |
| 2357 | ;; check the next arg. | |
| 2358 | (return-from is-variable))) | |
| 2359 | ;; come here if the occ-th argument is a variable,or | |
| 2360 | ;; method is maximal. delay the evaluation. | |
| 2361 | (push (1+ occ) end-strategy) | |
| 2362 | )) | |
| 2363 | (setf (method-rewrite-strategy meth) | |
| 2016 | ;; first inherits operator's strategy | |
| 2017 | (unless (method-supplied-strategy meth) | |
| 2018 | (setf (method-supplied-strategy meth) (operator-rewrite-strategy op))) | |
| 2019 | ;; if the strategy is specified by the user, we don't modify it | |
| 2020 | ;; this covers in particular cases 1, 2, 3, 4 | |
| 2021 | ;; | |
| 2022 | (when (method-supplied-strategy meth) | |
| 2023 | (setf (method-rewrite-strategy meth) | |
| 2024 | ;; patch: use supplied strategy as is. | |
| 2025 | ;; (complete-method-strategy meth (method-supplied-strategy meth)) | |
| 2026 | (method-supplied-strategy meth))) | |
| 2027 | ||
| 2028 | ;; compute strategy | |
| 2029 | (unless (method-rewrite-strategy meth) | |
| 2030 | ; this condition also covers the | |
| 2031 | ; case of default method. | |
| 2032 | (cond ((and (null (method-rules-with-different-top meth)) | |
| 2033 | (rule-ring-is-empty (method-rules-with-same-top meth))) | |
| 2034 | ;; the method has no rewrite rules | |
| 2035 | ;; --> cases 5.a and 6: the operator is free from axioms. | |
| 2036 | ;; *NOTE* complete-method-strategy is not neccessary here. | |
| 2037 | ;; *also* the-default-strategy returns nil when num-args = 0 . | |
| 2038 | (setf (method-rewrite-strategy meth) | |
| 2039 | ; (butlast (the-default-strategy (operator-num-args op))) | |
| 2040 | (the-default-strategy (operator-num-args op)))) | |
| 2041 | ||
| 2042 | ;; the method has some rewrite rules associated with it. | |
| 2043 | ((or | |
| 2044 | ;; case 7 : has some equational theory | |
| 2045 | (not (theory-is-empty-for-matching (method-theory meth))) | |
| 2046 | ;; case 8 : the method is not free constructor. | |
| 2047 | (null (method-rules-with-different-top meth)) | |
| 2048 | ;; case 5.b : has rules with different top and constant | |
| 2049 | ;; --> non-free constructor | |
| 2050 | (null (method-arity meth))) | |
| 2051 | ;; then the strategy is bottom up: | |
| 2052 | (setf (method-rewrite-strategy meth) | |
| 2053 | (the-default-strategy (operator-num-args op)))) | |
| 2054 | ||
| 2055 | (t | |
| 2056 | ;; case 9: the real work begins here. | |
| 2057 | ;; this is a rather huristic optimization of reduction process. | |
| 2058 | ;; the | |
| 2059 | (let ((strategy nil) | |
| 2060 | (end-strategy nil) | |
| 2061 | (l-ar (operator-num-args op))) | |
| 2062 | (declare (type fixnum l-ar)) | |
| 2063 | (do ((occ 0 (1+ occ))) | |
| 2064 | ((<= l-ar occ)) | |
| 2065 | (declare (type fixnum occ)) | |
| 2066 | (block is-variable | |
| 2067 | (let ((rr (method-rules-with-same-top meth))) | |
| 2068 | (do ((rule (initialize-rule-ring rr) (rule-ring-next rr))) | |
| 2069 | ((end-of-rule-ring rr)) | |
| 2070 | (unless (term-is-variable? | |
| 2071 | (term-arg-n (rule-lhs rule) occ)) | |
| 2072 | ;; we eagarly evaluate non-variable argument. | |
| 2073 | (push (1+ occ) strategy) | |
| 2074 | ;; check next argument | |
| 2075 | (return-from is-variable)))) | |
| 2076 | ;; we come here iff | |
| 2077 | ;; the arguments in lhs of all rules-with-same-top are | |
| 2078 | ;; variables or no rules-with-same-top. | |
| 2079 | (dolist (rule (method-rules-with-different-top meth)) | |
| 2080 | (When | |
| 2081 | (let ((argn (term-arg-n (rule-lhs rule) occ)) | |
| 2082 | (m (term-head (rule-lhs rule)))) | |
| 2083 | (or (not (term-is-variable? argn)) | |
| 2084 | ;; argn is not a variable. | |
| 2085 | (rule-is-builtin rule) | |
| 2086 | (not (and | |
| 2087 | ;; method is maximal? | |
| 2088 | ;; overloaded is necessarily a superset | |
| 2089 | ;; of lower. Note, overloaded always include | |
| 2090 | ;; self + default method, but lower not. | |
| 2091 | ;; thus #lower = #overloaded - 2 means the | |
| 2092 | ;; method is maximal. | |
| 2093 | (= (length (method-lower-methods meth)) | |
| 2094 | (- (length (method-overloaded-methods meth)) 2)) | |
| 2095 | (sort<= (nth occ (method-arity m)) | |
| 2096 | (term-sort argn)) | |
| 2097 | )))) | |
| 2098 | ;; method of lhs is not maximal, | |
| 2099 | ;; eagarly evaluates the non-variable argument. | |
| 2100 | (push (1+ occ) strategy) | |
| 2101 | ;; check the next arg. | |
| 2102 | (return-from is-variable))) | |
| 2103 | ;; come here if the occ-th argument is a variable,or | |
| 2104 | ;; method is maximal. delay the evaluation. | |
| 2105 | (push (1+ occ) end-strategy))) | |
| 2106 | (setf (method-rewrite-strategy meth) | |
| 2364 | 2107 | (complete-method-strategy meth |
| 2365 | (append (reverse strategy) | |
| 2366 | (if (member 0 strategy) nil '(0)) | |
| 2367 | (reverse end-strategy)))) | |
| 2368 | )))))))) | |
| 2108 | (append (reverse strategy) | |
| 2109 | (if (member 0 strategy) nil '(0)) | |
| 2110 | (reverse end-strategy)))))))))))) | |
| 2369 | 2111 | |
| 2370 | 2112 | ;;; *NOTE* assumes *current-opinfo-table* is properly bound. |
| 2371 | 2113 | ;;; |
| 2372 | 2114 | (defun fix-strategy-and-rules (module opinfo) |
| 2373 | 2115 | (declare (type module module) |
| 2374 | (type list opinfo) | |
| 2375 | (values t)) | |
| 2116 | (type list opinfo) | |
| 2117 | (values t)) | |
| 2376 | 2118 | (with-in-module (module) |
| 2377 | 2119 | (dolist (mth (opinfo-methods opinfo)) |
| 2378 | 2120 | (let ((rr (method-rules-with-same-top mth))) |
| 2379 | (when (method-supplied-strategy mth) | |
| 2380 | (unless (eql 0 (car (method-supplied-strategy mth))) | |
| 2381 | (when *on-operator-debug* | |
| 2382 | (princ "- merging rewrite rules of ") | |
| 2383 | (print-chaos-object mth)) | |
| 2384 | (let ((rwst (rule-ring-to-list rr))) | |
| 2385 | (setf (method-rules-with-different-top mth) | |
| 2386 | (append rwst (method-rules-with-different-top mth))) | |
| 2387 | (setf (rule-ring-ring rr) nil)))) | |
| 2388 | ;; | |
| 2389 | (setf (method-rules-with-different-top mth) | |
| 2390 | (sort (method-rules-with-different-top mth) | |
| 2391 | #'method<= | |
| 2392 | :key #'(lambda (x) (term-head (axiom-lhs x))))) | |
| 2393 | ;; | |
| 2394 | )))) | |
| 2121 | (when (method-supplied-strategy mth) | |
| 2122 | (unless (eql 0 (car (method-supplied-strategy mth))) | |
| 2123 | (when *on-operator-debug* | |
| 2124 | (princ "- merging rewrite rules of ") | |
| 2125 | (print-chaos-object mth)) | |
| 2126 | (let ((rwst (rule-ring-to-list rr))) | |
| 2127 | (setf (method-rules-with-different-top mth) | |
| 2128 | (append rwst (method-rules-with-different-top mth))) | |
| 2129 | (setf (rule-ring-ring rr) nil)))) | |
| 2130 | ;; | |
| 2131 | (setf (method-rules-with-different-top mth) | |
| 2132 | (sort (method-rules-with-different-top mth) | |
| 2133 | #'method<= | |
| 2134 | :key #'(lambda (x) (term-head (axiom-lhs x))))))))) | |
| 2395 | 2135 | |
| 2396 | 2136 | (defun propagate-attributes (module) |
| 2397 | 2137 | (declare (type module module) |
| 2398 | (values t)) | |
| 2138 | (values t)) | |
| 2399 | 2139 | (let ((opinfos (module-all-operators module))) |
| 2400 | 2140 | (with-in-module (module) |
| 2401 | 2141 | (dolist (opinfo opinfos) |
| 2402 | (dolist (m (opinfo-methods opinfo)) | |
| 2403 | ;; for each operator methods | |
| 2142 | (dolist (m (opinfo-methods opinfo)) | |
| 2143 | ;; for each operator methods | |
| 2404 | 2144 | (unless (method-is-error-method m) |
| 2405 | 2145 | (let* ((lower-ops (method-lower-methods m)) |
| 2406 | 2146 | (p-theory (method-theory m)) |
| 2407 | 2147 | (code (theory-info-code (theory-info p-theory))) |
| 2408 | 2148 | (id (car (theory-zero p-theory))) |
| 2409 | 2149 | (no-compl (if (cdr (theory-zero p-theory)) t nil))) |
| 2410 | (declare (type fixnum code)) | |
| 2411 | ;; | |
| 2412 | ;; check with lower operators of m | |
| 2413 | ;; p-theory : theory of method m | |
| 2414 | ;; code : theory code of method m | |
| 2415 | ;; id : zero for p-theory if any | |
| 2150 | (declare (type fixnum code)) | |
| 2151 | ;; | |
| 2152 | ;; check with lower operators of m | |
| 2153 | ;; p-theory : theory of method m | |
| 2154 | ;; code : theory code of method m | |
| 2155 | ;; id : zero for p-theory if any | |
| 2416 | 2156 | (dolist (lower lower-ops) |
| 2417 | 2157 | (when (method-is-restriction-of lower m) |
| 2418 | ;; seems this test is redundant... | |
| 2158 | ;; seems this test is redundant... | |
| 2419 | 2159 | (let ((othy (method-theory lower)) |
| 2420 | 2160 | newthy) |
| 2421 | ;; othy : theory of lower method | |
| 2161 | ;; othy : theory of lower method | |
| 2422 | 2162 | (setq code (logior code (theory-info-code (theory-info othy)))) |
| 2423 | ;; code now inherits super. | |
| 2424 | (when (theory-zero othy) | |
| 2425 | ;; reset id if lower method has its own. | |
| 2426 | (setq id (car (theory-zero othy)))) | |
| 2427 | ||
| 2428 | ;; check with other overloading methods. | |
| 2429 | (dolist (anop lower-ops) | |
| 2430 | (when (method-is-restriction-of lower anop) | |
| 2431 | (let ((thy (method-theory anop))) | |
| 2432 | (when (theory-contains-associativity thy) | |
| 2433 | (setq code (logior code .A.))) | |
| 2434 | (when (theory-contains-commutativity thy) | |
| 2435 | (setq code (logior code .C.))) | |
| 2436 | (when (theory-contains-idempotency thy) | |
| 2437 | (setq code (logior code .I.))) | |
| 2438 | (when (theory-contains-identity thy) | |
| 2439 | (setq code (logior code .Z.)) | |
| 2440 | (when (cdr (theory-zero thy)) | |
| 2441 | (setq no-compl t)) | |
| 2442 | (if (null id) | |
| 2163 | ;; code now inherits super. | |
| 2164 | (when (theory-zero othy) | |
| 2165 | ;; reset id if lower method has its own. | |
| 2166 | (setq id (car (theory-zero othy)))) | |
| 2167 | ||
| 2168 | ;; check with other overloading methods. | |
| 2169 | (dolist (anop lower-ops) | |
| 2170 | (when (method-is-restriction-of lower anop) | |
| 2171 | (let ((thy (method-theory anop))) | |
| 2172 | (when (theory-contains-associativity thy) | |
| 2173 | (setq code (logior code .A.))) | |
| 2174 | (when (theory-contains-commutativity thy) | |
| 2175 | (setq code (logior code .C.))) | |
| 2176 | (when (theory-contains-idempotency thy) | |
| 2177 | (setq code (logior code .I.))) | |
| 2178 | (when (theory-contains-identity thy) | |
| 2179 | (setq code (logior code .Z.)) | |
| 2180 | (when (cdr (theory-zero thy)) | |
| 2181 | (setq no-compl t)) | |
| 2182 | (if (null id) | |
| 2443 | 2183 | (setq id (car (theory-zero thy))) |
| 2444 | 2184 | (let ((nid (car (theory-zero thy)))) |
| 2445 | 2185 | (when (and nid (not (term-is-congruent? id nid))) |
| 2446 | 2186 | (with-output-chaos-warning () |
| 2447 | 2187 | (princ "different possible identities for operator ") |
| 2448 | 2188 | (print-chaos-object (opinfo-operator opinfo)) |
| 2449 | (print-next) | |
| 2450 | (term-print id) (princ " -- VS. -- ") | |
| 2451 | (term-print nid))) | |
| 2452 | ))) | |
| 2453 | ))) | |
| 2454 | ;; | |
| 2455 | (when id | |
| 2456 | (let ((idsrt (term-sort id)) | |
| 2457 | (ar (method-arity lower))) | |
| 2458 | (when (not (or (sort<= idsrt (car ar)) | |
| 2459 | (sort<= idsrt (cadr ar)))) | |
| 2460 | ;; (break) | |
| 2461 | (setq code (logxor code .Z.)) | |
| 2462 | (setq id nil)))) | |
| 2463 | ;; | |
| 2464 | (setf newthy | |
| 2465 | (create-theory code | |
| 2466 | (when id | |
| 2467 | (cons id no-compl)))) | |
| 2468 | (when (and no-compl | |
| 2469 | (theory-zero othy) | |
| 2470 | (not (cdr (theory-zero othy)))) | |
| 2471 | (with-output-chaos-warning () | |
| 2472 | (princ "variation in id completion") | |
| 2473 | (princ " for ") (print-chaos-object m))) | |
| 2474 | ;; | |
| 2475 | (set-method-theory lower | |
| 2476 | newthy | |
| 2477 | #|| set-method-theory calls this | |
| 2478 | (check-method-theory-consistency | |
| 2479 | lower | |
| 2480 | newthy | |
| 2481 | *current-opinfo-table* | |
| 2482 | t) | |
| 2483 | ||# | |
| 2484 | *current-opinfo-table* | |
| 2485 | t)) | |
| 2486 | )) | |
| 2487 | )) ; end unless | |
| 2488 | ) ; end dolist | |
| 2489 | ) ; end dolist | |
| 2490 | ) | |
| 2491 | )) | |
| 2492 | ||
| 2189 | (print-next) | |
| 2190 | (term-print id) (princ " -- VS. -- ") | |
| 2191 | (term-print nid))))))))) | |
| 2192 | ;; | |
| 2193 | (when id | |
| 2194 | (let ((idsrt (term-sort id)) | |
| 2195 | (ar (method-arity lower))) | |
| 2196 | (when (not (or (sort<= idsrt (car ar)) | |
| 2197 | (sort<= idsrt (cadr ar)))) | |
| 2198 | ;; (break) | |
| 2199 | (setq code (logxor code .Z.)) | |
| 2200 | (setq id nil)))) | |
| 2201 | ;; | |
| 2202 | (setf newthy | |
| 2203 | (create-theory code | |
| 2204 | (when id | |
| 2205 | (cons id no-compl)))) | |
| 2206 | (when (and no-compl | |
| 2207 | (theory-zero othy) | |
| 2208 | (not (cdr (theory-zero othy)))) | |
| 2209 | (with-output-chaos-warning () | |
| 2210 | (princ "variation in id completion") | |
| 2211 | (princ " for ") (print-chaos-object m))) | |
| 2212 | ;; | |
| 2213 | (set-method-theory lower | |
| 2214 | newthy | |
| 2215 | *current-opinfo-table* | |
| 2216 | t))))))))))) | |
| 2493 | 2217 | |
| 2494 | 2218 | ;;; EOF |
| 0 | 0 | ;;;-*- Mode:LISP; Package:CHAOS; Base:10; Syntax:Common-lisp -*- |
| 1 | 1 | ;;; |
| 2 | ;;; Copyright (c) 2000-2014, Toshimi Sawada. All rights reserved. | |
| 2 | ;;; Copyright (c) 2000-2015, Toshimi Sawada. All rights reserved. | |
| 3 | 3 | ;;; |
| 4 | 4 | ;;; Redistribution and use in source and binary forms, with or without |
| 5 | 5 | ;;; modification, are permitted provided that the following conditions |
| 27 | 27 | ;;; |
| 28 | 28 | (in-package :chaos) |
| 29 | 29 | #|============================================================================== |
| 30 | System: Chaos | |
| 31 | Module: construct | |
| 32 | File: rwl.lisp | |
| 30 | System: Chaos | |
| 31 | Module: construct | |
| 32 | File: rwl.lisp | |
| 33 | 33 | ==============================================================================|# |
| 34 | 34 | #-:chaos-debug |
| 35 | 35 | (declaim (optimize (speed 3) (safety 0) #-GCL (debug 0))) |
| 44 | 44 | ;;; |
| 45 | 45 | (defun make-congruence-axiom (opinfo module) |
| 46 | 46 | (let ((var-num 0) |
| 47 | l-arg1 | |
| 48 | l-arg2 | |
| 49 | lhs | |
| 50 | rhs-subs | |
| 51 | rhs) | |
| 47 | l-arg1 | |
| 48 | l-arg2 | |
| 49 | lhs | |
| 50 | rhs-subs | |
| 51 | rhs) | |
| 52 | 52 | (declare (type fixnum var-num)) |
| 53 | 53 | ;; |
| 54 | 54 | ;; if "oper" is 2-ary operator, then creates the following equation: |
| 56 | 56 | ;; ceq oper(t1,t2) ==> oper(t1',t2') = true if (t1 ==> t2) and (t1' ==> t2'). |
| 57 | 57 | ;; |
| 58 | 58 | (let ((methods (opinfo-methods opinfo)) |
| 59 | (ms nil) | |
| 60 | (result nil)) | |
| 59 | (ms nil) | |
| 60 | (result nil)) | |
| 61 | 61 | (unless (method-arity (car methods)) |
| 62 | (return-from make-congruence-axiom nil)) ; this case is handled by | |
| 63 | ; builtin axiom for _==>_. | |
| 62 | (return-from make-congruence-axiom nil)) ; this case is handled by | |
| 63 | ; builtin axiom for _==>_. | |
| 64 | 64 | (when (some #'(lambda (x) (method-is-universal* x)) |
| 65 | methods) | |
| 66 | (return-from make-congruence-axiom nil)) | |
| 65 | methods) | |
| 66 | (return-from make-congruence-axiom nil)) | |
| 67 | 67 | ;; |
| 68 | 68 | (dolist (m methods) |
| 69 | (let ((pmeth nil)) | |
| 70 | (block next-method | |
| 71 | (when (or (method-is-error-method m) | |
| 72 | (module-is-hard-wired (method-module m)) | |
| 73 | (method-is-behavioural m) | |
| 74 | (sort-is-hidden (method-coarity m))) | |
| 75 | (return-from next-method nil)) | |
| 76 | (setq pmeth (method-most-general-no-error m methods module)) | |
| 77 | (unless (memq pmeth ms) | |
| 78 | (push pmeth ms))))) | |
| 69 | (let ((pmeth nil)) | |
| 70 | (block next-method | |
| 71 | (when (or (method-is-error-method m) | |
| 72 | (module-is-hard-wired (method-module m)) | |
| 73 | (method-is-behavioural m) | |
| 74 | (sort-is-hidden (method-coarity m))) | |
| 75 | (return-from next-method nil)) | |
| 76 | (setq pmeth (method-most-general-no-error m methods module)) | |
| 77 | (unless (memq pmeth ms) | |
| 78 | (push pmeth ms))))) | |
| 79 | 79 | ;; ms contains most general methods |
| 80 | 80 | (dolist (method ms) |
| 81 | (block next-method | |
| 82 | (when (memq method (module-methods-with-rwl-axiom module)) | |
| 83 | (return-from next-method nil)) | |
| 84 | (push method (module-methods-with-rwl-axiom module)) | |
| 85 | (let ((vars1 (mapcar #'(lambda (x) | |
| 86 | (make-variable-term | |
| 87 | x | |
| 88 | (intern (format nil "cv~d" (incf var-num))))) | |
| 89 | (method-arity method))) | |
| 90 | (vars2 (mapcar #'(lambda (x) | |
| 91 | (make-variable-term | |
| 92 | x | |
| 93 | (intern (format nil "cv~d" (incf var-num))))) | |
| 94 | (method-arity method)))) | |
| 95 | ;; | |
| 96 | (setq l-arg1 | |
| 97 | (make-term-with-sort-check method vars1 module)) | |
| 98 | (setq l-arg2 | |
| 99 | (make-term-with-sort-check method vars2 module)) | |
| 100 | (setq lhs | |
| 101 | (make-term-with-sort-check *rwl-predicate* | |
| 102 | (list l-arg1 l-arg2) | |
| 103 | module)) | |
| 104 | (setq rhs-subs | |
| 105 | (mapcar #'(lambda (x y) | |
| 106 | (make-term-with-sort-check *rwl-predicate* | |
| 107 | (list x y) | |
| 108 | module)) | |
| 109 | vars1 | |
| 110 | vars2)) | |
| 111 | (setq rhs (reduce #'(lambda (x y) | |
| 112 | (make-term-with-sort-check *bool-and* | |
| 113 | (list x y))) | |
| 114 | rhs-subs)) | |
| 115 | (push | |
| 116 | (make-rule :lhs lhs | |
| 117 | :rhs *bool-true* | |
| 118 | :condition rhs | |
| 119 | :type :equation | |
| 120 | :kind ':rwl-congruence) | |
| 121 | result) | |
| 122 | ))) | |
| 81 | (block next-method | |
| 82 | (when (memq method (module-methods-with-rwl-axiom module)) | |
| 83 | (return-from next-method nil)) | |
| 84 | (push method (module-methods-with-rwl-axiom module)) | |
| 85 | (let ((vars1 (mapcar #'(lambda (x) | |
| 86 | (make-variable-term | |
| 87 | x | |
| 88 | (intern (format nil "cv~d" (incf var-num))))) | |
| 89 | (method-arity method))) | |
| 90 | (vars2 (mapcar #'(lambda (x) | |
| 91 | (make-variable-term | |
| 92 | x | |
| 93 | (intern (format nil "cv~d" (incf var-num))))) | |
| 94 | (method-arity method)))) | |
| 95 | ;; | |
| 96 | (setq l-arg1 | |
| 97 | (make-term-with-sort-check method vars1 module)) | |
| 98 | (setq l-arg2 | |
| 99 | (make-term-with-sort-check method vars2 module)) | |
| 100 | (setq lhs | |
| 101 | (make-term-with-sort-check *rwl-predicate* | |
| 102 | (list l-arg1 l-arg2) | |
| 103 | module)) | |
| 104 | (setq rhs-subs | |
| 105 | (mapcar #'(lambda (x y) | |
| 106 | (make-term-with-sort-check *rwl-predicate* | |
| 107 | (list x y) | |
| 108 | module)) | |
| 109 | vars1 | |
| 110 | vars2)) | |
| 111 | (setq rhs (reduce #'(lambda (x y) | |
| 112 | (make-term-with-sort-check *bool-and* | |
| 113 | (list x y))) | |
| 114 | rhs-subs)) | |
| 115 | (push | |
| 116 | (make-rule :lhs lhs | |
| 117 | :rhs *bool-true* | |
| 118 | :condition rhs | |
| 119 | :type :equation | |
| 120 | :kind ':rwl-congruence) | |
| 121 | result) | |
| 122 | ))) | |
| 123 | 123 | ;; |
| 124 | 124 | result))) |
| 125 | 125 | |
| 127 | 127 | (when (rule-is-builtin rule) |
| 128 | 128 | (return-from make-trans-relations nil)) |
| 129 | 129 | (let ((l-arg1 (rule-lhs rule)) |
| 130 | (l-arg2 (rule-rhs rule)) | |
| 131 | (cond (rule-condition rule)) | |
| 132 | lhs) | |
| 130 | (l-arg2 (rule-rhs rule)) | |
| 131 | (cond (rule-condition rule)) | |
| 132 | lhs) | |
| 133 | 133 | (setq lhs |
| 134 | (make-term-with-sort-check *rwl-predicate* | |
| 135 | (list l-arg1 l-arg2) | |
| 136 | module) | |
| 137 | ) | |
| 134 | (make-term-with-sort-check *rwl-predicate* | |
| 135 | (list l-arg1 l-arg2) | |
| 136 | module) | |
| 137 | ) | |
| 138 | 138 | (make-rule :lhs lhs |
| 139 | :rhs *bool-true* ; (if cond cond *bool-true*) | |
| 140 | :condition (if cond cond *bool-true*) ; was *bool-true* | |
| 141 | :type ':equation | |
| 142 | :kind ':rwl-transition | |
| 143 | :labels nil))) | |
| 139 | :rhs *bool-true* ; (if cond cond *bool-true*) | |
| 140 | :condition (if cond cond *bool-true*) ; was *bool-true* | |
| 141 | :type ':equation | |
| 142 | :kind ':rwl-transition | |
| 143 | :labels nil))) | |
| 144 | 144 | |
| 145 | 145 | #|| |
| 146 | 146 | (defun add-rwl-axioms (module) |
| 147 | 147 | (flet ((trans-rule (rule) |
| 148 | (unless (member rule (module-rules-with-rwl-axiom module) | |
| 149 | :test #'rule-is-similar?) | |
| 150 | (let ((ax (make-trans-relations rule module))) | |
| 151 | (when ax | |
| 152 | (adjoin-axiom-to-module module ax) | |
| 153 | (push ax (module-rules-with-rwl-axiom module))))) | |
| 154 | )) | |
| 148 | (unless (member rule (module-rules-with-rwl-axiom module) | |
| 149 | :test #'rule-is-similar?) | |
| 150 | (let ((ax (make-trans-relations rule module))) | |
| 151 | (when ax | |
| 152 | (adjoin-axiom-to-module module ax) | |
| 153 | (push ax (module-rules-with-rwl-axiom module))))) | |
| 154 | )) | |
| 155 | 155 | ;; |
| 156 | 156 | (unless (module-includes-rwl module) |
| 157 | 157 | (return-from add-rwl-axioms nil)) |
| 159 | 159 | (with-in-module (module) |
| 160 | 160 | ;; add congruence rule for ==>, one for each operator: |
| 161 | 161 | (dolist (opinfo (module-all-operators module)) |
| 162 | (let ((axs (make-congruence-axiom opinfo module))) | |
| 163 | (dolist (ax axs) | |
| 164 | (adjoin-axiom-to-module module ax)))) | |
| 162 | (let ((axs (make-congruence-axiom opinfo module))) | |
| 163 | (dolist (ax axs) | |
| 164 | (adjoin-axiom-to-module module ax)))) | |
| 165 | 165 | ;; add axiom of ==> for each rule in module. |
| 166 | 166 | (let ((tobe-fixed (module-axioms-to-be-fixed module))) |
| 167 | (dolist (rul (module-rules module)) | |
| 168 | (when (eq (axiom-type rul) :rule) | |
| 169 | (setq rul (or (cdr (assq rul tobe-fixed)) rul)) | |
| 170 | (trans-rule rul))) | |
| 171 | (dolist (rul (module-rewrite-rules module)) | |
| 172 | ; because we called even when the own | |
| 173 | ; rewrite rules are not yet set up. | |
| 174 | (when (eq (axiom-type rul) :rule) | |
| 175 | (setq rul (or (cdr (assq rul tobe-fixed)) rul)) | |
| 176 | (trans-rule rul)))) | |
| 167 | (dolist (rul (module-rules module)) | |
| 168 | (when (eq (axiom-type rul) :rule) | |
| 169 | (setq rul (or (cdr (assq rul tobe-fixed)) rul)) | |
| 170 | (trans-rule rul))) | |
| 171 | (dolist (rul (module-rewrite-rules module)) | |
| 172 | ; because we called even when the own | |
| 173 | ; rewrite rules are not yet set up. | |
| 174 | (when (eq (axiom-type rul) :rule) | |
| 175 | (setq rul (or (cdr (assq rul tobe-fixed)) rul)) | |
| 176 | (trans-rule rul)))) | |
| 177 | 177 | ))) |
| 178 | 178 | ||# |
| 179 | 179 | |
| 0 | 0 | ;;;-*- Mode:LISP; Package:CHAOS; Base:10; Syntax:Common-lisp -*- |
| 1 | 1 | ;;; |
| 2 | ;;; Copyright (c) 2000-2014, Toshimi Sawada. All rights reserved. | |
| 2 | ;;; Copyright (c) 2000-2015, Toshimi Sawada. All rights reserved. | |
| 3 | 3 | ;;; |
| 4 | 4 | ;;; Redistribution and use in source and binary forms, with or without |
| 5 | 5 | ;;; modification, are permitted provided that the following conditions |
| 27 | 27 | ;;; |
| 28 | 28 | (in-package :chaos) |
| 29 | 29 | #|============================================================================== |
| 30 | System: CHAOS | |
| 31 | Module: construct | |
| 32 | File: sort.lisp | |
| 30 | System: CHAOS | |
| 31 | Module: construct | |
| 32 | File: sort.lisp | |
| 33 | 33 | ==============================================================================|# |
| 34 | 34 | #-:chaos-debug |
| 35 | 35 | (declaim (optimize (speed 3) (safety 0) #-GCL (debug 0))) |
| 37 | 37 | (declaim (optimize (speed 1) (safety 3) #-GCL (debug 3))) |
| 38 | 38 | |
| 39 | 39 | ;;;============================================================================= |
| 40 | ;;; SORT | |
| 40 | ;;; SORT | |
| 41 | 41 | ;;;============================================================================= |
| 42 | 42 | |
| 43 | 43 | ;;; (defvar *on-sort-debug* nil) |
| 51 | 51 | (defmacro make-sort-id (symbol__$$) |
| 52 | 52 | (once-only (symbol__$$) |
| 53 | 53 | ` (if (stringp ,symbol__$$) |
| 54 | (intern ,symbol__$$) | |
| 55 | ,symbol__$$))) | |
| 54 | (intern ,symbol__$$) | |
| 55 | ,symbol__$$))) | |
| 56 | 56 | |
| 57 | 57 | (defun add-sort-to-module (sort mod) |
| 58 | 58 | ;; register sort in module |
| 78 | 78 | ;;; make new sort term if it not exist. |
| 79 | 79 | ;;; |
| 80 | 80 | (defun define-sort (sort-id-symbol module |
| 81 | &optional | |
| 82 | (type 'sort) | |
| 83 | hidden | |
| 84 | force) | |
| 81 | &optional | |
| 82 | (type 'sort) | |
| 83 | hidden | |
| 84 | force) | |
| 85 | 85 | (declare (ignore force)) |
| 86 | 86 | (setq sort-id-symbol (make-sort-id sort-id-symbol)) |
| 87 | 87 | (let ((pre (find-sort-in module sort-id-symbol)) |
| 88 | #|| | |
| 89 | (if force | |
| 90 | nil | |
| 91 | (simple-find-sort-in-local module sort-id-symbol)) | |
| 92 | ||# | |
| 93 | ) | |
| 88 | #|| | |
| 89 | (if force | |
| 90 | nil | |
| 91 | (simple-find-sort-in-local module sort-id-symbol)) | |
| 92 | ||# | |
| 93 | ) | |
| 94 | 94 | #|| |
| 95 | 95 | (when (and (not force) pre) |
| 96 | 96 | (with-output-chaos-warning () |
| 97 | (format t "sort ~s is already declared in the module " | |
| 98 | sort-id-symbol) | |
| 99 | (print-mod-name (sort-module pre)) | |
| 100 | (print-next) | |
| 101 | (princ "...ignored.") | |
| 102 | (return-from define-sort nil))) | |
| 97 | (format t "sort ~s is already declared in the module " | |
| 98 | sort-id-symbol) | |
| 99 | (print-mod-name (sort-module pre)) | |
| 100 | (print-next) | |
| 101 | (princ "...ignored.") | |
| 102 | (return-from define-sort nil))) | |
| 103 | 103 | ||# |
| 104 | 104 | (if (and pre (eq (sort-type pre) type)) |
| 105 | (progn | |
| 106 | (setf (sort-hidden pre) hidden) | |
| 107 | pre) | |
| 108 | ;; | |
| 109 | (let (sort) | |
| 110 | (case type | |
| 111 | (record-sort | |
| 112 | (setf sort (new-record-sort sort-id-symbol module hidden))) | |
| 113 | (class-sort | |
| 114 | (setf sort (new-class-sort sort-id-symbol module hidden))) | |
| 115 | (sort | |
| 116 | (setf sort (new-general-sort sort-id-symbol module hidden))) | |
| 117 | (and-sort | |
| 118 | (setf sort (new-and-sort sort-id-symbol module hidden))) | |
| 119 | (or-sort | |
| 120 | (setf sort (new-or-sort sort-id-symbol module hidden))) | |
| 121 | (t (with-output-panic-message () | |
| 122 | (format t "Unsupported type of sort ~s!" type) | |
| 123 | (chaos-error 'panic)))) | |
| 124 | ;; (register-sort sort) | |
| 125 | sort)))) | |
| 105 | (progn | |
| 106 | (setf (sort-hidden pre) hidden) | |
| 107 | pre) | |
| 108 | ;; | |
| 109 | (let (sort) | |
| 110 | (case type | |
| 111 | (record-sort | |
| 112 | (setf sort (new-record-sort sort-id-symbol module hidden))) | |
| 113 | (class-sort | |
| 114 | (setf sort (new-class-sort sort-id-symbol module hidden))) | |
| 115 | (sort | |
| 116 | (setf sort (new-general-sort sort-id-symbol module hidden))) | |
| 117 | (and-sort | |
| 118 | (setf sort (new-and-sort sort-id-symbol module hidden))) | |
| 119 | (or-sort | |
| 120 | (setf sort (new-or-sort sort-id-symbol module hidden))) | |
| 121 | (t (with-output-panic-message () | |
| 122 | (format t "Unsupported type of sort ~s!" type) | |
| 123 | (chaos-error 'panic)))) | |
| 124 | ;; (register-sort sort) | |
| 125 | sort)))) | |
| 126 | 126 | |
| 127 | 127 | ;;; DEFINE-BUILTIN-SORT |
| 128 | 128 | |
| 129 | 129 | (defun define-builtin-sort (sort-id-symbol &optional |
| 130 | (module *chaos-module*) | |
| 131 | (info nil) | |
| 132 | (hidden nil) | |
| 133 | (force nil)) | |
| 130 | (module *chaos-module*) | |
| 131 | (info nil) | |
| 132 | (hidden nil) | |
| 133 | (force nil)) | |
| 134 | 134 | (setq sort-id-symbol (make-sort-id sort-id-symbol)) |
| 135 | 135 | (let ((pre (if force |
| 136 | nil | |
| 137 | (simple-find-sort-in-local module sort-id-symbol))) | |
| 138 | sort) | |
| 136 | nil | |
| 137 | (simple-find-sort-in-local module sort-id-symbol))) | |
| 138 | sort) | |
| 139 | 139 | (if pre |
| 140 | (setf sort pre) | |
| 141 | (setf sort (new-bi-sort sort-id-symbol module))) | |
| 140 | (setf sort pre) | |
| 141 | (setf sort (new-bi-sort sort-id-symbol module))) | |
| 142 | 142 | (setf (bsort-info sort) info) |
| 143 | 143 | (setf (bsort-hidden sort) hidden) |
| 144 | 144 | (add-builtin-sort sort module) |
| 152 | 152 | #|| |
| 153 | 153 | (when (eq module *chaos-module*) |
| 154 | 154 | (setf (symbol-function |
| 155 | (intern (format nil | |
| 156 | "THE-~A-SORT" (string-upcase (sort-print-name sort))))) | |
| 157 | #'(lambda () sort))) | |
| 155 | (intern (format nil | |
| 156 | "THE-~A-SORT" (string-upcase (sort-print-name sort))))) | |
| 157 | #'(lambda () sort))) | |
| 158 | 158 | ||# |
| 159 | 159 | (add-sort-to-module sort module) |
| 160 | 160 | sort) |
| 164 | 164 | (defun define-and-sort (sort-id-symbol module components &optional hidden) |
| 165 | 165 | (setq sort-id-symbol (make-sort-id sort-id-symbol)) |
| 166 | 166 | (let ((pre (or (get-sort-named sort-id-symbol module) |
| 167 | (simple-find-sort-in-local module sort-id-symbol)))) | |
| 167 | (simple-find-sort-in-local module sort-id-symbol)))) | |
| 168 | 168 | (if pre |
| 169 | pre | |
| 170 | (let ((sort (new-and-sort sort-id-symbol module components hidden))) | |
| 171 | (register-sort-cache sort) | |
| 172 | sort)))) | |
| 169 | pre | |
| 170 | (let ((sort (new-and-sort sort-id-symbol module components hidden))) | |
| 171 | (register-sort-cache sort) | |
| 172 | sort)))) | |
| 173 | 173 | |
| 174 | 174 | ;;; DEFINE-OR-SORT |
| 175 | 175 | ;;; |
| 176 | 176 | (defun define-or-sort (sort-id-symbol module components &optional hidden) |
| 177 | 177 | (setq sort-id-symbol (make-sort-id sort-id-symbol)) |
| 178 | 178 | (let ((pre (or (get-sort-named sort-id-symbol module) |
| 179 | (simple-find-sort-in-local module sort-id-symbol)))) | |
| 179 | (simple-find-sort-in-local module sort-id-symbol)))) | |
| 180 | 180 | (if pre |
| 181 | pre | |
| 182 | (let ((sort (new-or-sort sort-id-symbol module components hidden))) | |
| 183 | (register-sort-cache sort) | |
| 184 | sort)))) | |
| 181 | pre | |
| 182 | (let ((sort (new-or-sort sort-id-symbol module components hidden))) | |
| 183 | (register-sort-cache sort) | |
| 184 | sort)))) | |
| 185 | 185 | |
| 186 | 186 | ;;; DEFINE-ERR-SORT |
| 187 | 187 | ;;; |
| 188 | 188 | (defun define-err-sort (sort-id-symbol module components &optional subs hidden) |
| 189 | 189 | (setq sort-id-symbol (make-sort-id sort-id-symbol)) |
| 190 | 190 | (let ((pre (or (get-sort-named sort-id-symbol module) |
| 191 | (simple-find-sort-in-local module sort-id-symbol)))) | |
| 191 | (simple-find-sort-in-local module sort-id-symbol)))) | |
| 192 | 192 | (if pre |
| 193 | pre | |
| 194 | (let ((sort (new-err-sort sort-id-symbol | |
| 195 | module | |
| 196 | components | |
| 197 | subs | |
| 198 | hidden))) | |
| 199 | (register-sort-cache sort) | |
| 200 | sort)))) | |
| 193 | pre | |
| 194 | (let ((sort (new-err-sort sort-id-symbol | |
| 195 | module | |
| 196 | components | |
| 197 | subs | |
| 198 | hidden))) | |
| 199 | (register-sort-cache sort) | |
| 200 | sort)))) | |
| 201 | 201 | |
| 202 | 202 | ;;; ****** |
| 203 | 203 | ;;; COPIER ____________________________________________________________________ |
| 208 | 208 | (defun %copy-sort (sort module &optional new-name force) |
| 209 | 209 | (let ((name (if new-name new-name (sort-id sort)))) |
| 210 | 210 | (let ((new-sort |
| 211 | (if (sort-is-builtin sort) | |
| 212 | (define-builtin-sort name | |
| 213 | module | |
| 214 | (bsort-info sort) | |
| 215 | (sort-is-hidden sort) | |
| 216 | force) | |
| 217 | (define-sort name | |
| 218 | module | |
| 219 | (sort-type sort) | |
| 220 | (sort-is-hidden sort) | |
| 221 | force)))) | |
| 211 | (if (sort-is-builtin sort) | |
| 212 | (define-builtin-sort name | |
| 213 | module | |
| 214 | (bsort-info sort) | |
| 215 | (sort-is-hidden sort) | |
| 216 | force) | |
| 217 | (define-sort name | |
| 218 | module | |
| 219 | (sort-type sort) | |
| 220 | (sort-is-hidden sort) | |
| 221 | force)))) | |
| 222 | 222 | ;; |
| 223 | 223 | (setf (sort-derived-from new-sort) sort) |
| 224 | 224 | ;; |
| 225 | 225 | (cond ((memq (sort-type sort) '(class-sort record-sort)) |
| 226 | ;; | |
| 227 | (setf (crsort-is-a-copy new-sort) t) | |
| 228 | ;; obsolate values, but for the future..... | |
| 229 | (with-output-panic-message () | |
| 230 | (princ "sorry, but copying record/class sort is not yet properly supported!")) | |
| 231 | ) | |
| 232 | ((eq (sort-type sort) 'and-sort) | |
| 233 | (setf (and-sort-components new-sort) | |
| 234 | (mapcar #'(lambda (s) (%copy-sort s module)) | |
| 235 | (and-sort-components sort))) | |
| 236 | (with-output-chaos-warning () | |
| 237 | (princ "sorry, but copying `and-sort' is not yet properly supported!")) | |
| 238 | ) | |
| 239 | ((eq (sort-type sort) 'or-sort) | |
| 240 | (setf (or-sort-components new-sort) | |
| 241 | (mapcar #'(lambda (s) (%copy-sort s module)) | |
| 242 | (or-sort-components sort))) | |
| 243 | (with-output-chaos-warning () | |
| 244 | (princ "sorry, but copying `or-sort' is not yet properly supported!")) | |
| 245 | )) | |
| 226 | ;; | |
| 227 | (setf (crsort-is-a-copy new-sort) t) | |
| 228 | ;; obsolate values, but for the future..... | |
| 229 | (with-output-panic-message () | |
| 230 | (princ "sorry, but copying record/class sort is not yet properly supported!")) | |
| 231 | ) | |
| 232 | ((eq (sort-type sort) 'and-sort) | |
| 233 | (setf (and-sort-components new-sort) | |
| 234 | (mapcar #'(lambda (s) (%copy-sort s module)) | |
| 235 | (and-sort-components sort))) | |
| 236 | (with-output-chaos-warning () | |
| 237 | (princ "sorry, but copying `and-sort' is not yet properly supported!")) | |
| 238 | ) | |
| 239 | ((eq (sort-type sort) 'or-sort) | |
| 240 | (setf (or-sort-components new-sort) | |
| 241 | (mapcar #'(lambda (s) (%copy-sort s module)) | |
| 242 | (or-sort-components sort))) | |
| 243 | (with-output-chaos-warning () | |
| 244 | (princ "sorry, but copying `or-sort' is not yet properly supported!")) | |
| 245 | )) | |
| 246 | 246 | ;; |
| 247 | 247 | new-sort))) |
| 248 | 248 | |
| 266 | 266 | ;;; | / / \ |
| 267 | 267 | ;;; | / / \ |
| 268 | 268 | ;;; | / Zero Posint |
| 269 | ;;; | / | |
| 269 | ;;; | / | |
| 270 | 270 | ;;; Bool^Natural |
| 271 | 271 | ;;; |
| 272 | 272 | (defun glb-sort (s1 s2 |
| 273 | &optional | |
| 274 | (module *current-module*) | |
| 275 | (order *current-sort-order*) | |
| 276 | ) | |
| 273 | &optional | |
| 274 | (module *current-module*) | |
| 275 | (order *current-sort-order*) | |
| 276 | ) | |
| 277 | 277 | (cond ((sort<= s1 s2) s1) |
| 278 | ((sort< s2 s1) s2) | |
| 279 | (t (let ((meet (meet-of-sorts s1 s2 order)) | |
| 280 | sort) | |
| 281 | (when (and (= 1 (length meet)) | |
| 282 | (and-sort-p (car meet))) | |
| 283 | ;; glb already exists. we don't need to create. | |
| 284 | (return-from glb-sort (car meet))) | |
| 285 | ;; creates GLB | |
| 286 | (setq sort (make-glb-sort (list s1 s2) module)) | |
| 287 | (add-sort-to-module sort module) | |
| 288 | #|| | |
| 289 | (setq sl (make-sort-relation sort | |
| 290 | (remove-if #'(lambda (x) (sort= x sort)) meet) | |
| 291 | (and-sort-components sort))) | |
| 292 | ||# | |
| 293 | (declare-subsort-in-module `((,@(remove-if #'(lambda (x) (sort= x sort)) meet) | |
| 294 | :< ,sort :< ,@(and-sort-components sort))) | |
| 295 | module) | |
| 296 | sort)))) | |
| 278 | ((sort< s2 s1) s2) | |
| 279 | (t (let ((meet (meet-of-sorts s1 s2 order)) | |
| 280 | sort) | |
| 281 | (when (and (= 1 (length meet)) | |
| 282 | (and-sort-p (car meet))) | |
| 283 | ;; glb already exists. we don't need to create. | |
| 284 | (return-from glb-sort (car meet))) | |
| 285 | ;; creates GLB | |
| 286 | (setq sort (make-glb-sort (list s1 s2) module)) | |
| 287 | (add-sort-to-module sort module) | |
| 288 | #|| | |
| 289 | (setq sl (make-sort-relation sort | |
| 290 | (remove-if #'(lambda (x) (sort= x sort)) meet) | |
| 291 | (and-sort-components sort))) | |
| 292 | ||# | |
| 293 | (declare-subsort-in-module `((,@(remove-if #'(lambda (x) (sort= x sort)) meet) | |
| 294 | :< ,sort :< ,@(and-sort-components sort))) | |
| 295 | module) | |
| 296 | sort)))) | |
| 297 | 297 | |
| 298 | 298 | ;;; MAKE-GLB-SORT components join module order |
| 299 | 299 | ;;; |
| 300 | 300 | (defun gather-and-components (sort) |
| 301 | 301 | (let ((compo nil)) |
| 302 | 302 | (cond ((and-sort-p sort) |
| 303 | (setq compo (nconc compo | |
| 304 | (mapcan #'(lambda (x) | |
| 305 | (gather-and-components x)) | |
| 306 | (copy-list (and-sort-components sort)))))) | |
| 307 | (t (setq compo (nconc compo (list sort))))) | |
| 303 | (setq compo (nconc compo | |
| 304 | (mapcan #'(lambda (x) | |
| 305 | (gather-and-components x)) | |
| 306 | (copy-list (and-sort-components sort)))))) | |
| 307 | (t (setq compo (nconc compo (list sort))))) | |
| 308 | 308 | compo)) |
| 309 | 309 | |
| 310 | 310 | (defun canonicalize-and-components (components sort-order) |
| 311 | 311 | (let ((canon-compo nil)) |
| 312 | 312 | (dolist (compo components) |
| 313 | 313 | (setq canon-compo (nconc canon-compo |
| 314 | (gather-and-components compo)))) | |
| 314 | (gather-and-components compo)))) | |
| 315 | 315 | (minimal-sorts (delete-duplicates canon-compo :test #'eq) |
| 316 | sort-order))) | |
| 316 | sort-order))) | |
| 317 | 317 | |
| 318 | 318 | (defun glb-sort-name (sorts) |
| 319 | 319 | (let ((compo-names (sort (mapcan #'(lambda (s) |
| 320 | (if (and-sort-p s) | |
| 321 | (mapcar #'(lambda(x) (sort-id x)) | |
| 322 | (and-sort-components s)) | |
| 323 | (list (sort-id s)))) | |
| 324 | sorts) | |
| 325 | #'(lambda (x y) | |
| 326 | (string< (the simple-string (string x)) | |
| 327 | (the simple-string (string y))))))) | |
| 320 | (if (and-sort-p s) | |
| 321 | (mapcar #'(lambda(x) (sort-id x)) | |
| 322 | (and-sort-components s)) | |
| 323 | (list (sort-id s)))) | |
| 324 | sorts) | |
| 325 | #'(lambda (x y) | |
| 326 | (string< (the simple-string (string x)) | |
| 327 | (the simple-string (string y))))))) | |
| 328 | 328 | (setf compo-names (sort |
| 329 | (mapcar #'string | |
| 330 | (delete-duplicates compo-names :test #'eq)) | |
| 331 | #'(lambda (id1 id2) | |
| 332 | (string<= (the simple-string id1) | |
| 333 | (the simple-string id2))))) | |
| 329 | (mapcar #'string | |
| 330 | (delete-duplicates compo-names :test #'eq)) | |
| 331 | #'(lambda (id1 id2) | |
| 332 | (string<= (the simple-string id1) | |
| 333 | (the simple-string id2))))) | |
| 334 | 334 | (if (cdr compo-names) |
| 335 | (intern (format nil "~{~^~A~^^~}" compo-names)) | |
| 336 | (intern (format nil "^~A" (car compo-names)))))) | |
| 335 | (intern (format nil "~{~^~A~^^~}" compo-names)) | |
| 336 | (intern (format nil "^~A" (car compo-names)))))) | |
| 337 | 337 | |
| 338 | 338 | (defun make-glb-sort (components &optional |
| 339 | (module *current-module*)) | |
| 339 | (module *current-module*)) | |
| 340 | 340 | (setq components (canonicalize-and-components components |
| 341 | (module-sort-order module))) | |
| 341 | (module-sort-order module))) | |
| 342 | 342 | (let ((sort-id (glb-sort-name components)) |
| 343 | (glb nil)) | |
| 343 | (glb nil)) | |
| 344 | 344 | (setf glb (find-sort-in module sort-id)) |
| 345 | 345 | (if glb |
| 346 | glb | |
| 347 | (define-and-sort sort-id module components)))) | |
| 346 | glb | |
| 347 | (define-and-sort sort-id module components)))) | |
| 348 | 348 | |
| 349 | 349 | ;;; JOIN-OF-SORTS sort1 sor2 order |
| 350 | 350 | ;;; |
| 351 | 351 | (defun join-of-sorts (sort1 sort2 &optional (order *current-sort-order*)) |
| 352 | 352 | (cond ((sort= sort1 sort2) (list sort1)) |
| 353 | ((sort< sort1 sort2 order) (list sort2)) | |
| 354 | ((sort< sort2 sort1 order) (list sort1)) | |
| 355 | (t (minimal-sorts (intersection (supersorts sort1 order) (supersorts | |
| 356 | sort2 order)) | |
| 357 | order)))) | |
| 353 | ((sort< sort1 sort2 order) (list sort2)) | |
| 354 | ((sort< sort2 sort1 order) (list sort1)) | |
| 355 | (t (minimal-sorts (intersection (supersorts sort1 order) (supersorts | |
| 356 | sort2 order)) | |
| 357 | order)))) | |
| 358 | 358 | |
| 359 | 359 | ;;; LUB-SORT s1 s2 module-id order |
| 360 | 360 | ;;; Finds LUB of s1 s2, if it does not exist, create the actual LUB which have |
| 371 | 371 | ;;; |
| 372 | 372 | ;;; Bool|Natural |
| 373 | 373 | ;;; / | |
| 374 | ;;; / | | |
| 374 | ;;; / | | |
| 375 | 375 | ;;; Bool Natural |
| 376 | 376 | ;;; / \ |
| 377 | 377 | ;;; / \ |
| 381 | 381 | |
| 382 | 382 | (defmacro lub-sort-name (sorts____?) |
| 383 | 383 | ` (intern (format nil "~{~^~A~^|~}" |
| 384 | (sort (mapcar #'(lambda (s) (string (sort-id s))) | |
| 385 | ,sorts____?) | |
| 386 | #'(lambda (id1 id2) | |
| 387 | (declare (type simple-string id1 id2)) | |
| 388 | (string< id1 id2)))))) | |
| 384 | (sort (mapcar #'(lambda (s) (string (sort-id s))) | |
| 385 | ,sorts____?) | |
| 386 | #'(lambda (id1 id2) | |
| 387 | (declare (type simple-string id1 id2)) | |
| 388 | (string< id1 id2)))))) | |
| 389 | 389 | |
| 390 | 390 | (defun lub-sort (s1 s2 &optional (module *current-module*) (order *current-sort-order*)) |
| 391 | 391 | (let ((join (join-of-sorts s1 s2 order))) |
| 392 | 392 | (if (= 1 (length join)) |
| 393 | ;; minimum exists. we don't nee to create. | |
| 394 | (return-from lub-sort (car join)) | |
| 395 | ;; creates the new one. | |
| 396 | (make-lub-sort (list s1 s2) join module)))) | |
| 393 | ;; minimum exists. we don't nee to create. | |
| 394 | (return-from lub-sort (car join)) | |
| 395 | ;; creates the new one. | |
| 396 | (make-lub-sort (list s1 s2) join module)))) | |
| 397 | 397 | |
| 398 | 398 | ;;; MAKE-LUB-SORT components join module order |
| 399 | 399 | |
| 400 | 400 | (defun make-lub-sort (components join |
| 401 | &optional | |
| 402 | (module *current-module*)) | |
| 401 | &optional | |
| 402 | (module *current-module*)) | |
| 403 | 403 | (let* ((sort-id (lub-sort-name components)) |
| 404 | (lub (define-or-sort sort-id module components))) | |
| 404 | (lub (define-or-sort sort-id module components))) | |
| 405 | 405 | (add-sort-to-module lub module) |
| 406 | 406 | (declare-subsort-in-module `((,@components :< ,lub ,@join)) module) |
| 407 | 407 | lub)) |
| 412 | 412 | ;;; Example: |
| 413 | 413 | ;;; |
| 414 | 414 | ;;; NameRef ObjectID Number |
| 415 | ;;; | /| \ \ | | |
| 416 | ;;; | / | \ \ | | |
| 417 | ;;; | / | \ \ | | |
| 418 | ;;; Identifier ... String Integer | |
| 415 | ;;; | /| \ \ | | |
| 416 | ;;; | / | \ \ | | |
| 417 | ;;; | / | \ \ | | |
| 418 | ;;; Identifier ... String Integer | |
| 419 | 419 | ;;; |
| 420 | 420 | ;;; applying `generate-err-sorts' to this sort-order will make |
| 421 | 421 | ;;; |
| 422 | 422 | ;;; ?:-NameRef+Number+ObjectID --- generated err-sort |
| 423 | ;;; / | \ | |
| 424 | ;;; / | \ | |
| 425 | ;;; / | \ | |
| 423 | ;;; / | \ | |
| 424 | ;;; / | \ | |
| 425 | ;;; / | \ | |
| 426 | 426 | ;;; NameRef ObjectID Number |
| 427 | ;;; | /| \ \ | | |
| 428 | ;;; | / | \ \ | | |
| 429 | ;;; | / | \ \ | | |
| 430 | ;;; Identifier ... String Integer | |
| 427 | ;;; | /| \ \ | | |
| 428 | ;;; | / | \ \ | | |
| 429 | ;;; | / | \ \ | | |
| 430 | ;;; Identifier ... String Integer | |
| 431 | 431 | ;;; |
| 432 | 432 | ;;; |
| 433 | 433 | (defmacro make-err-sort-name (components____!?) |
| 434 | 434 | ` (intern (format nil "?~{~^~A~^+~}" |
| 435 | (sort (mapcar #'(lambda (s) (string (sort-id s))) | |
| 436 | ,components____!?) | |
| 437 | #'(lambda (x y) (string< x y)))))) | |
| 435 | (sort (mapcar #'(lambda (s) (string (sort-id s))) | |
| 436 | ,components____!?) | |
| 437 | #'(lambda (x y) (string< x y)))))) | |
| 438 | 438 | |
| 439 | 439 | (defun generate-err-sorts (&optional (sort-order *current-sort-order*) |
| 440 | (module *current-module*)) | |
| 440 | (module *current-module*)) | |
| 441 | 441 | (flet ((find-the-equivalent-error-sort (id components olds) |
| 442 | (find-if #'(lambda (es) | |
| 443 | (let ((name (sort-id es))) | |
| 444 | (and (eq id name) | |
| 445 | (sort-set-equal (err-sort-components es) | |
| 446 | components)))) | |
| 447 | olds)) | |
| 448 | ) | |
| 442 | (find-if #'(lambda (es) | |
| 443 | (let ((name (sort-id es))) | |
| 444 | (and (eq id name) | |
| 445 | (sort-set-equal (err-sort-components es) | |
| 446 | components)))) | |
| 447 | olds)) | |
| 448 | ) | |
| 449 | 449 | ;; |
| 450 | 450 | (let ((old-errs (module-error-sorts module)) ; imported + generated. |
| 451 | (all-errors nil)) ; the list of all error sort | |
| 452 | ; newly generated. | |
| 451 | (all-errors nil)) ; the list of all error sort | |
| 452 | ; newly generated. | |
| 453 | 453 | (declare (type list old-errs)) |
| 454 | 454 | ;; first, we clear all pre-defined error sorts. |
| 455 | 455 | (clear-err-sorts sort-order) |
| 458 | 458 | ;; we now allow the non-filterd signature, ie, there can be multiple tops |
| 459 | 459 | ;; for a connected component. |
| 460 | 460 | (let ((maximal (maximal-sorts-no-error |
| 461 | (let ((res nil)) | |
| 462 | (maphash #'(lambda (sort relation) | |
| 463 | (declare (ignore relation)) | |
| 464 | (push sort res)) | |
| 465 | sort-order) | |
| 466 | res) | |
| 467 | sort-order))) | |
| 468 | (while maximal | |
| 469 | (let* ((s (car maximal)) | |
| 470 | (subs (sub-or-equal-sorts s sort-order)) | |
| 471 | (all-subs subs) | |
| 472 | (same-compo (list s)) | |
| 473 | (sname nil) | |
| 474 | (found nil) | |
| 475 | (hidden nil) | |
| 476 | err-sort) | |
| 477 | ;; gather tops in the same connected component. | |
| 478 | ;; if found one, we again must walk through the rest. | |
| 479 | (loop (setf found nil) | |
| 480 | (dolist (m (cdr maximal)) | |
| 481 | (let ((msub (sub-or-equal-sorts m sort-order))) | |
| 482 | (when (intersection all-subs msub :test #'eq) | |
| 483 | (setf all-subs (union all-subs msub :test #'eq)) | |
| 484 | (setf found t) | |
| 485 | (push m same-compo)))) | |
| 486 | (setf maximal (set-difference maximal same-compo)) | |
| 487 | (when (or (null maximal) (not found)) (return))) | |
| 488 | ;; | |
| 489 | (setq hidden (sort-is-hidden (car same-compo))) | |
| 490 | (setq sname (make-err-sort-name same-compo)) | |
| 491 | (let ((old (find-the-equivalent-error-sort | |
| 492 | sname | |
| 493 | same-compo | |
| 494 | old-errs))) | |
| 495 | ;; for debug | |
| 496 | (when *on-sort-debug* | |
| 497 | (with-output-simple-msg () | |
| 498 | (format t "~%[generate-err-sorts]: name = ~a" sname) | |
| 499 | (format t "~%- predefined : ~a" old) | |
| 500 | (when old | |
| 501 | (format t "~% with compo = ~a" (err-sort-components old))) | |
| 502 | )) | |
| 503 | ;; | |
| 504 | (if old | |
| 505 | ;; use the existing one. | |
| 506 | (progn | |
| 507 | (setq err-sort old) | |
| 508 | (setq old-errs (delete old old-errs :test #'eq))) | |
| 509 | ;; we need brand new sort. | |
| 510 | (setq err-sort (define-err-sort sname | |
| 511 | module | |
| 512 | same-compo | |
| 513 | all-subs | |
| 514 | hidden))) | |
| 515 | (push err-sort all-errors) | |
| 516 | (dolist (a all-subs) | |
| 517 | (setf (the-err-sort a sort-order) err-sort))))) | |
| 518 | ;; done all. | |
| 519 | (setf (module-error-sorts module) all-errors) | |
| 520 | ;; returns obsolete sorts. | |
| 521 | old-errs)))) | |
| 461 | (let ((res nil)) | |
| 462 | (maphash #'(lambda (sort relation) | |
| 463 | (declare (ignore relation)) | |
| 464 | (push sort res)) | |
| 465 | sort-order) | |
| 466 | res) | |
| 467 | sort-order))) | |
| 468 | (while maximal | |
| 469 | (let* ((s (car maximal)) | |
| 470 | (subs (sub-or-equal-sorts s sort-order)) | |
| 471 | (all-subs subs) | |
| 472 | (same-compo (list s)) | |
| 473 | (sname nil) | |
| 474 | (found nil) | |
| 475 | (hidden nil) | |
| 476 | err-sort) | |
| 477 | ;; gather tops in the same connected component. | |
| 478 | ;; if found one, we again must walk through the rest. | |
| 479 | (loop (setf found nil) | |
| 480 | (dolist (m (cdr maximal)) | |
| 481 | (let ((msub (sub-or-equal-sorts m sort-order))) | |
| 482 | (when (intersection all-subs msub :test #'eq) | |
| 483 | (setf all-subs (union all-subs msub :test #'eq)) | |
| 484 | (setf found t) | |
| 485 | (push m same-compo)))) | |
| 486 | (setf maximal (set-difference maximal same-compo)) | |
| 487 | (when (or (null maximal) (not found)) (return))) | |
| 488 | ;; | |
| 489 | (setq hidden (sort-is-hidden (car same-compo))) | |
| 490 | (setq sname (make-err-sort-name same-compo)) | |
| 491 | (let ((old (find-the-equivalent-error-sort | |
| 492 | sname | |
| 493 | same-compo | |
| 494 | old-errs))) | |
| 495 | ;; for debug | |
| 496 | (when *on-sort-debug* | |
| 497 | (with-output-simple-msg () | |
| 498 | (format t "~%[generate-err-sorts]: name = ~a" sname) | |
| 499 | (format t "~%- predefined : ~a" old) | |
| 500 | (when old | |
| 501 | (format t "~% with compo = ~a" (err-sort-components old))) | |
| 502 | )) | |
| 503 | ;; | |
| 504 | (if old | |
| 505 | ;; use the existing one. | |
| 506 | (progn | |
| 507 | (setq err-sort old) | |
| 508 | (setq old-errs (delete old old-errs :test #'eq))) | |
| 509 | ;; we need brand new sort. | |
| 510 | (setq err-sort (define-err-sort sname | |
| 511 | module | |
| 512 | same-compo | |
| 513 | all-subs | |
| 514 | hidden))) | |
| 515 | (push err-sort all-errors) | |
| 516 | (dolist (a all-subs) | |
| 517 | (setf (the-err-sort a sort-order) err-sort))))) | |
| 518 | ;; done all. | |
| 519 | (setf (module-error-sorts module) all-errors) | |
| 520 | ;; returns obsolete sorts. | |
| 521 | old-errs)))) | |
| 522 | 522 | |
| 523 | 523 | ;;; **************** |
| 524 | 524 | ;;; SORT DECLARATION ___________________________________________________________ |
| 527 | 527 | ;;; DECLARE-SORT-IN-MODLE : sort-name module -> sort |
| 528 | 528 | ;;; |
| 529 | 529 | (defun declare-sort-in-module (sort-name &optional |
| 530 | (module *current-module*) | |
| 531 | (type 'sort) | |
| 532 | (hidden nil)) | |
| 530 | (module *current-module*) | |
| 531 | (type 'sort) | |
| 532 | (hidden nil)) | |
| 533 | 533 | (let ((mod (if (module-p module) |
| 534 | module | |
| 535 | (find-module-in-env module)))) | |
| 534 | module | |
| 535 | (find-module-in-env module)))) | |
| 536 | 536 | (unless mod |
| 537 | 537 | (with-output-chaos-error ('no-such-module) |
| 538 | (princ "declaring sort, no such module ") | |
| 539 | (print-mod-name module) | |
| 540 | )) | |
| 538 | (princ "declaring sort, no such module ") | |
| 539 | (print-mod-name module) | |
| 540 | )) | |
| 541 | 541 | ;; |
| 542 | 542 | (when (or (eq sort-name $name-cosmos) |
| 543 | (eq sort-name $name-universal) | |
| 544 | (eq sort-name $name-huniversal)) | |
| 543 | (eq sort-name $name-universal) | |
| 544 | (eq sort-name $name-huniversal)) | |
| 545 | 545 | (with-output-chaos-error ('reserved-sort) |
| 546 | (format t "Sort name ~A is reserfed for the system, sorry." | |
| 547 | sort-name))) | |
| 546 | (format t "Sort name ~A is reserfed for the system, sorry." | |
| 547 | sort-name))) | |
| 548 | 548 | ;; |
| 549 | 549 | (set-needs-parse module) |
| 550 | 550 | (include-BOOL module) |
| 558 | 558 | (defun recreate-sort (module sort &optional new-name) |
| 559 | 559 | (let ((sort-name (sort-id sort))) |
| 560 | 560 | (when *on-sort-debug* |
| 561 | (format t "~&[recreate-sort] : given name ~s, new-name = ~s" | |
| 562 | sort-name new-name)) | |
| 561 | (format t "~%[recreate-sort] : given name ~s, new-name = ~s" | |
| 562 | sort-name new-name)) | |
| 563 | 563 | ;; |
| 564 | 564 | (let ((val (find-sort-in module (if new-name new-name sort-name)))) |
| 565 | 565 | (if val |
| 566 | val | |
| 567 | (let ((newsort (%copy-sort sort module new-name))) | |
| 568 | (when *on-sort-debug* | |
| 569 | (format t "~& - created ~s" (sort-id newsort)) | |
| 570 | (format t " in ") | |
| 571 | (print-modexp module)) | |
| 572 | newsort | |
| 573 | ))))) | |
| 566 | val | |
| 567 | (let ((newsort (%copy-sort sort module new-name))) | |
| 568 | (when *on-sort-debug* | |
| 569 | (format t "~% - created ~s" (sort-id newsort)) | |
| 570 | (format t " in ") | |
| 571 | (print-modexp module)) | |
| 572 | newsort | |
| 573 | ))))) | |
| 574 | 574 | |
| 575 | 575 | (defun recreate-sorts (module sort-list) |
| 576 | 576 | (mapcar #'(lambda (s) (recreate-sort module s)) |
| 577 | sort-list)) | |
| 577 | sort-list)) | |
| 578 | 578 | |
| 579 | 579 | (defun !recreate-sort (module sort &optional new-name) |
| 580 | 580 | (let ((newsort (%copy-sort sort module new-name))) |
| 582 | 582 | |
| 583 | 583 | (defun !recreate-sorts (module sort-list) |
| 584 | 584 | (mapcar #'(lambda (s) (!recreate-sort module s)) |
| 585 | sort-list)) | |
| 585 | sort-list)) | |
| 586 | 586 | |
| 587 | 587 | ;;; SUBSORT DECLARATION ________________________________________________________ |
| 588 | 588 | |
| 590 | 590 | ;;; order-decls : list of (sort supers) |
| 591 | 591 | ;;; |
| 592 | 592 | (defun declare-subsort-in-module (order-decls &optional (module *current-module*) |
| 593 | hidden) | |
| 593 | hidden) | |
| 594 | 594 | ;; (declare (optimize (speed 3) (safety 0))) |
| 595 | 595 | (let* ((mod (if (module-p module) |
| 596 | module | |
| 597 | (find-module-in-env module))) | |
| 598 | (sort-order (if mod (module-sort-order mod) | |
| 599 | ;; internal error | |
| 600 | (error "No such module: declare-subsort-in-module ~A" module)))) | |
| 596 | module | |
| 597 | (find-module-in-env module))) | |
| 598 | (sort-order (if mod (module-sort-order mod) | |
| 599 | ;; internal error | |
| 600 | (error "No such module: declare-subsort-in-module ~A" module)))) | |
| 601 | 601 | (declare (type sort-order sort-order)) |
| 602 | 602 | (dolist (decl order-decls) |
| 603 | 603 | (declare (type list decl)) |
| 612 | 612 | ;;; |
| 613 | 613 | (defun adjoin-sort-relation (sl module) |
| 614 | 614 | (let ((s (sort-relation-sort sl)) |
| 615 | (rls (module-sort-relations module))) | |
| 615 | (rls (module-sort-relations module))) | |
| 616 | 616 | (let ((pre (assq s rls))) |
| 617 | 617 | (if pre |
| 618 | (progn (setf (_subsorts pre) | |
| 619 | (union (_subsorts sl) (_subsorts pre) :test #'eq)) | |
| 620 | (setf (_supersorts pre) | |
| 621 | (union (_supersorts sl) (_supersorts pre) :test #'eq))) | |
| 622 | (push sl (module-sort-relations module)))))) | |
| 618 | (progn (setf (_subsorts pre) | |
| 619 | (union (_subsorts sl) (_subsorts pre) :test #'eq)) | |
| 620 | (setf (_supersorts pre) | |
| 621 | (union (_supersorts sl) (_supersorts pre) :test #'eq))) | |
| 622 | (push sl (module-sort-relations module)))))) | |
| 623 | 623 | |
| 624 | 624 | #|| BAD THING !!! |
| 625 | 625 | (defun clean-up-sort-relations (module) |
| 640 | 640 | (declare (type list sls)) |
| 641 | 641 | (when sls |
| 642 | 642 | (dolist (sl sls) |
| 643 | (adjoin-sort-relation sl module) | |
| 644 | (add-relation-to-order (copy-sort-relation sl) sort-order))))) | |
| 643 | (adjoin-sort-relation sl module) | |
| 644 | (add-relation-to-order (copy-sort-relation sl) sort-order))))) | |
| 645 | 645 | |
| 646 | 646 | ;;; CONSTRUCT-SORT-RELATIONS <SubSortDecl> |
| 647 | 647 | ;;; Returns the list of sort-relations derived from the given |
| 649 | 649 | ;;; |
| 650 | 650 | (defun construct-sort-relations (order-decl &optional (module *current-module*) hidden) |
| 651 | 651 | (let ((*current-module* module) |
| 652 | (res nil) | |
| 653 | (tmp nil) | |
| 654 | (work nil)) | |
| 652 | (res nil) | |
| 653 | (tmp nil) | |
| 654 | (work nil)) | |
| 655 | 655 | (declare (type list res tmp work)) |
| 656 | 656 | (dolist (sid order-decl) |
| 657 | 657 | ;; sid can be a list (sort-id module-name) |
| 658 | 658 | (if (eq sid ':<) |
| 659 | (progn (push work tmp) | |
| 660 | (setq work nil)) | |
| 661 | (let ((sort (find-sort-in module sid))) | |
| 662 | (when (or (eq sort *cosmos*) | |
| 663 | (eq sort *universal-sort*) | |
| 664 | (eq sort *huniversal-sort*)) | |
| 665 | (let ((*chaos-quiet* t)) | |
| 666 | (with-output-chaos-error ('invalid-sort-relation) | |
| 667 | (format t "You can not specify the order with built in sort ~A." | |
| 668 | (string (sort-name sort)))))) | |
| 669 | ;; | |
| 670 | (if sort | |
| 671 | (progn | |
| 672 | (when hidden | |
| 673 | (unless (sort-is-hidden sort) | |
| 674 | (with-output-chaos-error ('invalid-subsort-decl) | |
| 675 | (princ "you cannot declare subsort relation between hidden and visible sorts.") | |
| 676 | (print-next) | |
| 677 | (princ "the sort ") (print-sort-name sort) | |
| 678 | (princ " is visible, but must be hidden in this context.") | |
| 679 | ))) | |
| 680 | (push sort work)) | |
| 681 | (with-output-chaos-error ('no-such-sort) | |
| 682 | (princ "constructing sort relation, no such sort with name ") | |
| 683 | (if (term? sid) | |
| 684 | (term-print sid) | |
| 685 | (princ sid)) | |
| 686 | ) | |
| 687 | )))) | |
| 659 | (progn (push work tmp) | |
| 660 | (setq work nil)) | |
| 661 | (let ((sort (find-sort-in module sid))) | |
| 662 | (when (or (eq sort *cosmos*) | |
| 663 | (eq sort *universal-sort*) | |
| 664 | (eq sort *huniversal-sort*)) | |
| 665 | (let ((*chaos-quiet* t)) | |
| 666 | (with-output-chaos-error ('invalid-sort-relation) | |
| 667 | (format t "You can not specify the order with built in sort ~A." | |
| 668 | (string (sort-name sort)))))) | |
| 669 | ;; | |
| 670 | (if sort | |
| 671 | (progn | |
| 672 | (when hidden | |
| 673 | (unless (sort-is-hidden sort) | |
| 674 | (with-output-chaos-error ('invalid-subsort-decl) | |
| 675 | (princ "you cannot declare subsort relation between hidden and visible sorts.") | |
| 676 | (print-next) | |
| 677 | (princ "the sort ") (print-sort-name sort) | |
| 678 | (princ " is visible, but must be hidden in this context.") | |
| 679 | ))) | |
| 680 | (push sort work)) | |
| 681 | (with-output-chaos-error ('no-such-sort) | |
| 682 | (princ "constructing sort relation, no such sort with name ") | |
| 683 | (if (term? sid) | |
| 684 | (term-print sid) | |
| 685 | (princ sid)) | |
| 686 | ) | |
| 687 | )))) | |
| 688 | 688 | ;; |
| 689 | 689 | (setq tmp (nreverse (push work tmp))) |
| 690 | 690 | (dotimes (x (length tmp)) |
| 691 | 691 | (declare (type fixnum x)) |
| 692 | 692 | (dolist (s (nth x tmp)) |
| 693 | (let ((lowers (let ((ls nil)) | |
| 694 | (dotimes (y x) | |
| 695 | (declare (type fixnum y)) | |
| 696 | (setq ls (append ls (nth y tmp)))) | |
| 697 | ls)) | |
| 698 | (greaters (do* ((y (1+ x) (1+ y)) | |
| 699 | (res (nth y tmp) | |
| 700 | (append res (nth y tmp)))) | |
| 701 | ((>= y (the fixnum (length tmp))) res) | |
| 702 | (declare (type fixnum y) | |
| 703 | (type list res))))) | |
| 704 | (declare (type list lowers greaters)) | |
| 705 | ;; check hidden condition | |
| 706 | (when hidden | |
| 707 | (when (eq (sort-module s) module) | |
| 708 | (dolist (ts lowers) | |
| 709 | (unless (eq (sort-module ts) module) | |
| 710 | (with-output-chaos-warning () | |
| 711 | (princ "declaring hidden sort ") | |
| 712 | (print-sort-name s) | |
| 713 | (princ " as a supersort of imported hidden sort ") | |
| 714 | (print-sort-name ts)))))) | |
| 715 | ;; | |
| 716 | (push (make-sort-relation s lowers greaters) res)))) | |
| 693 | (let ((lowers (let ((ls nil)) | |
| 694 | (dotimes (y x) | |
| 695 | (declare (type fixnum y)) | |
| 696 | (setq ls (append ls (nth y tmp)))) | |
| 697 | ls)) | |
| 698 | (greaters (do* ((y (1+ x) (1+ y)) | |
| 699 | (res (nth y tmp) | |
| 700 | (append res (nth y tmp)))) | |
| 701 | ((>= y (the fixnum (length tmp))) res) | |
| 702 | (declare (type fixnum y) | |
| 703 | (type list res))))) | |
| 704 | (declare (type list lowers greaters)) | |
| 705 | ;; check hidden condition | |
| 706 | (when hidden | |
| 707 | (when (eq (sort-module s) module) | |
| 708 | (dolist (ts lowers) | |
| 709 | (unless (eq (sort-module ts) module) | |
| 710 | (with-output-chaos-warning () | |
| 711 | (princ "declaring hidden sort ") | |
| 712 | (print-sort-name s) | |
| 713 | (princ " as a supersort of imported hidden sort ") | |
| 714 | (print-sort-name ts)))))) | |
| 715 | ;; | |
| 716 | (push (make-sort-relation s lowers greaters) res)))) | |
| 717 | 717 | res)) |
| 718 | 718 | |
| 719 | 719 | ;;; UPDATE-SORT-ORDER |
| 720 | 720 | ;;; |
| 721 | 721 | (defun update-sort-order (module) |
| 722 | 722 | (let ((closure |
| 723 | (sort-relations-transitive-closure1 (module-sort-relations module))) | |
| 724 | (so (module-sort-order module))) | |
| 723 | (sort-relations-transitive-closure1 (module-sort-relations module))) | |
| 724 | (so (module-sort-order module))) | |
| 725 | 725 | (dolist (sl closure) |
| 726 | 726 | (add-relation-to-order sl so)))) |
| 727 | 727 | |
| 729 | 729 | ;;; |
| 730 | 730 | (defun find-compatible-err-sort (sort module &optional sortmap) |
| 731 | 731 | (when (or (sort= sort *cosmos*) |
| 732 | (sort= sort *universal-sort*) | |
| 733 | (sort= sort *bottom-sort*) | |
| 734 | (sort= sort *huniversal-sort*) | |
| 735 | ) | |
| 732 | (sort= sort *universal-sort*) | |
| 733 | (sort= sort *bottom-sort*) | |
| 734 | (sort= sort *huniversal-sort*) | |
| 735 | ) | |
| 736 | 736 | (return-from find-compatible-err-sort sort)) |
| 737 | 737 | ;; |
| 738 | 738 | (cond ((err-sort-p sort) |
| 739 | (or (cdr (memq sort sortmap)) | |
| 740 | (let* ((compo (car (err-sort-components sort))) | |
| 741 | (xs (if sortmap | |
| 742 | (modmorph-assoc-image sortmap compo) | |
| 743 | compo))) | |
| 744 | ;; | |
| 745 | (or (the-err-sort xs (module-sort-order module)) | |
| 746 | sort)))) | |
| 747 | (t (let ((xs (if sortmap | |
| 748 | (modmorph-assoc-image sortmap sort) | |
| 749 | sort))) | |
| 750 | (the-err-sort xs (module-sort-order module)))))) | |
| 739 | (or (cdr (memq sort sortmap)) | |
| 740 | (let* ((compo (car (err-sort-components sort))) | |
| 741 | (xs (if sortmap | |
| 742 | (modmorph-assoc-image sortmap compo) | |
| 743 | compo))) | |
| 744 | ;; | |
| 745 | (or (the-err-sort xs (module-sort-order module)) | |
| 746 | sort)))) | |
| 747 | (t (let ((xs (if sortmap | |
| 748 | (modmorph-assoc-image sortmap sort) | |
| 749 | sort))) | |
| 750 | (the-err-sort xs (module-sort-order module)))))) | |
| 751 | 751 | |
| 752 | 752 | ;;; |
| 753 | 753 | ;;; SUPPORT FUNCTIONS for SORT MEMBERSHIP PREDICATE. |
| 756 | 756 | (defun method->sort-name (method) |
| 757 | 757 | (let ((name (method-symbol method))) |
| 758 | 758 | (if (cdr name) |
| 759 | (with-output-chaos-error ('invalid-sort-id) | |
| 760 | (format t "operator name ~s is illegal for sort name." name)) | |
| 761 | (car name)))) | |
| 759 | (with-output-chaos-error ('invalid-sort-id) | |
| 760 | (format t "operator name ~s is illegal for sort name." name)) | |
| 761 | (car name)))) | |
| 762 | 762 | |
| 763 | 763 | (defun get-sort-id-value (id-term) |
| 764 | 764 | (if (term-is-builtin-constant? id-term) |
| 770 | 770 | (if (term-is-variable? sort-id-term) |
| 771 | 771 | (list (variable-sort sort-id-term)) |
| 772 | 772 | (let ((sort-name (get-sort-id-value sort-id-term))) |
| 773 | (find-all-sorts-in module sort-name)))) | |
| 773 | (find-all-sorts-in module sort-name)))) | |
| 774 | 774 | |
| 775 | 775 | ;;; |
| 776 | 776 | ;;; the generic sort membership tester |
| 779 | 779 | (defvar .test-term-sort-membership-in-progress. nil) |
| 780 | 780 | |
| 781 | 781 | (defun test-term-sort-membership (term sort-id-const |
| 782 | &optional | |
| 783 | (module (or *current-module* | |
| 784 | *last-module*))) | |
| 782 | &optional (module (get-context-module))) | |
| 783 | ||
| 785 | 784 | (declare (type term term sort-id-const)) |
| 786 | 785 | (unless module |
| 787 | 786 | (with-output-chaos-error ('no-context) |
| 789 | 788 | (with-in-module (module) |
| 790 | 789 | (let ((sorts (gather-sorts-with-id sort-id-const module))) |
| 791 | 790 | (unless sorts |
| 792 | (with-output-chaos-error ('no-sort) | |
| 793 | (format t "sort membership: no such sort ~a in the current context." | |
| 794 | (get-sort-id-value sort-id-const)))) | |
| 791 | (with-output-chaos-error ('no-sort) | |
| 792 | (format t "sort membership: no such sort ~a in the current context." | |
| 793 | (get-sort-id-value sort-id-const)))) | |
| 795 | 794 | |
| 796 | 795 | ;; first we compute the sort with considering sort membership |
| 797 | 796 | ;; predicates in recursive manner. |
| 798 | 797 | (unless .test-term-sort-membership-in-progress. |
| 799 | (let ((.test-term-sort-membership-in-progress. term)) | |
| 800 | (apply-sort-memb term module))) | |
| 798 | (let ((.test-term-sort-membership-in-progress. term)) | |
| 799 | (apply-sort-memb term module))) | |
| 801 | 800 | |
| 802 | 801 | ;; test the result. |
| 803 | 802 | (let ((term-sort (term-sort term))) |
| 804 | (if (some #'(lambda (x) | |
| 805 | (sort<= term-sort x *current-sort-order*)) | |
| 806 | sorts) | |
| 807 | t | |
| 808 | nil)))) | |
| 803 | (if (some #'(lambda (x) | |
| 804 | (sort<= term-sort x *current-sort-order*)) | |
| 805 | sorts) | |
| 806 | t | |
| 807 | nil)))) | |
| 809 | 808 | ) |
| 810 | 809 | |
| 811 | 810 | ;;; SORT-IS-PARAMETERIZED : sort -> Bool |
| 0 | 0 | ;;;-*-Mode:LISP; Package: CHAOS; Base:10; Syntax:Common-lisp -*- |
| 1 | 1 | ;;; |
| 2 | ;;; Copyright (c) 2000-2014, Toshimi Sawada. All rights reserved. | |
| 2 | ;;; Copyright (c) 2000-2015, Toshimi Sawada. All rights reserved. | |
| 3 | 3 | ;;; |
| 4 | 4 | ;;; Redistribution and use in source and binary forms, with or without |
| 5 | 5 | ;;; modification, are permitted provided that the following conditions |
| 27 | 27 | ;;; |
| 28 | 28 | (in-package :chaos) |
| 29 | 29 | #|============================================================================= |
| 30 | System:CHAOS | |
| 31 | Module:construct | |
| 32 | File:trs.lisp | |
| 30 | System:CHAOS | |
| 31 | Module:construct | |
| 32 | File:trs.lisp | |
| 33 | 33 | =============================================================================|# |
| 34 | 34 | |
| 35 | 35 | ;;; DESCRIPTION =============================================================== |
| 39 | 39 | ;;; excepting module names. |
| 40 | 40 | ;;; --------------------------------------------------------------------------- |
| 41 | 41 | |
| 42 | ;; (declaim (special *current-trs*)) ; not used now | |
| 42 | ;; (declaim (special *current-trs*)) ; not used now | |
| 43 | 43 | ;; (defvar *current-trs* nil) |
| 44 | 44 | |
| 45 | 45 | (defun trs-get-mod-or-error (modexp) |
| 46 | 46 | (if (module-p modexp) |
| 47 | 47 | modexp |
| 48 | 48 | (let ((modval nil)) |
| 49 | (cond ((null modexp) | |
| 50 | (setq modval (eval-mod nil))) | |
| 51 | ((stringp modexp) | |
| 52 | (setq modval (eval-mod (list modexp)))) | |
| 53 | (t (with-output-chaos-error ('invalid-modexp) | |
| 54 | (format t "illegal modexp ~a" modexp) | |
| 55 | ))) | |
| 56 | (if modval | |
| 57 | modval | |
| 58 | (with-output-chaos-error ('unknown-mod) | |
| 59 | (format t "could not evaluate modexp ~a" modexp) | |
| 60 | ))))) | |
| 49 | (cond ((null modexp) | |
| 50 | (setq modval (eval-mod nil))) | |
| 51 | ((stringp modexp) | |
| 52 | (setq modval (eval-mod (list modexp)))) | |
| 53 | (t (with-output-chaos-error ('invalid-modexp) | |
| 54 | (format t "illegal modexp ~a" modexp) | |
| 55 | ))) | |
| 56 | (if modval | |
| 57 | modval | |
| 58 | (with-output-chaos-error ('unknown-mod) | |
| 59 | (format t "could not evaluate modexp ~a" modexp) | |
| 60 | ))))) | |
| 61 | 61 | |
| 62 | 62 | (defun get-module-trs-or-error (modexp) |
| 63 | 63 | (get-module-trs (trs-get-mod-or-error modexp))) |
| 69 | 69 | (setq module (trs-get-mod-or-error modexp)) |
| 70 | 70 | (let ((trs (module-trs module))) |
| 71 | 71 | (when (or (need-rewriting-preparation module) |
| 72 | (null (trs$sort-name-map trs))) | |
| 73 | (chaos->trs module)) | |
| 72 | (null (trs$sort-name-map trs))) | |
| 73 | (chaos->trs module)) | |
| 74 | 74 | trs)) |
| 75 | 75 | |
| 76 | 76 | ;;; |
| 89 | 89 | trs)) |
| 90 | 90 | |
| 91 | 91 | (defun print-chaos-trs (trs &optional (stream *standard-output*) |
| 92 | &rest ignore) | |
| 92 | &rest ignore) | |
| 93 | 93 | (declare (ignore ignore)) |
| 94 | 94 | (let ((*print-circle* nil) |
| 95 | (*print-case* :downcase) | |
| 96 | (*print-escape* nil)) | |
| 95 | (*print-case* :downcase) | |
| 96 | (*print-escape* nil)) | |
| 97 | 97 | (prin1 |
| 98 | 98 | (make-trs-print-form trs) |
| 99 | 99 | stream) |
| 126 | 126 | (declare (type string name sup-str)) |
| 127 | 127 | (let ((nam-tok (parse-with-delimiter name #\space))) |
| 128 | 128 | (if (cdr nam-tok) |
| 129 | (reduce #'(lambda (x y) (concatenate 'string | |
| 130 | x | |
| 131 | sup-str | |
| 132 | y)) | |
| 133 | nam-tok) | |
| 134 | (car nam-tok)))) | |
| 129 | (reduce #'(lambda (x y) (concatenate 'string | |
| 130 | x | |
| 131 | sup-str | |
| 132 | y)) | |
| 133 | nam-tok) | |
| 134 | (car nam-tok)))) | |
| 135 | 135 | |
| 136 | 136 | (defun trs-proper-sort-p (sort) |
| 137 | 137 | (not (or (err-sort-p sort) |
| 138 | (memq (sort-module sort) | |
| 139 | *kernel-hard-wired-builtin-modules*)))) | |
| 138 | (memq (sort-module sort) | |
| 139 | *kernel-hard-wired-builtin-modules*)))) | |
| 140 | 140 | |
| 141 | 141 | (defun trs-proper-sort-p* (sort) |
| 142 | 142 | (not (memq (sort-module sort) |
| 143 | *kernel-hard-wired-builtin-modules*))) | |
| 143 | *kernel-hard-wired-builtin-modules*))) | |
| 144 | 144 | |
| 145 | 145 | ;;; |
| 146 | 146 | ;;; |
| 158 | 158 | (defun make-trs-module-name (module) |
| 159 | 159 | (let ((name (module-name module))) |
| 160 | 160 | (if (modexp-is-simple-name name) |
| 161 | (make-module-print-name2 module) | |
| 162 | (or (gethash name _trs_mod_name_hash_) | |
| 163 | (prog1 | |
| 164 | (setq name (make-trs-module-name-internal name)) | |
| 165 | (setf (gethash name _trs_mod_name_hash_) | |
| 166 | name)))))) | |
| 161 | (make-module-print-name2 module) | |
| 162 | (or (gethash name _trs_mod_name_hash_) | |
| 163 | (prog1 | |
| 164 | (setq name (make-trs-module-name-internal name)) | |
| 165 | (setf (gethash name _trs_mod_name_hash_) | |
| 166 | name)))))) | |
| 167 | 167 | |
| 168 | 168 | (defun make-trs-sort-name (sort) |
| 169 | 169 | (intern (concatenate 'string |
| 170 | (string-replace-space-with | |
| 171 | (string (sort-id sort)) | |
| 172 | "$sp$") | |
| 173 | "." | |
| 174 | (make-trs-module-name (sort-module sort))))) | |
| 170 | (string-replace-space-with | |
| 171 | (string (sort-id sort)) | |
| 172 | "$sp$") | |
| 173 | "." | |
| 174 | (make-trs-module-name (sort-module sort))))) | |
| 175 | 175 | |
| 176 | 176 | (defun make-sort-name-map (trs) |
| 177 | 177 | (let ((so (trs$sort-order trs))) |
| 178 | 178 | (dolist (sort (trs$sorts trs)) |
| 179 | 179 | (when (trs-proper-sort-p* sort) |
| 180 | (push (cons sort (make-trs-sort-name sort)) | |
| 181 | (trs$sort-name-map trs)) | |
| 182 | (let ((ds (direct-supersorts sort so))) | |
| 183 | (when (and (null (cdr ds)) (err-sort-p (car ds)) | |
| 184 | (not (assq (car ds) (trs$sort-name-map trs)))) | |
| 185 | (push (cons (car ds) (make-trs-sort-name (car ds))) | |
| 186 | (trs$sort-name-map trs)))) | |
| 187 | )))) | |
| 180 | (push (cons sort (make-trs-sort-name sort)) | |
| 181 | (trs$sort-name-map trs)) | |
| 182 | (let ((ds (direct-supersorts sort so))) | |
| 183 | (when (and (null (cdr ds)) (err-sort-p (car ds)) | |
| 184 | (not (assq (car ds) (trs$sort-name-map trs)))) | |
| 185 | (push (cons (car ds) (make-trs-sort-name (car ds))) | |
| 186 | (trs$sort-name-map trs)))) | |
| 187 | )))) | |
| 188 | 188 | |
| 189 | 189 | (defun map-chaos-sort-to-trs (sort trs) |
| 190 | 190 | (cdr (assq sort (trs$sort-name-map trs)))) |
| 193 | 193 | (unless (sort-struct-p sort) (break "PANIC")) |
| 194 | 194 | (or (map-chaos-sort-to-trs sort trs) |
| 195 | 195 | (cond ((sort= sort *universal-sort*) |
| 196 | (sort-name *universal-sort*)) | |
| 197 | ((sort= sort *huniversal-sort*) | |
| 198 | (sort-name *huniversal-sort*)) | |
| 199 | ((sort= sort *cosmos*) | |
| 200 | (sort-name *cosmos*)) | |
| 201 | (t (if ignore-error | |
| 202 | (sort-name sort) | |
| 203 | (with-output-panic-message () | |
| 204 | (format t | |
| 205 | "could not map sort ~a to trs" (sort-id sort)) | |
| 206 | nil)))))) | |
| 207 | ||
| 196 | (sort-name *universal-sort*)) | |
| 197 | ((sort= sort *huniversal-sort*) | |
| 198 | (sort-name *huniversal-sort*)) | |
| 199 | ((sort= sort *cosmos*) | |
| 200 | (sort-name *cosmos*)) | |
| 201 | (t (if ignore-error | |
| 202 | (sort-name sort) | |
| 203 | (with-output-panic-message () | |
| 204 | (format t | |
| 205 | "could not map sort ~a to trs" (sort-id sort)) | |
| 206 | nil)))))) | |
| 207 | ||
| 208 | 208 | (defun map-trs-sort-to-chaos (name trs) |
| 209 | 209 | (when (stringp name) |
| 210 | 210 | (setq name (intern name))) |
| 215 | 215 | ;;; |
| 216 | 216 | (defun make-trs-sort-graph (trs) |
| 217 | 217 | (let ((so (trs$sort-order trs)) |
| 218 | (snmlist (trs$sort-name-map trs)) | |
| 219 | (sub-rel nil) | |
| 220 | (err-rel nil)) | |
| 218 | (snmlist (trs$sort-name-map trs)) | |
| 219 | (sub-rel nil) | |
| 220 | (err-rel nil)) | |
| 221 | 221 | (dolist (s (trs$sorts trs)) |
| 222 | 222 | (block next |
| 223 | (unless (trs-proper-sort-p s) (return-from next nil)) | |
| 224 | (let ((supers (direct-supersorts s so))) | |
| 225 | (if supers | |
| 226 | (if (and (null (cdr supers)) | |
| 227 | (err-sort-p (car supers))) | |
| 228 | (push (list (cdr (assq s snmlist)) | |
| 229 | (cdr (assq (car supers) snmlist))) | |
| 230 | err-rel) | |
| 231 | ;; | |
| 232 | (dolist (sup supers) | |
| 233 | (push (list (cdr (assq s snmlist)) | |
| 234 | (cdr (assq sup snmlist))) | |
| 235 | sub-rel))))))) | |
| 223 | (unless (trs-proper-sort-p s) (return-from next nil)) | |
| 224 | (let ((supers (direct-supersorts s so))) | |
| 225 | (if supers | |
| 226 | (if (and (null (cdr supers)) | |
| 227 | (err-sort-p (car supers))) | |
| 228 | (push (list (cdr (assq s snmlist)) | |
| 229 | (cdr (assq (car supers) snmlist))) | |
| 230 | err-rel) | |
| 231 | ;; | |
| 232 | (dolist (sup supers) | |
| 233 | (push (list (cdr (assq s snmlist)) | |
| 234 | (cdr (assq sup snmlist))) | |
| 235 | sub-rel))))))) | |
| 236 | 236 | (setf (trs$sort-graph trs) (nreverse sub-rel)) |
| 237 | 237 | (setf (trs$err-sorts trs) (nreverse err-rel)) |
| 238 | 238 | )) |
| 262 | 262 | (defun trs-proper-method-p (meth) |
| 263 | 263 | (and (not (method-is-error-method meth)) |
| 264 | 264 | (not (memq (method-module meth) |
| 265 | *kernel-hard-wired-builtin-modules*)) | |
| 265 | *kernel-hard-wired-builtin-modules*)) | |
| 266 | 266 | (not (or (eq meth *bool-if*) |
| 267 | (eq meth *bool-equal*) | |
| 268 | ;; (eq meth *beh-equal*) | |
| 269 | (eq meth *beh-eq-pred*) | |
| 270 | (eq meth *bool-nonequal*) | |
| 271 | (eq meth *rwl-predicate*))))) | |
| 267 | (eq meth *bool-equal*) | |
| 268 | ;; (eq meth *beh-equal*) | |
| 269 | (eq meth *beh-eq-pred*) | |
| 270 | (eq meth *bool-nonequal*) | |
| 271 | (eq meth *rwl-predicate*))))) | |
| 272 | 272 | |
| 273 | 273 | (defun trs-proper-method-p* (meth) |
| 274 | 274 | (and (not (memq (method-module meth) |
| 275 | *kernel-hard-wired-builtin-modules*)) | |
| 275 | *kernel-hard-wired-builtin-modules*)) | |
| 276 | 276 | (not (or (eq meth *bool-if*) |
| 277 | (eq meth *bool-equal*) | |
| 278 | (eq meth *beh-equal*) | |
| 279 | (eq meth *beh-eq-pred*) | |
| 280 | (eq meth *bool-nonequal*) | |
| 281 | (eq meth *rwl-predicate*))))) | |
| 277 | (eq meth *bool-equal*) | |
| 278 | (eq meth *beh-equal*) | |
| 279 | (eq meth *beh-eq-pred*) | |
| 280 | (eq meth *bool-nonequal*) | |
| 281 | (eq meth *rwl-predicate*))))) | |
| 282 | 282 | |
| 283 | 283 | (defun cmake-operator-print-name (operator) |
| 284 | 284 | (let ((nam (operator-name operator)) |
| 285 | (mixfix (operator-is-mixfix operator))) | |
| 285 | (mixfix (operator-is-mixfix operator))) | |
| 286 | 286 | (if mixfix |
| 287 | (make-print-operator-id (car nam)) | |
| 288 | (format nil "~a/~d" | |
| 289 | (make-print-operator-id (car nam)) | |
| 290 | (cdr nam))))) | |
| 287 | (make-print-operator-id (car nam)) | |
| 288 | (format nil "~a/~d" | |
| 289 | (make-print-operator-id (car nam)) | |
| 290 | (cdr nam))))) | |
| 291 | 291 | |
| 292 | 292 | (defun make-trs-op-name (method opinfo-table) |
| 293 | 293 | (let ((name nil)) |
| 294 | 294 | (if (get-method-info method opinfo-table) |
| 295 | (let ((op (method-operator method opinfo-table))) | |
| 296 | (setq name (operator-print-name op))) | |
| 297 | (let ((meth-name (method-name method))) | |
| 298 | (if (member "_" (car meth-name) :test #'equal) | |
| 299 | ;; mixfix | |
| 300 | (setq name (make-print-operator-id (car meth-name))) | |
| 301 | ;; | |
| 302 | (setq name (format nil "~a/~d" | |
| 303 | (make-print-operator-id (car meth-name)) | |
| 304 | (cdr meth-name)))))) | |
| 295 | (let ((op (method-operator method opinfo-table))) | |
| 296 | (setq name (operator-print-name op))) | |
| 297 | (let ((meth-name (method-name method))) | |
| 298 | (if (member "_" (car meth-name) :test #'equal) | |
| 299 | ;; mixfix | |
| 300 | (setq name (make-print-operator-id (car meth-name))) | |
| 301 | ;; | |
| 302 | (setq name (format nil "~a/~d" | |
| 303 | (make-print-operator-id (car meth-name)) | |
| 304 | (cdr meth-name)))))) | |
| 305 | 305 | ;; |
| 306 | 306 | (or (gethash name *trs-opname-hash*) |
| 307 | (setf (gethash name *trs-opname-hash*) | |
| 308 | (let ((res nil) | |
| 309 | (lim (length name)) | |
| 310 | (cur-tok nil)) | |
| 311 | (do ((pos 0 (1+ pos))) | |
| 312 | ((>= pos lim)) | |
| 313 | (setq cur-tok (char name pos)) | |
| 314 | (push (or (cdr (assoc cur-tok | |
| 315 | trs-operator-special-token-map | |
| 316 | :test #'equal)) | |
| 317 | (string cur-tok)) | |
| 318 | res)) | |
| 319 | (intern (reduce #'(lambda (x y) | |
| 320 | (concatenate 'string x y)) | |
| 321 | (nreverse res)))))))) | |
| 307 | (setf (gethash name *trs-opname-hash*) | |
| 308 | (let ((res nil) | |
| 309 | (lim (length name)) | |
| 310 | (cur-tok nil)) | |
| 311 | (do ((pos 0 (1+ pos))) | |
| 312 | ((>= pos lim)) | |
| 313 | (setq cur-tok (char name pos)) | |
| 314 | (push (or (cdr (assoc cur-tok | |
| 315 | trs-operator-special-token-map | |
| 316 | :test #'equal)) | |
| 317 | (string cur-tok)) | |
| 318 | res)) | |
| 319 | (intern (reduce #'(lambda (x y) | |
| 320 | (concatenate 'string x y)) | |
| 321 | (nreverse res)))))))) | |
| 322 | 322 | |
| 323 | 323 | (defun make-trs-op-info (method trs) |
| 324 | 324 | (let ((module (trs$module trs))) |
| 325 | 325 | (with-in-module (module) |
| 326 | 326 | (let ((method-name (make-trs-op-name method *current-opinfo-table*)) |
| 327 | (arity (mapcar #'(lambda (s) (map-chaos-sort-to-trs-or-panic s | |
| 328 | trs | |
| 329 | t)) | |
| 330 | (method-arity method))) | |
| 331 | (coarity (map-chaos-sort-to-trs-or-panic | |
| 332 | (method-coarity method) | |
| 333 | trs | |
| 334 | t)) | |
| 335 | (attrs (make-trs-method-attr method module))) | |
| 336 | (list* method-name arity coarity attrs))))) | |
| 327 | (arity (mapcar #'(lambda (s) (map-chaos-sort-to-trs-or-panic s | |
| 328 | trs | |
| 329 | t)) | |
| 330 | (method-arity method))) | |
| 331 | (coarity (map-chaos-sort-to-trs-or-panic | |
| 332 | (method-coarity method) | |
| 333 | trs | |
| 334 | t)) | |
| 335 | (attrs (make-trs-method-attr method module))) | |
| 336 | (list* method-name arity coarity attrs))))) | |
| 337 | 337 | |
| 338 | 338 | (defun make-trs-op-maps (trs) |
| 339 | 339 | (let ((module (trs$module trs))) |
| 340 | 340 | (let ((res nil)) |
| 341 | 341 | (dolist (ops (module-all-operators module)) |
| 342 | (let ((methods (opinfo-methods ops))) | |
| 343 | (dolist (m methods) | |
| 344 | (let ((info (make-trs-op-info m trs))) | |
| 345 | (if (method-is-error-method m) | |
| 346 | (let ((rev-ent (assq (car info) | |
| 347 | (trs$op-rev-table trs)))) | |
| 348 | (if rev-ent | |
| 349 | (setf (cdr rev-ent) m) | |
| 350 | (push (cons (car info) m) | |
| 351 | (trs$op-rev-table trs)))) | |
| 352 | (when (trs-proper-method-p* m) | |
| 353 | (push (cons m info) res))))))) | |
| 342 | (let ((methods (opinfo-methods ops))) | |
| 343 | (dolist (m methods) | |
| 344 | (let ((info (make-trs-op-info m trs))) | |
| 345 | (if (method-is-error-method m) | |
| 346 | (let ((rev-ent (assq (car info) | |
| 347 | (trs$op-rev-table trs)))) | |
| 348 | (if rev-ent | |
| 349 | (setf (cdr rev-ent) m) | |
| 350 | (push (cons (car info) m) | |
| 351 | (trs$op-rev-table trs)))) | |
| 352 | (when (trs-proper-method-p* m) | |
| 353 | (push (cons m info) res))))))) | |
| 354 | 354 | ;; make reverse op maps for builtin operators |
| 355 | 355 | (when (assq *truth-module* (module-all-submodules module)) |
| 356 | (dolist (op (list *bool-equal* *bool-nonequal* | |
| 357 | *beh-equal* *bool-if* *beh-eq-pred*)) | |
| 358 | (push (cons (make-trs-op-name op (module-opinfo-table module)) | |
| 359 | op) | |
| 360 | (trs$op-rev-table trs)))) | |
| 356 | (dolist (op (list *bool-equal* *bool-nonequal* | |
| 357 | *beh-equal* *bool-if* *beh-eq-pred*)) | |
| 358 | (push (cons (make-trs-op-name op (module-opinfo-table module)) | |
| 359 | op) | |
| 360 | (trs$op-rev-table trs)))) | |
| 361 | 361 | ;; |
| 362 | 362 | (when (module-includes-rwl module) |
| 363 | (push (cons (make-trs-op-name *rwl-predicate* (module-opinfo-table module)) | |
| 364 | *rwl-predicate*) | |
| 365 | (trs$op-rev-table trs))) | |
| 363 | (push (cons (make-trs-op-name *rwl-predicate* (module-opinfo-table module)) | |
| 364 | *rwl-predicate*) | |
| 365 | (trs$op-rev-table trs))) | |
| 366 | 366 | ;; |
| 367 | 367 | (setf (trs$op-info-map trs) |
| 368 | (nreverse res))))) | |
| 368 | (nreverse res))))) | |
| 369 | 369 | |
| 370 | 370 | (defun make-trs-method-attr (meth module) |
| 371 | 371 | (with-in-module (module) |
| 372 | 372 | (let ((theory (method-theory meth)) |
| 373 | (strat (method-rewrite-strategy meth)) | |
| 374 | (constr (method-constructor meth)) | |
| 375 | ;; (prec (method-precedence meth)) | |
| 376 | (assoc (method-associativity meth)) | |
| 377 | (res nil)) | |
| 373 | (strat (method-rewrite-strategy meth)) | |
| 374 | (constr (method-constructor meth)) | |
| 375 | ;; (prec (method-precedence meth)) | |
| 376 | (assoc (method-associativity meth)) | |
| 377 | (res nil)) | |
| 378 | 378 | ;; |
| 379 | 379 | ;; (when (and (eql 0 (car (last strat))) |
| 380 | 380 | ;; (member 0 (butlast strat))) |
| 381 | 381 | ;; (setq strat (butlast strat))) |
| 382 | 382 | ;; |
| 383 | 383 | (let ((th-info (theory-info theory)) |
| 384 | (zero (theory-zero theory))) | |
| 385 | (when (not (eq th-info the-e-property)) | |
| 386 | (when (or (theory-info-is-AC th-info) | |
| 387 | (theory-info-is-A th-info) | |
| 388 | (theory-info-is-AI th-info) | |
| 389 | (theory-info-is-AZ th-info) | |
| 390 | (theory-info-is-AIZ th-info) | |
| 391 | (theory-info-is-ACI th-info) | |
| 392 | (theory-info-is-ACZ th-info) | |
| 393 | (theory-info-is-ACIZ th-info)) | |
| 394 | (push ':assoc res)) | |
| 395 | (when (or (theory-info-is-AC th-info) | |
| 396 | (theory-info-is-C th-info) | |
| 397 | (theory-info-is-CI th-info) | |
| 398 | (theory-info-is-CZ th-info) | |
| 399 | (theory-info-is-CIZ th-info) | |
| 400 | (theory-info-is-ACI th-info) | |
| 401 | (theory-info-is-ACZ th-info) | |
| 402 | (theory-info-is-ACIZ th-info)) | |
| 403 | (push ':comm res)) | |
| 404 | (when (or (theory-info-is-I th-info) | |
| 405 | (theory-info-is-IZ th-info) | |
| 406 | (theory-info-is-CI th-info) | |
| 407 | (theory-info-is-CIZ th-info) | |
| 408 | (theory-info-is-AI th-info) | |
| 409 | (theory-info-is-AIZ th-info) | |
| 410 | (theory-info-is-ACI th-info) | |
| 411 | (theory-info-is-ACIZ th-info)) | |
| 412 | (push ':idem res)) | |
| 413 | (when zero | |
| 414 | (let ((mth (car zero))) ; to be fixed later. | |
| 415 | (if (null (cdr zero)) | |
| 416 | (push (list ':id mth) res) | |
| 417 | (push (list ':idr mth) res)))) | |
| 418 | )) | |
| 384 | (zero (theory-zero theory))) | |
| 385 | (when (not (eq th-info the-e-property)) | |
| 386 | (when (or (theory-info-is-AC th-info) | |
| 387 | (theory-info-is-A th-info) | |
| 388 | (theory-info-is-AI th-info) | |
| 389 | (theory-info-is-AZ th-info) | |
| 390 | (theory-info-is-AIZ th-info) | |
| 391 | (theory-info-is-ACI th-info) | |
| 392 | (theory-info-is-ACZ th-info) | |
| 393 | (theory-info-is-ACIZ th-info)) | |
| 394 | (push ':assoc res)) | |
| 395 | (when (or (theory-info-is-AC th-info) | |
| 396 | (theory-info-is-C th-info) | |
| 397 | (theory-info-is-CI th-info) | |
| 398 | (theory-info-is-CZ th-info) | |
| 399 | (theory-info-is-CIZ th-info) | |
| 400 | (theory-info-is-ACI th-info) | |
| 401 | (theory-info-is-ACZ th-info) | |
| 402 | (theory-info-is-ACIZ th-info)) | |
| 403 | (push ':comm res)) | |
| 404 | (when (or (theory-info-is-I th-info) | |
| 405 | (theory-info-is-IZ th-info) | |
| 406 | (theory-info-is-CI th-info) | |
| 407 | (theory-info-is-CIZ th-info) | |
| 408 | (theory-info-is-AI th-info) | |
| 409 | (theory-info-is-AIZ th-info) | |
| 410 | (theory-info-is-ACI th-info) | |
| 411 | (theory-info-is-ACIZ th-info)) | |
| 412 | (push ':idem res)) | |
| 413 | (when zero | |
| 414 | (let ((mth (car zero))) ; to be fixed later. | |
| 415 | (if (null (cdr zero)) | |
| 416 | (push (list ':id mth) res) | |
| 417 | (push (list ':idr mth) res)))) | |
| 418 | )) | |
| 419 | 419 | (when strat |
| 420 | (push (list ':strat strat) res)) | |
| 420 | (push (list ':strat strat) res)) | |
| 421 | 421 | (when constr |
| 422 | (push ':constr res)) | |
| 422 | (push ':constr res)) | |
| 423 | 423 | (when assoc |
| 424 | (push (if (eq :left assoc) | |
| 425 | ':l-assoc | |
| 426 | ':r-assoc) | |
| 427 | res)) | |
| 424 | (push (if (eq :left assoc) | |
| 425 | ':l-assoc | |
| 426 | ':r-assoc) | |
| 427 | res)) | |
| 428 | 428 | res))) |
| 429 | 429 | |
| 430 | 430 | (defun fix-trs-ids (trs) |
| 431 | 431 | (dolist (map (trs$op-info-map trs)) |
| 432 | 432 | (let* ((info (cdr map)) |
| 433 | (zero (find-if #'(lambda (x) (and (consp x) | |
| 434 | (or (eq (car x) :id) | |
| 435 | (eq (car x) :idr)))) | |
| 436 | info))) | |
| 433 | (zero (find-if #'(lambda (x) (and (consp x) | |
| 434 | (or (eq (car x) :id) | |
| 435 | (eq (car x) :idr)))) | |
| 436 | info))) | |
| 437 | 437 | (when zero |
| 438 | (setf (cdr zero) (list (trs$make-term-form (cadr zero) trs))))))) | |
| 438 | (setf (cdr zero) (list (trs$make-term-form (cadr zero) trs))))))) | |
| 439 | 439 | |
| 440 | 440 | (defun map-chaos-op-to-trs (method trs) |
| 441 | 441 | (or (cadr (assq method (trs$op-info-map trs))) |
| 442 | 442 | (with-in-module ((trs$module trs)) |
| 443 | (make-trs-op-name method *current-opinfo-table*)) | |
| 443 | (make-trs-op-name method *current-opinfo-table*)) | |
| 444 | 444 | (with-output-panic-message () |
| 445 | (format t "cound not map operator ~a" | |
| 446 | (method-symbol method)) | |
| 447 | (chaos-error 'panic)))) | |
| 445 | (format t "cound not map operator ~a" | |
| 446 | (method-symbol method)) | |
| 447 | (chaos-error 'panic)))) | |
| 448 | 448 | |
| 449 | 449 | (defun map-chaos-op-to-trs-info (method trs) |
| 450 | 450 | (cdr (assq method (trs$op-info-map trs)))) |
| 454 | 454 | (setq name (intern name))) |
| 455 | 455 | (or (cdr (assoc name (trs$op-rev-table trs))) |
| 456 | 456 | (let* ((opnam (list (string name))) |
| 457 | (opref (parse-op-name opnam)) | |
| 458 | (opinfos (car (find-qual-operators opref (trs$module trs))))) | |
| 459 | (car (opinfo-methods opinfos))) | |
| 457 | (opref (parse-op-name opnam)) | |
| 458 | (opinfos (car (find-qual-operators opref (trs$module trs))))) | |
| 459 | (car (opinfo-methods opinfos))) | |
| 460 | 460 | (with-output-panic-message () |
| 461 | (format t "could not find reverse map of operator symbol ~a" | |
| 462 | name) | |
| 463 | (chaos-error 'panic)))) | |
| 461 | (format t "could not find reverse map of operator symbol ~a" | |
| 462 | name) | |
| 463 | (chaos-error 'panic)))) | |
| 464 | 464 | |
| 465 | 465 | ;;; |
| 466 | 466 | ;;; BUILTIN OPERATORS |
| 467 | 467 | ;;; |
| 468 | 468 | (defun find-trs-dummy-method (trs meth arity coarity) |
| 469 | 469 | (cdr (assoc (list meth arity coarity) |
| 470 | (trs$dummy-methods trs) | |
| 471 | :test #'equal))) | |
| 470 | (trs$dummy-methods trs) | |
| 471 | :test #'equal))) | |
| 472 | 472 | |
| 473 | 473 | (defun make-trs-dummy-method (trs meth arity coarity) |
| 474 | 474 | (or (find-trs-dummy-method trs meth arity coarity) |
| 475 | 475 | (with-in-module ((trs$module trs)) |
| 476 | (let* ((op (method-operator meth)) | |
| 477 | (new-meth (make-operator-method :name (operator-name op) | |
| 478 | :arity arity | |
| 479 | :coarity coarity))) | |
| 480 | (setf (method-constructor new-meth) | |
| 481 | (method-constructor meth)) | |
| 482 | (setf (method-is-behavioural new-meth) | |
| 483 | (method-is-behavioural meth)) | |
| 484 | (setf (method-module new-meth) | |
| 485 | *current-module*) | |
| 486 | (setf (method-supplied-strategy new-meth) | |
| 487 | (method-supplied-strategy meth)) | |
| 488 | (setf (method-precedence new-meth) | |
| 489 | (method-precedence meth)) | |
| 490 | (setf (method-associativity new-meth) | |
| 491 | (method-associativity meth)) | |
| 492 | (push (cons (list meth arity coarity) new-meth) | |
| 493 | (trs$dummy-methods trs)) | |
| 494 | ;; | |
| 495 | new-meth)))) | |
| 476 | (let* ((op (method-operator meth)) | |
| 477 | (new-meth (make-operator-method :name (operator-name op) | |
| 478 | :arity arity | |
| 479 | :coarity coarity))) | |
| 480 | (setf (method-constructor new-meth) | |
| 481 | (method-constructor meth)) | |
| 482 | (setf (method-is-behavioural new-meth) | |
| 483 | (method-is-behavioural meth)) | |
| 484 | (setf (method-module new-meth) | |
| 485 | *current-module*) | |
| 486 | (setf (method-supplied-strategy new-meth) | |
| 487 | (method-supplied-strategy meth)) | |
| 488 | (setf (method-precedence new-meth) | |
| 489 | (method-precedence meth)) | |
| 490 | (setf (method-associativity new-meth) | |
| 491 | (method-associativity meth)) | |
| 492 | (push (cons (list meth arity coarity) new-meth) | |
| 493 | (trs$dummy-methods trs)) | |
| 494 | ;; | |
| 495 | new-meth)))) | |
| 496 | 496 | |
| 497 | 497 | (defun make-trs-builtin-bin-op-info (trs meth arity coarity) |
| 498 | 498 | (let ((new-meth |
| 499 | (make-trs-dummy-method trs meth arity coarity))) | |
| 499 | (make-trs-dummy-method trs meth arity coarity))) | |
| 500 | 500 | ;; |
| 501 | 501 | (let ((info (make-trs-op-info meth trs)) |
| 502 | (r-arity (mapcar #'(lambda (x) | |
| 503 | (map-chaos-sort-to-trs-or-panic x trs)) | |
| 504 | arity)) | |
| 505 | (r-coarity (map-chaos-sort-to-trs-or-panic coarity trs))) | |
| 502 | (r-arity (mapcar #'(lambda (x) | |
| 503 | (map-chaos-sort-to-trs-or-panic x trs)) | |
| 504 | arity)) | |
| 505 | (r-coarity (map-chaos-sort-to-trs-or-panic coarity trs))) | |
| 506 | 506 | (setf (second info) r-arity |
| 507 | (third info) r-coarity) | |
| 507 | (third info) r-coarity) | |
| 508 | 508 | (cons new-meth info)))) |
| 509 | 509 | |
| 510 | 510 | (defun make-trs-if-then-else-info (trs sort) |
| 511 | 511 | (let ((new-meth (make-trs-dummy-method trs |
| 512 | *bool-if* | |
| 513 | (list *bool-sort* sort sort) | |
| 514 | sort)) | |
| 515 | (info (make-trs-op-info *bool-if* trs)) | |
| 516 | (bool (map-chaos-sort-to-trs-or-panic *bool-sort* trs)) | |
| 517 | (s (map-chaos-sort-to-trs-or-panic sort trs)) | |
| 518 | ) | |
| 512 | *bool-if* | |
| 513 | (list *bool-sort* sort sort) | |
| 514 | sort)) | |
| 515 | (info (make-trs-op-info *bool-if* trs)) | |
| 516 | (bool (map-chaos-sort-to-trs-or-panic *bool-sort* trs)) | |
| 517 | (s (map-chaos-sort-to-trs-or-panic sort trs)) | |
| 518 | ) | |
| 519 | 519 | (setf (second info) (list bool s s)) |
| 520 | 520 | (setf (third info) s) |
| 521 | 521 | (cons new-meth info))) |
| 522 | 522 | |
| 523 | 523 | (defun make-trs-if-then-else-axioms (trs sort) |
| 524 | 524 | (let* ((var-then (make-variable-term sort 'THEN)) |
| 525 | (var-else (make-variable-term sort 'ELSE)) | |
| 526 | (if-op (find-trs-dummy-method trs *bool-if* | |
| 527 | (list *bool-sort* sort sort) | |
| 528 | sort)) | |
| 529 | (lhs-1 (make-applform sort | |
| 530 | if-op | |
| 531 | (list *bool-true* var-then var-else))) | |
| 532 | (lhs-2 (make-applform sort | |
| 533 | if-op | |
| 534 | (list *bool-false* var-then var-else))) | |
| 535 | (rhs-1 var-then) | |
| 536 | (rhs-2 var-else)) | |
| 525 | (var-else (make-variable-term sort 'ELSE)) | |
| 526 | (if-op (find-trs-dummy-method trs *bool-if* | |
| 527 | (list *bool-sort* sort sort) | |
| 528 | sort)) | |
| 529 | (lhs-1 (make-applform sort | |
| 530 | if-op | |
| 531 | (list *bool-true* var-then var-else))) | |
| 532 | (lhs-2 (make-applform sort | |
| 533 | if-op | |
| 534 | (list *bool-false* var-then var-else))) | |
| 535 | (rhs-1 var-then) | |
| 536 | (rhs-2 var-else)) | |
| 537 | 537 | (list (make-rule :lhs lhs-1 :rhs rhs-1 :condition *bool-true* |
| 538 | :type :equation | |
| 539 | :no-method-computation t) | |
| 540 | (make-rule :lhs lhs-2 :rhs rhs-2 :condition *bool-true* | |
| 541 | :type :equation | |
| 542 | :no-method-computation t)) | |
| 538 | :type :equation | |
| 539 | :no-method-computation t) | |
| 540 | (make-rule :lhs lhs-2 :rhs rhs-2 :condition *bool-true* | |
| 541 | :type :equation | |
| 542 | :no-method-computation t)) | |
| 543 | 543 | )) |
| 544 | 544 | |
| 545 | 545 | (defun get-trs-top-sorts (trs) |
| 546 | 546 | (let ((top-sorts nil)) |
| 547 | 547 | (dolist (sort (maximal-sorts (trs$sorts trs) |
| 548 | (trs$sort-order trs))) | |
| 548 | (trs$sort-order trs))) | |
| 549 | 549 | (when (trs-proper-sort-p sort) |
| 550 | (push sort top-sorts))) | |
| 550 | (push sort top-sorts))) | |
| 551 | 551 | top-sorts)) |
| 552 | 552 | |
| 553 | 553 | (defun get-trs-error-sorts (trs) |
| 554 | 554 | (let ((error-sorts nil)) |
| 555 | 555 | (dolist (ent (trs$sort-name-map trs) error-sorts) |
| 556 | (when (err-sort-p (car ent)) | |
| 557 | (push (car ent) error-sorts))))) | |
| 556 | (when (err-sort-p (car ent)) | |
| 557 | (push (car ent) error-sorts))))) | |
| 558 | 558 | |
| 559 | 559 | (defun make-trs-biopinfos (trs sorts) |
| 560 | 560 | (let ((infos nil) |
| 561 | (axs nil)) | |
| 561 | (axs nil)) | |
| 562 | 562 | (dolist (sort sorts) |
| 563 | 563 | (if (sort-is-hidden sort) |
| 564 | (push (make-trs-builtin-bin-op-info trs *beh-equal* | |
| 565 | (list sort sort) | |
| 566 | *bool-sort*) | |
| 567 | infos) | |
| 568 | (progn | |
| 569 | ;; _==_ | |
| 570 | (push (make-trs-builtin-bin-op-info trs *bool-equal* | |
| 571 | (list sort sort) | |
| 572 | *bool-sort*) | |
| 573 | infos) | |
| 574 | ;; _=b=_ | |
| 575 | (when (sort-is-hidden sort) | |
| 576 | (push (make-trs-builtin-bin-op-info trs *beh-eq-pred* | |
| 577 | (list sort sort) | |
| 578 | *bool-sort*) | |
| 579 | infos)) | |
| 580 | ;; _=*=_ | |
| 581 | (when (sort-is-hidden sort) | |
| 582 | (push (make-trs-builtin-bin-op-info trs *beh-equal* | |
| 583 | (list sort sort) | |
| 584 | *bool-sort*) | |
| 585 | infos)) | |
| 586 | ;; _=/=_ | |
| 587 | (push (make-trs-builtin-bin-op-info trs *bool-nonequal* | |
| 588 | (list sort sort) | |
| 589 | *bool-sort*) | |
| 590 | infos))) | |
| 564 | (push (make-trs-builtin-bin-op-info trs *beh-equal* | |
| 565 | (list sort sort) | |
| 566 | *bool-sort*) | |
| 567 | infos) | |
| 568 | (progn | |
| 569 | ;; _==_ | |
| 570 | (push (make-trs-builtin-bin-op-info trs *bool-equal* | |
| 571 | (list sort sort) | |
| 572 | *bool-sort*) | |
| 573 | infos) | |
| 574 | ;; _=b=_ | |
| 575 | (when (sort-is-hidden sort) | |
| 576 | (push (make-trs-builtin-bin-op-info trs *beh-eq-pred* | |
| 577 | (list sort sort) | |
| 578 | *bool-sort*) | |
| 579 | infos)) | |
| 580 | ;; _=*=_ | |
| 581 | (when (sort-is-hidden sort) | |
| 582 | (push (make-trs-builtin-bin-op-info trs *beh-equal* | |
| 583 | (list sort sort) | |
| 584 | *bool-sort*) | |
| 585 | infos)) | |
| 586 | ;; _=/=_ | |
| 587 | (push (make-trs-builtin-bin-op-info trs *bool-nonequal* | |
| 588 | (list sort sort) | |
| 589 | *bool-sort*) | |
| 590 | infos))) | |
| 591 | 591 | ;; if_then_else_fi |
| 592 | 592 | (push (make-trs-if-then-else-info trs sort) |
| 593 | infos) | |
| 593 | infos) | |
| 594 | 594 | (push (make-trs-if-then-else-axioms trs sort) |
| 595 | axs) | |
| 595 | axs) | |
| 596 | 596 | ) |
| 597 | 597 | ;; |
| 598 | 598 | (values infos axs) |
| 600 | 600 | |
| 601 | 601 | (defun make-trs-builtin-op-maps (trs) |
| 602 | 602 | (let* ((mod (trs$module trs)) |
| 603 | (top-sorts nil) | |
| 604 | (rel-infos nil) | |
| 605 | (if-then-axs nil) | |
| 606 | ) | |
| 603 | (top-sorts nil) | |
| 604 | (rel-infos nil) | |
| 605 | (if-then-axs nil) | |
| 606 | ) | |
| 607 | 607 | ;; |
| 608 | 608 | (setq top-sorts (get-trs-top-sorts trs)) |
| 609 | 609 | ;; |
| 610 | 610 | (when (assq *truth-module* (module-all-submodules mod)) |
| 611 | 611 | (multiple-value-bind (infos axs) |
| 612 | (make-trs-biopinfos trs top-sorts) | |
| 613 | (setq rel-infos infos) | |
| 614 | (setq if-then-axs axs)) | |
| 612 | (make-trs-biopinfos trs top-sorts) | |
| 613 | (setq rel-infos infos) | |
| 614 | (setq if-then-axs axs)) | |
| 615 | 615 | ) |
| 616 | 616 | (when (assq *rwl-module* (module-all-submodules mod)) |
| 617 | 617 | ;; _==>_ |
| 618 | 618 | (dolist (sort top-sorts) |
| 619 | (unless (sort-is-hidden sort) | |
| 620 | (push (cons *rwl-predicate* | |
| 621 | (make-trs-builtin-bin-op-info trs | |
| 622 | *rwl-predicate* | |
| 623 | (list sort sort) | |
| 624 | *bool-sort*)) | |
| 625 | rel-infos))) | |
| 619 | (unless (sort-is-hidden sort) | |
| 620 | (push (cons *rwl-predicate* | |
| 621 | (make-trs-builtin-bin-op-info trs | |
| 622 | *rwl-predicate* | |
| 623 | (list sort sort) | |
| 624 | *bool-sort*)) | |
| 625 | rel-infos))) | |
| 626 | 626 | ) |
| 627 | 627 | ;; |
| 628 | 628 | (setf (trs$sem-relations trs) rel-infos) |
| 629 | 629 | (dolist (ax if-then-axs) |
| 630 | 630 | (let ((ax1 (car ax)) |
| 631 | (ax2 (cadr ax))) | |
| 632 | (push ax1 (trs$sem-axioms trs)) | |
| 633 | (push ax2 (trs$sem-axioms trs)))) | |
| 631 | (ax2 (cadr ax))) | |
| 632 | (push ax1 (trs$sem-axioms trs)) | |
| 633 | (push ax2 (trs$sem-axioms trs)))) | |
| 634 | 634 | )) |
| 635 | 635 | |
| 636 | 636 | ;;; ------ |
| 650 | 650 | |
| 651 | 651 | (defun trs-set-if-then-sort (res) |
| 652 | 652 | (if (and (eq :op (trs-term-type res)) |
| 653 | (null (trs-term-sort res)) | |
| 654 | (eq '|if_then_else_fi| (trs-term-head res))) | |
| 653 | (null (trs-term-sort res)) | |
| 654 | (eq '|if_then_else_fi| (trs-term-head res))) | |
| 655 | 655 | (let ((sort (trs-get-if-then-sort res))) |
| 656 | (setf (trs-term-sort res) sort) | |
| 657 | sort) | |
| 656 | (setf (trs-term-sort res) sort) | |
| 657 | sort) | |
| 658 | 658 | (trs-term-sort res))) |
| 659 | 659 | |
| 660 | 660 | (defun trs-get-if-then-sort (trs-term) |
| 661 | 661 | (let ((arg2 (second (trs-term-subterms trs-term))) |
| 662 | (sort nil)) | |
| 662 | (sort nil)) | |
| 663 | 663 | (setq sort (trs-term-sort arg2)) |
| 664 | 664 | (unless sort |
| 665 | 665 | (with-output-panic-message () |
| 666 | (format t "could not set sort for if-then-else-fi!") | |
| 667 | (break) | |
| 668 | (chaos-error 'panic))) | |
| 666 | (format t "could not set sort for if-then-else-fi!") | |
| 667 | (break) | |
| 668 | (chaos-error 'panic))) | |
| 669 | 669 | sort)) |
| 670 | 670 | |
| 671 | 671 | (defun trs$make-term-form* (term trs) |
| 672 | (cond ((term-is-simple-lisp-form? term) | |
| 673 | (list ':lisp (lisp-form-original-form term))) | |
| 674 | ((term-is-general-lisp-form? term) | |
| 675 | (list ':glisp (lisp-form-original-form term))) | |
| 676 | ((term-is-builtin-constant? term) | |
| 677 | (list :builtin-value | |
| 678 | (term-builtin-value term) | |
| 679 | (map-chaos-sort-to-trs (term-sort term) trs))) | |
| 680 | ((term-is-variable? term) | |
| 681 | (list :var (variable-name term) | |
| 682 | (map-chaos-sort-to-trs (variable-sort term) trs))) | |
| 683 | ((term-is-applform? term) | |
| 684 | (list* :op | |
| 685 | (map-chaos-op-to-trs (term-head term) trs) | |
| 686 | (map-chaos-sort-to-trs (term-sort term) trs) | |
| 687 | (mapcar #'(lambda (x) | |
| 688 | (trs$make-term-form x trs)) | |
| 689 | (term-subterms term)))) | |
| 690 | (t (with-output-panic-message () | |
| 691 | (format t "unknown term : ") | |
| 692 | (term-print term))))) | |
| 672 | (cond ((term-is-simple-lisp-form? term) | |
| 673 | (list ':lisp (lisp-form-original-form term))) | |
| 674 | ((term-is-general-lisp-form? term) | |
| 675 | (list ':glisp (lisp-form-original-form term))) | |
| 676 | ((term-is-builtin-constant? term) | |
| 677 | (list :builtin-value | |
| 678 | (term-builtin-value term) | |
| 679 | (map-chaos-sort-to-trs (term-sort term) trs))) | |
| 680 | ((term-is-variable? term) | |
| 681 | (list :var (variable-name term) | |
| 682 | (map-chaos-sort-to-trs (variable-sort term) trs))) | |
| 683 | ((term-is-applform? term) | |
| 684 | (list* :op | |
| 685 | (map-chaos-op-to-trs (term-head term) trs) | |
| 686 | (map-chaos-sort-to-trs (term-sort term) trs) | |
| 687 | (mapcar #'(lambda (x) | |
| 688 | (trs$make-term-form x trs)) | |
| 689 | (term-subterms term)))) | |
| 690 | (t (with-output-panic-message () | |
| 691 | (format t "unknown term : ") | |
| 692 | (term-print term))))) | |
| 693 | 693 | |
| 694 | 694 | (defun trs-term-variables (term) |
| 695 | 695 | (case (trs-term-type term) |
| 696 | 696 | (:var (list term)) |
| 697 | 697 | (:op (let ((res nil)) |
| 698 | (dolist (st (trs-term-subterms term) res) | |
| 699 | (setq res (union res (trs-term-variables st) | |
| 700 | :test #'equal))))) | |
| 698 | (dolist (st (trs-term-subterms term) res) | |
| 699 | (setq res (union res (trs-term-variables st) | |
| 700 | :test #'equal))))) | |
| 701 | 701 | (otherwise nil))) |
| 702 | 702 | |
| 703 | 703 | (defun trs-re-make-term-form (trs trs-term) |
| 704 | 704 | (with-in-module ((trs$module trs)) |
| 705 | 705 | (with-output-to-string (str) |
| 706 | 706 | (let ((*standard-output* str)) |
| 707 | (re-print-trs-term trs trs-term parser-max-precedence) | |
| 708 | str)))) | |
| 707 | (re-print-trs-term trs trs-term parser-max-precedence) | |
| 708 | str)))) | |
| 709 | 709 | |
| 710 | 710 | (defun re-print-trs-term (trs trs-term prec) |
| 711 | 711 | (case (trs-term-type trs-term) |
| 712 | 712 | (:var (princ (string (trs-term-head trs-term)))) |
| 713 | 713 | (:op (let ((op-name (trs-term-head trs-term))) |
| 714 | (let ((hd (trs-rev-op-name op-name trs)) | |
| 715 | (op nil)) | |
| 716 | (setq op (method-operator hd)) | |
| 717 | (cond ((not (operator-is-mixfix op)) | |
| 718 | (let ((subs (trs-term-subterms trs-term))) | |
| 719 | (format t "~{~a~^ ~}" (operator-symbol op)) | |
| 720 | (when subs | |
| 721 | (princ "(") | |
| 722 | (let ((flg nil)) | |
| 723 | (dolist (i subs) | |
| 724 | (if flg (princ ",") (setq flg t)) | |
| 725 | (re-print-trs-term trs i parser-max-precedence) | |
| 726 | )) | |
| 727 | (princ ")")))) | |
| 728 | (t (let ((prec-test (and (get-method-precedence hd) | |
| 729 | (<= prec | |
| 730 | (get-method-precedence hd)))) | |
| 731 | (assoc-test (method-is-associative hd))) | |
| 732 | (when prec-test (princ "(")) | |
| 733 | (let ((subs (trs-term-subterms trs-term)) | |
| 734 | (prv nil)) | |
| 735 | (dolist (i (operator-token-sequence op)) | |
| 736 | (cond | |
| 737 | ((eq i t) | |
| 738 | (when prv (princ " ")) | |
| 739 | (setq prv t) | |
| 740 | (let ((tm (car subs))) | |
| 741 | (re-print-trs-term | |
| 742 | trs | |
| 743 | tm | |
| 744 | (if (and assoc-test | |
| 745 | tm | |
| 746 | (eq :op (trs-term-type tm)) | |
| 747 | (eq (trs-term-head tm) | |
| 748 | (trs-term-head trs-term))) | |
| 749 | parser-max-precedence | |
| 750 | (or (get-method-precedence hd) | |
| 751 | 0))) | |
| 752 | (setq subs (cdr subs)))) | |
| 753 | (t (when prv (princ " ")) | |
| 754 | (setq prv t) | |
| 755 | (princ i))))) | |
| 756 | (when prec-test (princ ")")) | |
| 757 | )))))) | |
| 714 | (let ((hd (trs-rev-op-name op-name trs)) | |
| 715 | (op nil)) | |
| 716 | (setq op (method-operator hd)) | |
| 717 | (cond ((not (operator-is-mixfix op)) | |
| 718 | (let ((subs (trs-term-subterms trs-term))) | |
| 719 | (format t "~{~a~^ ~}" (operator-symbol op)) | |
| 720 | (when subs | |
| 721 | (princ "(") | |
| 722 | (let ((flg nil)) | |
| 723 | (dolist (i subs) | |
| 724 | (if flg (princ ",") (setq flg t)) | |
| 725 | (re-print-trs-term trs i parser-max-precedence) | |
| 726 | )) | |
| 727 | (princ ")")))) | |
| 728 | (t (let ((prec-test (and (get-method-precedence hd) | |
| 729 | (<= prec | |
| 730 | (get-method-precedence hd)))) | |
| 731 | (assoc-test (method-is-associative hd))) | |
| 732 | (when prec-test (princ "(")) | |
| 733 | (let ((subs (trs-term-subterms trs-term)) | |
| 734 | (prv nil)) | |
| 735 | (dolist (i (operator-token-sequence op)) | |
| 736 | (cond | |
| 737 | ((eq i t) | |
| 738 | (when prv (princ " ")) | |
| 739 | (setq prv t) | |
| 740 | (let ((tm (car subs))) | |
| 741 | (re-print-trs-term | |
| 742 | trs | |
| 743 | tm | |
| 744 | (if (and assoc-test | |
| 745 | tm | |
| 746 | (eq :op (trs-term-type tm)) | |
| 747 | (eq (trs-term-head tm) | |
| 748 | (trs-term-head trs-term))) | |
| 749 | parser-max-precedence | |
| 750 | (or (get-method-precedence hd) | |
| 751 | 0))) | |
| 752 | (setq subs (cdr subs)))) | |
| 753 | (t (when prv (princ " ")) | |
| 754 | (setq prv t) | |
| 755 | (princ i))))) | |
| 756 | (when prec-test (princ ")")) | |
| 757 | )))))) | |
| 758 | 758 | (:builtin-value (princ (trs-term-head trs-term))) |
| 759 | 759 | (otherwise (format t "!! not supported (~a)" trs-term))) |
| 760 | 760 | ) |
| 767 | 767 | (defun make-trs-axioms (trs) |
| 768 | 768 | (let ((mod (trs$module trs))) |
| 769 | 769 | (let ((own-axs (module-own-axioms-ordered mod nil)) |
| 770 | (imp-axs (module-imported-axioms mod nil)) | |
| 771 | (eqns nil) | |
| 772 | (trns nil) | |
| 773 | (val nil)) | |
| 770 | (imp-axs (module-imported-axioms mod nil)) | |
| 771 | (eqns nil) | |
| 772 | (trns nil) | |
| 773 | (val nil)) | |
| 774 | 774 | (setq val (trs$get-axioms own-axs trs)) |
| 775 | 775 | (setq eqns (car val) |
| 776 | trns (cadr val)) | |
| 776 | trns (cadr val)) | |
| 777 | 777 | (setq val (trs$get-axioms imp-axs trs)) |
| 778 | 778 | (setf (trs$eqns trs) (nconc eqns (car val))) |
| 779 | 779 | (setf (trs$trns trs) (nconc trns (cadr val)))))) |
| 781 | 781 | |
| 782 | 782 | (defun trs$get-axioms (axs trs &optional include-bad-rule) |
| 783 | 783 | (let ((eqs nil) |
| 784 | (trns nil) | |
| 785 | (tinfo nil)) | |
| 784 | (trns nil) | |
| 785 | (tinfo nil)) | |
| 786 | 786 | (dolist (ax axs |
| 787 | (list (nreverse eqs) (nreverse trns))) | |
| 787 | (list (nreverse eqs) (nreverse trns))) | |
| 788 | 788 | (let ((lhs-top (term-head (axiom-lhs ax)))) |
| 789 | (unless (or (eq lhs-top *bool-if*) | |
| 790 | (eq lhs-top *bool-equal*) | |
| 791 | (eq lhs-top *beh-eq-pred*) | |
| 792 | (eq lhs-top *bool-nonequal*) | |
| 793 | (eq lhs-top *rwl-predicate*)) | |
| 794 | (setq tinfo (get-trs-axiom ax trs include-bad-rule))) | |
| 795 | (when tinfo | |
| 796 | (if (memq (axiom-type ax) '(:equation :pignose-axiom :pignose-goal)) | |
| 797 | (push tinfo eqs) | |
| 798 | (push tinfo trns))))) | |
| 789 | (unless (or (eq lhs-top *bool-if*) | |
| 790 | (eq lhs-top *bool-equal*) | |
| 791 | (eq lhs-top *beh-eq-pred*) | |
| 792 | (eq lhs-top *bool-nonequal*) | |
| 793 | (eq lhs-top *rwl-predicate*)) | |
| 794 | (setq tinfo (get-trs-axiom ax trs include-bad-rule))) | |
| 795 | (when tinfo | |
| 796 | (if (memq (axiom-type ax) '(:equation :pignose-axiom :pignose-goal)) | |
| 797 | (push tinfo eqs) | |
| 798 | (push tinfo trns))))) | |
| 799 | 799 | )) |
| 800 | 800 | |
| 801 | 801 | (defun get-trs-axiom (ax trs &optional include-bad-rule) |
| 802 | 802 | (let* ((lhs (axiom-lhs ax)) |
| 803 | (rhs (axiom-rhs ax)) | |
| 804 | (cond (axiom-condition ax)) | |
| 805 | (condp (not (is-true? cond))) | |
| 806 | (type (axiom-type ax)) | |
| 807 | (behavioural (axiom-is-behavioural ax)) | |
| 808 | (kind (axiom-kind ax)) | |
| 809 | (label (axiom-labels ax))) | |
| 803 | (rhs (axiom-rhs ax)) | |
| 804 | (cond (axiom-condition ax)) | |
| 805 | (condp (not (is-true? cond))) | |
| 806 | (type (axiom-type ax)) | |
| 807 | (behavioural (axiom-is-behavioural ax)) | |
| 808 | (kind (axiom-kind ax)) | |
| 809 | (label (axiom-labels ax))) | |
| 810 | 810 | (when (eq kind :bad-rule) |
| 811 | 811 | (unless include-bad-rule |
| 812 | (return-from get-trs-axiom nil))) | |
| 812 | (return-from get-trs-axiom nil))) | |
| 813 | 813 | (list* (case type |
| 814 | (:equation | |
| 815 | (cond (behavioural | |
| 816 | (cond (condp :bceq) | |
| 817 | (t :beq))) | |
| 818 | (t (cond (condp :ceq) | |
| 819 | (t :eq))))) | |
| 820 | (t (cond (behavioural | |
| 821 | (cond (condp :bctrans) | |
| 822 | (t :btrans))) | |
| 823 | (t (cond (condp :ctrans) | |
| 824 | (t :trans)))))) | |
| 825 | (if label | |
| 826 | (string (car label)) | |
| 827 | nil) | |
| 828 | (trs$make-term-form lhs trs) | |
| 829 | (trs$make-term-form rhs trs) | |
| 830 | (if condp | |
| 831 | (list (trs$make-term-form cond trs)) | |
| 832 | nil)))) | |
| 814 | (:equation | |
| 815 | (cond (behavioural | |
| 816 | (cond (condp :bceq) | |
| 817 | (t :beq))) | |
| 818 | (t (cond (condp :ceq) | |
| 819 | (t :eq))))) | |
| 820 | (t (cond (behavioural | |
| 821 | (cond (condp :bctrans) | |
| 822 | (t :btrans))) | |
| 823 | (t (cond (condp :ctrans) | |
| 824 | (t :trans)))))) | |
| 825 | (if label | |
| 826 | (string (car label)) | |
| 827 | nil) | |
| 828 | (trs$make-term-form lhs trs) | |
| 829 | (trs$make-term-form rhs trs) | |
| 830 | (if condp | |
| 831 | (list (trs$make-term-form cond trs)) | |
| 832 | nil)))) | |
| 833 | 833 | |
| 834 | 834 | (defmacro trs-axiom-type (ax) `(car ,ax)) |
| 835 | 835 | (defmacro trs-axiom-label (ax) `(cadr ,ax)) |
| 0 | 0 | ;;;-*-Mode:LISP; Package: CHAOS; Base:10; Syntax:Common-lisp -*- |
| 1 | 1 | ;;; |
| 2 | ;;; Copyright (c) 2000-2014, Toshimi Sawada. All rights reserved. | |
| 2 | ;;; Copyright (c) 2000-2015, Toshimi Sawada. All rights reserved. | |
| 3 | 3 | ;;; |
| 4 | 4 | ;;; Redistribution and use in source and binary forms, with or without |
| 5 | 5 | ;;; modification, are permitted provided that the following conditions |
| 27 | 27 | ;;; |
| 28 | 28 | (in-package :chaos) |
| 29 | 29 | #|============================================================================= |
| 30 | System:CHAOS | |
| 31 | Module:construct | |
| 32 | File:trs.lisp | |
| 30 | System:CHAOS | |
| 31 | Module:construct | |
| 32 | File:trs.lisp | |
| 33 | 33 | =============================================================================|# |
| 34 | 34 | #-:chaos-debug |
| 35 | 35 | (declaim (optimize (speed 3) (safety 0) #-GCL (debug 1))) |
| 45 | 45 | ;;; excepting module names. |
| 46 | 46 | ;;; --------------------------------------------------------------------------- |
| 47 | 47 | |
| 48 | ;; (declaim (special *current-trs*)) ; not used now | |
| 48 | ;; (declaim (special *current-trs*)) ; not used now | |
| 49 | 49 | ;; (defvar *current-trs* nil) |
| 50 | 50 | |
| 51 | 51 | (defun trs-get-mod-or-error (modexp) |
| 52 | 52 | (if (module-p modexp) |
| 53 | 53 | modexp |
| 54 | 54 | (let ((modval nil)) |
| 55 | (cond ((null modexp) | |
| 56 | (setq modval (eval-mod nil))) | |
| 57 | ((stringp modexp) | |
| 58 | (setq modval (eval-mod (list modexp)))) | |
| 59 | (t (with-output-chaos-error ('invalid-modexp) | |
| 60 | (format t "illegal modexp ~a" modexp) | |
| 61 | ))) | |
| 62 | (if modval | |
| 63 | modval | |
| 64 | (with-output-chaos-error ('unknown-mod) | |
| 65 | (format t "could not evaluate modexp ~a" modexp) | |
| 66 | ))))) | |
| 55 | (cond ((null modexp) | |
| 56 | (setq modval (eval-mod nil))) | |
| 57 | ((stringp modexp) | |
| 58 | (setq modval (eval-mod (list modexp)))) | |
| 59 | (t (with-output-chaos-error ('invalid-modexp) | |
| 60 | (format t "illegal modexp ~a" modexp) | |
| 61 | ))) | |
| 62 | (if modval | |
| 63 | modval | |
| 64 | (with-output-chaos-error ('unknown-mod) | |
| 65 | (format t "could not evaluate modexp ~a" modexp) | |
| 66 | ))))) | |
| 67 | 67 | |
| 68 | 68 | (defun get-module-trs-or-error (modexp) |
| 69 | 69 | (get-module-trs (trs-get-mod-or-error modexp))) |
| 75 | 75 | (setq module (trs-get-mod-or-error modexp)) |
| 76 | 76 | (let ((trs (module-trs module))) |
| 77 | 77 | (if (need-rewriting-preparation module) |
| 78 | (progn | |
| 79 | (compile-module module) | |
| 80 | (chaos->trs module)) | |
| 81 | (if (null (trs$sort-name-map trs)) | |
| 82 | (chaos->trs module))) | |
| 78 | (progn | |
| 79 | (compile-module module) | |
| 80 | (chaos->trs module)) | |
| 81 | (if (null (trs$sort-name-map trs)) | |
| 82 | (chaos->trs module))) | |
| 83 | 83 | trs)) |
| 84 | 84 | |
| 85 | 85 | ;;; |
| 98 | 98 | trs)) |
| 99 | 99 | |
| 100 | 100 | (defun print-chaos-trs (trs &optional (stream *standard-output*) |
| 101 | &rest ignore) | |
| 101 | &rest ignore) | |
| 102 | 102 | (declare (ignore ignore)) |
| 103 | 103 | (let ((*print-circle* nil) |
| 104 | (*print-case* :downcase) | |
| 105 | (*print-escape* nil)) | |
| 104 | (*print-case* :downcase) | |
| 105 | (*print-escape* nil)) | |
| 106 | 106 | (prin1 |
| 107 | 107 | (make-trs-print-form trs) |
| 108 | 108 | stream) |
| 135 | 135 | (declare (type simple-string name sup-str)) |
| 136 | 136 | (let ((nam-tok (parse-with-delimiter name #\space))) |
| 137 | 137 | (if (cdr nam-tok) |
| 138 | (reduce #'(lambda (x y) | |
| 139 | (declare (type simple-string x y)) | |
| 140 | (concatenate 'string | |
| 141 | x | |
| 142 | sup-str | |
| 143 | y)) | |
| 144 | nam-tok) | |
| 145 | (car nam-tok)))) | |
| 138 | (reduce #'(lambda (x y) | |
| 139 | (declare (type simple-string x y)) | |
| 140 | (concatenate 'string | |
| 141 | x | |
| 142 | sup-str | |
| 143 | y)) | |
| 144 | nam-tok) | |
| 145 | (car nam-tok)))) | |
| 146 | 146 | |
| 147 | 147 | (defun trs-proper-sort-p (sort) |
| 148 | 148 | (or (sort= sort *sort-id-sort*) |
| 149 | 149 | (not (or (err-sort-p sort) |
| 150 | (memq (sort-module sort) | |
| 151 | *kernel-hard-wired-builtin-modules*))))) | |
| 150 | (memq (sort-module sort) | |
| 151 | *kernel-hard-wired-builtin-modules*))))) | |
| 152 | 152 | |
| 153 | 153 | (defun trs-proper-sort-p* (sort) |
| 154 | 154 | (or (sort= sort *sort-id-sort*) |
| 155 | 155 | (not (memq (sort-module sort) |
| 156 | *kernel-hard-wired-builtin-modules*)))) | |
| 156 | *kernel-hard-wired-builtin-modules*)))) | |
| 157 | 157 | |
| 158 | 158 | ;;; |
| 159 | 159 | ;;; |
| 176 | 176 | (defun make-trs-module-name (module) |
| 177 | 177 | (let ((name (module-name module))) |
| 178 | 178 | (if (modexp-is-simple-name name) |
| 179 | (make-module-print-name2 module) | |
| 180 | (or (gethash module _trs_mod_name_hash_) | |
| 181 | (let ((trs-nam (make-trs-module-name-internal name))) | |
| 182 | (setf (gethash module _trs_mod_name_hash_) | |
| 183 | trs-nam) | |
| 184 | trs-nam))))) | |
| 179 | (make-module-print-name2 module) | |
| 180 | (or (gethash module _trs_mod_name_hash_) | |
| 181 | (let ((trs-nam (make-trs-module-name-internal name))) | |
| 182 | (setf (gethash module _trs_mod_name_hash_) | |
| 183 | trs-nam) | |
| 184 | trs-nam))))) | |
| 185 | 185 | |
| 186 | 186 | (defun make-trs-sort-name (sort) |
| 187 | 187 | (let* ((org-sort (get-original-sort sort)) |
| 188 | (dep-mod (sort-module org-sort))) | |
| 188 | (dep-mod (sort-module org-sort))) | |
| 189 | 189 | (when (memq dep-mod *tram-builtin-modules*) |
| 190 | 190 | (setq sort org-sort)) |
| 191 | 191 | (values |
| 192 | 192 | (intern (concatenate 'string |
| 193 | (string-replace-space-with | |
| 194 | (the simple-string (string (sort-id sort))) | |
| 195 | "$sp$") | |
| 196 | "." | |
| 197 | (the simple-string | |
| 198 | (make-trs-module-name (sort-module sort))))) | |
| 193 | (string-replace-space-with | |
| 194 | (the simple-string (string (sort-id sort))) | |
| 195 | "$sp$") | |
| 196 | "." | |
| 197 | (the simple-string | |
| 198 | (make-trs-module-name (sort-module sort))))) | |
| 199 | 199 | dep-mod |
| 200 | 200 | ))) |
| 201 | 201 | |
| 203 | 203 | (let ((so (trs$sort-order trs))) |
| 204 | 204 | (dolist (sort (trs$sorts trs)) |
| 205 | 205 | (when (trs-proper-sort-p* sort) |
| 206 | (push (cons sort (make-trs-sort-name sort)) | |
| 207 | (trs$sort-name-map trs)) | |
| 208 | (let ((ds (direct-supersorts sort so))) | |
| 209 | (when (and (null (cdr ds)) (err-sort-p (car ds)) | |
| 210 | (not (assq (car ds) (trs$sort-name-map trs)))) | |
| 211 | (push (cons (car ds) (make-trs-sort-name (car ds))) | |
| 212 | (trs$sort-name-map trs)))) | |
| 213 | )))) | |
| 206 | (push (cons sort (make-trs-sort-name sort)) | |
| 207 | (trs$sort-name-map trs)) | |
| 208 | (let ((ds (direct-supersorts sort so))) | |
| 209 | (when (and (null (cdr ds)) (err-sort-p (car ds)) | |
| 210 | (not (assq (car ds) (trs$sort-name-map trs)))) | |
| 211 | (push (cons (car ds) (make-trs-sort-name (car ds))) | |
| 212 | (trs$sort-name-map trs)))) | |
| 213 | )))) | |
| 214 | 214 | |
| 215 | 215 | (defun map-chaos-sort-to-trs (sort trs) |
| 216 | 216 | (cdr (assq sort (trs$sort-name-map trs)))) |
| 219 | 219 | (unless (sort-struct-p sort) (break "PANIC")) |
| 220 | 220 | (or (map-chaos-sort-to-trs sort trs) |
| 221 | 221 | (cond ((sort= sort *identifier-sort*) |
| 222 | '|Id.QID|) ; just for a moment | |
| 223 | ((sort= sort *universal-sort*) | |
| 224 | (sort-name *universal-sort*)) | |
| 225 | ((sort= sort *huniversal-sort*) | |
| 226 | (sort-name *huniversal-sort*)) | |
| 227 | ((sort= sort *cosmos*) | |
| 228 | (sort-name *cosmos*)) | |
| 229 | ((sort= sort *bottom-sort*) | |
| 230 | (sort-name *bottom-sort*)) | |
| 231 | (t (if ignore-error | |
| 232 | (sort-name sort) | |
| 233 | (with-output-panic-message () | |
| 234 | (format t | |
| 235 | "could not map sort ~a to trs" | |
| 236 | (string (sort-id sort))) | |
| 237 | nil)))))) | |
| 238 | ||
| 222 | '|Id.QID|) ; just for a moment | |
| 223 | ((sort= sort *universal-sort*) | |
| 224 | (sort-name *universal-sort*)) | |
| 225 | ((sort= sort *huniversal-sort*) | |
| 226 | (sort-name *huniversal-sort*)) | |
| 227 | ((sort= sort *cosmos*) | |
| 228 | (sort-name *cosmos*)) | |
| 229 | ((sort= sort *bottom-sort*) | |
| 230 | (sort-name *bottom-sort*)) | |
| 231 | (t (if ignore-error | |
| 232 | (sort-name sort) | |
| 233 | (with-output-panic-message () | |
| 234 | (format t | |
| 235 | "could not map sort ~a to trs" | |
| 236 | (string (sort-id sort))) | |
| 237 | nil)))))) | |
| 238 | ||
| 239 | 239 | (defun map-trs-sort-to-chaos (name trs) |
| 240 | 240 | (when (stringp name) |
| 241 | 241 | (setq name (intern name))) |
| 242 | 242 | (or (car (rassoc name (trs$sort-name-map trs) :test #'eq)) |
| 243 | 243 | (if (eq name '|Id.QID|) |
| 244 | *identifier-sort* | |
| 245 | nil) | |
| 244 | *identifier-sort* | |
| 245 | nil) | |
| 246 | 246 | )) |
| 247 | 247 | |
| 248 | 248 | ;;; |
| 250 | 250 | ;;; |
| 251 | 251 | (defun make-trs-sort-graph (trs) |
| 252 | 252 | (let ((so (trs$sort-order trs)) |
| 253 | ;; (snmlist (trs$sort-name-map trs)) | |
| 254 | (sub-rel nil) | |
| 255 | (err-rel nil)) | |
| 253 | ;; (snmlist (trs$sort-name-map trs)) | |
| 254 | (sub-rel nil) | |
| 255 | (err-rel nil)) | |
| 256 | 256 | (dolist (s (trs$sorts trs)) |
| 257 | 257 | (block next |
| 258 | ;; (unless (trs-proper-sort-p s) (return-from next nil)) | |
| 259 | (let ((supers (direct-supersorts s so))) | |
| 260 | (when supers | |
| 261 | (if (and (null (cdr supers)) | |
| 262 | (err-sort-p (car supers))) | |
| 263 | (if (not (trs-proper-sort-p s)) | |
| 264 | (return-from next nil) | |
| 265 | (push (list (map-chaos-sort-to-trs-or-panic s trs) | |
| 266 | (map-chaos-sort-to-trs-or-panic (car supers) trs)) | |
| 267 | err-rel)) | |
| 268 | ;; else | |
| 269 | (let ((s-mapped (map-chaos-sort-to-trs-or-panic s trs t))) | |
| 270 | (setq supers | |
| 271 | (delete-if-not #'(lambda (x) | |
| 272 | (trs-proper-sort-p x)) | |
| 273 | supers)) | |
| 274 | (unless supers | |
| 275 | (return-from next nil)) | |
| 276 | (dolist (sup supers) | |
| 277 | (push (list s-mapped | |
| 278 | (map-chaos-sort-to-trs-or-panic sup trs)) | |
| 279 | sub-rel)))))) | |
| 280 | )) | |
| 258 | ;; (unless (trs-proper-sort-p s) (return-from next nil)) | |
| 259 | (let ((supers (direct-supersorts s so))) | |
| 260 | (when supers | |
| 261 | (if (and (null (cdr supers)) | |
| 262 | (err-sort-p (car supers))) | |
| 263 | (if (not (trs-proper-sort-p s)) | |
| 264 | (return-from next nil) | |
| 265 | (push (list (map-chaos-sort-to-trs-or-panic s trs) | |
| 266 | (map-chaos-sort-to-trs-or-panic (car supers) trs)) | |
| 267 | err-rel)) | |
| 268 | ;; else | |
| 269 | (let ((s-mapped (map-chaos-sort-to-trs-or-panic s trs t))) | |
| 270 | (setq supers | |
| 271 | (delete-if-not #'(lambda (x) | |
| 272 | (trs-proper-sort-p x)) | |
| 273 | supers)) | |
| 274 | (unless supers | |
| 275 | (return-from next nil)) | |
| 276 | (dolist (sup supers) | |
| 277 | (push (list s-mapped | |
| 278 | (map-chaos-sort-to-trs-or-panic sup trs)) | |
| 279 | sub-rel)))))) | |
| 280 | )) | |
| 281 | 281 | ;; |
| 282 | 282 | (setf (trs$sort-graph trs) (nreverse sub-rel)) |
| 283 | 283 | (setf (trs$err-sorts trs) (nreverse err-rel)) |
| 315 | 315 | (defun trs-proper-method-p (meth) |
| 316 | 316 | (and (not (method-is-error-method meth)) |
| 317 | 317 | (not (memq (method-module meth) |
| 318 | *kernel-hard-wired-builtin-modules*)) | |
| 318 | *kernel-hard-wired-builtin-modules*)) | |
| 319 | 319 | (not (or (eq meth *bool-if*) |
| 320 | (eq meth *sort-membership*) | |
| 321 | (eq meth *bool-equal*) | |
| 322 | (eq meth *beh-equal*) | |
| 323 | (eq meth *beh-eq-pred*) | |
| 324 | (eq meth *bool-nonequal*) | |
| 325 | (eq meth *rwl-predicate*) | |
| 326 | (eq meth *rwl-predicate2*))))) | |
| 320 | (eq meth *sort-membership*) | |
| 321 | (eq meth *bool-equal*) | |
| 322 | (eq meth *beh-equal*) | |
| 323 | (eq meth *beh-eq-pred*) | |
| 324 | (eq meth *bool-nonequal*) | |
| 325 | (eq meth *rwl-predicate*) | |
| 326 | (eq meth *rwl-predicate2*))))) | |
| 327 | 327 | |
| 328 | 328 | ;;; |
| 329 | 329 | |
| 333 | 333 | (or (eq method *bool-true-meth*) |
| 334 | 334 | (eq method *bool-false-meth*) |
| 335 | 335 | (let ((mxs (cons method (method-overloaded-methods method opinfo-table)))) |
| 336 | (some #'(lambda (x) | |
| 337 | (let ((mmod (method-module x))) | |
| 338 | (or (memq mmod *tram-bool-modules*) | |
| 339 | (memq mmod *tram-builtin-modules*)))) | |
| 340 | mxs)))) | |
| 336 | (some #'(lambda (x) | |
| 337 | (let ((mmod (method-module x))) | |
| 338 | (or (memq mmod *tram-bool-modules*) | |
| 339 | (memq mmod *tram-builtin-modules*)))) | |
| 340 | mxs)))) | |
| 341 | 341 | |
| 342 | 342 | (defun trs-get-real-method-if-dummy (method trs) |
| 343 | 343 | (let ((ent (rassoc method (trs$dummy-methods trs)))) |
| 344 | 344 | (if ent |
| 345 | (caar ent) | |
| 346 | method))) | |
| 345 | (caar ent) | |
| 346 | method))) | |
| 347 | 347 | |
| 348 | 348 | (defun make-trs-op-name (method module &aux (trs (module-trs module))) |
| 349 | 349 | ;; NOTE* assumption: sort name map should have been generated. |
| 350 | 350 | ;; this is used for modifying operator name with the error-sort |
| 351 | 351 | ;; of its coarity. |
| 352 | 352 | (let ((name (cadr (assq method (trs$op-info-map trs)))) |
| 353 | (opinfo-table (module-opinfo-table module)) | |
| 354 | (sort-name-map (trs$sort-name-map trs))) | |
| 353 | (opinfo-table (module-opinfo-table module)) | |
| 354 | (sort-name-map (trs$sort-name-map trs))) | |
| 355 | 355 | (when name (return-from make-trs-op-name name)) |
| 356 | 356 | ;; |
| 357 | 357 | (setq method (trs-get-real-method-if-dummy method trs)) |
| 358 | 358 | ;; |
| 359 | 359 | (if (get-method-info method opinfo-table) |
| 360 | (let ((op (method-operator method opinfo-table))) | |
| 361 | (setq name (operator-print-name op))) | |
| 362 | (let ((meth-name (method-name method))) | |
| 363 | (if (member "_" (car meth-name) :test #'equal) | |
| 364 | ;; mixfix | |
| 365 | (setq name (make-print-operator-id (car meth-name))) | |
| 366 | ;; | |
| 367 | (setq name (format nil "~a/~d" | |
| 368 | (make-print-operator-id (car meth-name)) | |
| 369 | (cdr meth-name)))))) | |
| 360 | (let ((op (method-operator method opinfo-table))) | |
| 361 | (setq name (operator-print-name op))) | |
| 362 | (let ((meth-name (method-name method))) | |
| 363 | (if (member "_" (car meth-name) :test #'equal) | |
| 364 | ;; mixfix | |
| 365 | (setq name (make-print-operator-id (car meth-name))) | |
| 366 | ;; | |
| 367 | (setq name (format nil "~a/~d" | |
| 368 | (make-print-operator-id (car meth-name)) | |
| 369 | (cdr meth-name)))))) | |
| 370 | 370 | ;; |
| 371 | 371 | (when (and *trs-modify-operator-name* |
| 372 | (not (trs-check-if-builtin-op-family method opinfo-table))) | |
| 372 | (not (trs-check-if-builtin-op-family method opinfo-table))) | |
| 373 | 373 | (setq name (concatenate 'string |
| 374 | name | |
| 375 | (let ((err-sort (the-err-sort (method-coarity method) | |
| 376 | (module-sort-order module)))) | |
| 377 | (string (or (cdr (assq err-sort sort-name-map)) | |
| 378 | (sort-id err-sort))))))) | |
| 374 | name | |
| 375 | (let ((err-sort (the-err-sort (method-coarity method) | |
| 376 | (module-sort-order module)))) | |
| 377 | (string (or (cdr (assq err-sort sort-name-map)) | |
| 378 | (sort-id err-sort))))))) | |
| 379 | 379 | ;; |
| 380 | 380 | (or (gethash name *trs-opname-hash*) |
| 381 | (setf (gethash name *trs-opname-hash*) | |
| 382 | (let ((res nil) | |
| 383 | (lim (length name)) | |
| 384 | (cur-tok nil)) | |
| 385 | (declare (type fixnum lim)) | |
| 386 | (do ((pos 0 (1+ pos))) | |
| 387 | ((>= pos lim)) | |
| 388 | (declare (type fixnum pos)) | |
| 389 | (setq cur-tok (char name pos)) | |
| 390 | (push (or (cdr (assoc cur-tok | |
| 391 | trs-operator-special-token-map | |
| 392 | :test #'equal)) | |
| 393 | (string cur-tok)) | |
| 394 | res)) | |
| 395 | (intern (reduce #'(lambda (x y) | |
| 396 | (declare (type simple-string x y)) | |
| 397 | (concatenate 'string x y)) | |
| 398 | (nreverse res)))))))) | |
| 381 | (setf (gethash name *trs-opname-hash*) | |
| 382 | (let ((res nil) | |
| 383 | (lim (length name)) | |
| 384 | (cur-tok nil)) | |
| 385 | (declare (type fixnum lim)) | |
| 386 | (do ((pos 0 (1+ pos))) | |
| 387 | ((>= pos lim)) | |
| 388 | (declare (type fixnum pos)) | |
| 389 | (setq cur-tok (char name pos)) | |
| 390 | (push (or (cdr (assoc cur-tok | |
| 391 | trs-operator-special-token-map | |
| 392 | :test #'equal)) | |
| 393 | (string cur-tok)) | |
| 394 | res)) | |
| 395 | (intern (reduce #'(lambda (x y) | |
| 396 | (declare (type simple-string x y)) | |
| 397 | (concatenate 'string x y)) | |
| 398 | (nreverse res)))))))) | |
| 399 | 399 | |
| 400 | 400 | (defun make-trs-op-info (method trs) |
| 401 | 401 | (let ((module (trs$module trs))) |
| 402 | 402 | (with-in-module (module) |
| 403 | 403 | (let ((method-name (make-trs-op-name method module)) |
| 404 | (arity (mapcar #'(lambda (s) (map-chaos-sort-to-trs-or-panic s | |
| 405 | trs | |
| 406 | t)) | |
| 407 | (method-arity method))) | |
| 408 | (coarity (map-chaos-sort-to-trs-or-panic | |
| 409 | (method-coarity method) | |
| 410 | trs | |
| 411 | t)) | |
| 412 | (attrs (make-trs-method-attr method module))) | |
| 413 | (list* method-name arity coarity attrs))))) | |
| 404 | (arity (mapcar #'(lambda (s) (map-chaos-sort-to-trs-or-panic s | |
| 405 | trs | |
| 406 | t)) | |
| 407 | (method-arity method))) | |
| 408 | (coarity (map-chaos-sort-to-trs-or-panic | |
| 409 | (method-coarity method) | |
| 410 | trs | |
| 411 | t)) | |
| 412 | (attrs (make-trs-method-attr method module))) | |
| 413 | (list* method-name arity coarity attrs))))) | |
| 414 | 414 | |
| 415 | 415 | (defun make-trs-op-maps (trs) |
| 416 | 416 | (let ((module (trs$module trs))) |
| 429 | 429 | ;; getting modules from their names). |
| 430 | 430 | ;; |
| 431 | 431 | (dolist (ops (module-all-operators module)) |
| 432 | (let ((methods (opinfo-methods ops))) | |
| 433 | (dolist (m methods) | |
| 434 | (let ((info (make-trs-op-info m trs))) | |
| 435 | (when (or (method-is-error-method m) | |
| 436 | (null (method-arity m))) | |
| 437 | (let ((rev-ent (assq (car info) | |
| 438 | (trs$op-rev-table trs)))) | |
| 439 | (if rev-ent | |
| 440 | (setf (cdr rev-ent) m) | |
| 441 | (push (cons (car info) m) | |
| 442 | (trs$op-rev-table trs))))) | |
| 443 | (when (trs-proper-method-p m) | |
| 444 | ;; trs-proper-method-p rejects error method. | |
| 445 | (push (cons m info) res)))))) | |
| 432 | (let ((methods (opinfo-methods ops))) | |
| 433 | (dolist (m methods) | |
| 434 | (let ((info (make-trs-op-info m trs))) | |
| 435 | (when (or (method-is-error-method m) | |
| 436 | (null (method-arity m))) | |
| 437 | (let ((rev-ent (assq (car info) | |
| 438 | (trs$op-rev-table trs)))) | |
| 439 | (if rev-ent | |
| 440 | (setf (cdr rev-ent) m) | |
| 441 | (push (cons (car info) m) | |
| 442 | (trs$op-rev-table trs))))) | |
| 443 | (when (trs-proper-method-p m) | |
| 444 | ;; trs-proper-method-p rejects error method. | |
| 445 | (push (cons m info) res)))))) | |
| 446 | 446 | ;; make reverse op maps for builtin operators |
| 447 | 447 | (when (assq *truth-module* (module-all-submodules module)) |
| 448 | (dolist (op (list *bool-equal* *bool-nonequal* | |
| 449 | *sort-membership* | |
| 450 | *beh-equal* *bool-if* *beh-eq-pred*)) | |
| 451 | (push (cons (make-trs-op-name op module) | |
| 452 | op) | |
| 453 | (trs$op-rev-table trs)))) | |
| 448 | (dolist (op (list *bool-equal* *bool-nonequal* | |
| 449 | *sort-membership* | |
| 450 | *beh-equal* *bool-if* *beh-eq-pred*)) | |
| 451 | (push (cons (make-trs-op-name op module) | |
| 452 | op) | |
| 453 | (trs$op-rev-table trs)))) | |
| 454 | 454 | ;; other optional built-ins. |
| 455 | 455 | #|| TODO: |
| 456 | 456 | (when (module-includes-rwl module) |
| 457 | (push (cons (make-trs-op-name *rwl-predicate* module) | |
| 458 | *rwl-predicate*) | |
| 459 | (trs$op-rev-table trs)) | |
| 460 | (push (cons (make-trs-op-name *rwl-predicate2* module) | |
| 461 | *rwl-predicate2*) | |
| 462 | (trs$op-rev-table trs))) | |
| 457 | (push (cons (make-trs-op-name *rwl-predicate* module) | |
| 458 | *rwl-predicate*) | |
| 459 | (trs$op-rev-table trs)) | |
| 460 | (push (cons (make-trs-op-name *rwl-predicate2* module) | |
| 461 | *rwl-predicate2*) | |
| 462 | (trs$op-rev-table trs))) | |
| 463 | 463 | ||# |
| 464 | 464 | ;; |
| 465 | 465 | (setf (trs$op-info-map trs) |
| 466 | (nreverse res))))) | |
| 466 | (nreverse res))))) | |
| 467 | 467 | |
| 468 | 468 | (defun make-trs-method-attr (meth module) |
| 469 | 469 | (with-in-module (module) |
| 470 | 470 | (let ((theory (method-theory meth)) |
| 471 | (strat (method-rewrite-strategy meth)) | |
| 472 | (constr (method-constructor meth)) | |
| 473 | ;; (prec (method-precedence meth)) | |
| 474 | (assoc (method-associativity meth)) | |
| 475 | (memo (method-has-memo meth)) | |
| 476 | (res nil)) | |
| 471 | (strat (method-rewrite-strategy meth)) | |
| 472 | (constr (method-constructor meth)) | |
| 473 | ;; (prec (method-precedence meth)) | |
| 474 | (assoc (method-associativity meth)) | |
| 475 | (memo (method-has-memo meth)) | |
| 476 | (res nil)) | |
| 477 | 477 | ;; |
| 478 | 478 | ;; (when (and (eql 0 (car (last strat))) |
| 479 | 479 | ;; (member 0 (butlast strat))) |
| 480 | 480 | ;; (setq strat (butlast strat))) |
| 481 | 481 | ;; |
| 482 | 482 | (let ((th-info (theory-info theory)) |
| 483 | (zero (theory-zero theory))) | |
| 484 | (when (not (eq th-info the-e-property)) | |
| 485 | (when (or (theory-info-is-AC th-info) | |
| 486 | (theory-info-is-A th-info) | |
| 487 | (theory-info-is-AI th-info) | |
| 488 | (theory-info-is-AZ th-info) | |
| 489 | (theory-info-is-AIZ th-info) | |
| 490 | (theory-info-is-ACI th-info) | |
| 491 | (theory-info-is-ACZ th-info) | |
| 492 | (theory-info-is-ACIZ th-info)) | |
| 493 | (push ':assoc res)) | |
| 494 | (when (or (theory-info-is-AC th-info) | |
| 495 | (theory-info-is-C th-info) | |
| 496 | (theory-info-is-CI th-info) | |
| 497 | (theory-info-is-CZ th-info) | |
| 498 | (theory-info-is-CIZ th-info) | |
| 499 | (theory-info-is-ACI th-info) | |
| 500 | (theory-info-is-ACZ th-info) | |
| 501 | (theory-info-is-ACIZ th-info)) | |
| 502 | (push ':comm res)) | |
| 503 | (when (or (theory-info-is-I th-info) | |
| 504 | (theory-info-is-IZ th-info) | |
| 505 | (theory-info-is-CI th-info) | |
| 506 | (theory-info-is-CIZ th-info) | |
| 507 | (theory-info-is-AI th-info) | |
| 508 | (theory-info-is-AIZ th-info) | |
| 509 | (theory-info-is-ACI th-info) | |
| 510 | (theory-info-is-ACIZ th-info)) | |
| 511 | (push ':idem res)) | |
| 512 | (when zero | |
| 513 | (let ((mth (car zero))) ; to be fixed later. | |
| 514 | (if (null (cdr zero)) | |
| 515 | (push (list ':id mth) res) | |
| 516 | (push (list ':idr mth) res)))) | |
| 517 | )) | |
| 483 | (zero (theory-zero theory))) | |
| 484 | (when (not (eq th-info the-e-property)) | |
| 485 | (when (or (theory-info-is-AC th-info) | |
| 486 | (theory-info-is-A th-info) | |
| 487 | (theory-info-is-AI th-info) | |
| 488 | (theory-info-is-AZ th-info) | |
| 489 | (theory-info-is-AIZ th-info) | |
| 490 | (theory-info-is-ACI th-info) | |
| 491 | (theory-info-is-ACZ th-info) | |
| 492 | (theory-info-is-ACIZ th-info)) | |
| 493 | (push ':assoc res)) | |
| 494 | (when (or (theory-info-is-AC th-info) | |
| 495 | (theory-info-is-C th-info) | |
| 496 | (theory-info-is-CI th-info) | |
| 497 | (theory-info-is-CZ th-info) | |
| 498 | (theory-info-is-CIZ th-info) | |
| 499 | (theory-info-is-ACI th-info) | |
| 500 | (theory-info-is-ACZ th-info) | |
| 501 | (theory-info-is-ACIZ th-info)) | |
| 502 | (push ':comm res)) | |
| 503 | (when (or (theory-info-is-I th-info) | |
| 504 | (theory-info-is-IZ th-info) | |
| 505 | (theory-info-is-CI th-info) | |
| 506 | (theory-info-is-CIZ th-info) | |
| 507 | (theory-info-is-AI th-info) | |
| 508 | (theory-info-is-AIZ th-info) | |
| 509 | (theory-info-is-ACI th-info) | |
| 510 | (theory-info-is-ACIZ th-info)) | |
| 511 | (push ':idem res)) | |
| 512 | (when zero | |
| 513 | (let ((mth (car zero))) ; to be fixed later. | |
| 514 | (if (null (cdr zero)) | |
| 515 | (push (list ':id mth) res) | |
| 516 | (push (list ':idr mth) res)))) | |
| 517 | )) | |
| 518 | 518 | (when strat |
| 519 | (push (list ':strat strat) res)) | |
| 519 | (push (list ':strat strat) res)) | |
| 520 | 520 | (when memo |
| 521 | (push ':memo res)) | |
| 521 | (push ':memo res)) | |
| 522 | 522 | (when constr |
| 523 | (push ':constr res)) | |
| 523 | (push ':constr res)) | |
| 524 | 524 | (when assoc |
| 525 | (push (if (eq :left assoc) | |
| 526 | ':l-assoc | |
| 527 | ':r-assoc) | |
| 528 | res)) | |
| 525 | (push (if (eq :left assoc) | |
| 526 | ':l-assoc | |
| 527 | ':r-assoc) | |
| 528 | res)) | |
| 529 | 529 | res))) |
| 530 | 530 | |
| 531 | 531 | (defun fix-trs-ids (trs) |
| 532 | 532 | (dolist (map (trs$op-info-map trs)) |
| 533 | 533 | (let* ((info (cdr map)) |
| 534 | (zero (find-if #'(lambda (x) (and (consp x) | |
| 535 | (or (eq (car x) :id) | |
| 536 | (eq (car x) :idr)))) | |
| 537 | info))) | |
| 534 | (zero (find-if #'(lambda (x) (and (consp x) | |
| 535 | (or (eq (car x) :id) | |
| 536 | (eq (car x) :idr)))) | |
| 537 | info))) | |
| 538 | 538 | (when zero |
| 539 | (setf (cdr zero) (list (trs$make-term-form (cadr zero) trs))))))) | |
| 539 | (setf (cdr zero) (list (trs$make-term-form (cadr zero) trs))))))) | |
| 540 | 540 | |
| 541 | 541 | (defun map-chaos-op-to-trs (method trs) |
| 542 | 542 | (or (cadr (assq method (trs$op-info-map trs))) |
| 543 | 543 | (make-trs-op-name method (trs$module trs)) |
| 544 | 544 | (with-output-panic-message () |
| 545 | (format t "cound not map operator ~a" | |
| 546 | (method-symbol method)) | |
| 547 | (chaos-error 'panic)))) | |
| 545 | (format t "cound not map operator ~a" | |
| 546 | (method-symbol method)) | |
| 547 | (chaos-error 'panic)))) | |
| 548 | 548 | |
| 549 | 549 | (defun map-chaos-op-to-trs-info (method trs) |
| 550 | 550 | (cdr (assq method (trs$op-info-map trs)))) |
| 554 | 554 | (setq name (intern name))) |
| 555 | 555 | (or (cdr (assq name (trs$op-rev-table trs))) |
| 556 | 556 | (let* ((opnam (list (string name))) |
| 557 | (opref (parse-op-name opnam)) | |
| 558 | (opinfos (car (find-qual-operators opref (trs$module trs))))) | |
| 559 | (car (opinfo-methods opinfos))) | |
| 557 | (opref (parse-op-name opnam)) | |
| 558 | (opinfos (car (find-qual-operators opref (trs$module trs))))) | |
| 559 | (car (opinfo-methods opinfos))) | |
| 560 | 560 | (with-output-panic-message () |
| 561 | (format t "could not find reverse map of operator symbol ~a" | |
| 562 | name) | |
| 563 | (chaos-error 'panic)))) | |
| 561 | (format t "could not find reverse map of operator symbol ~a" | |
| 562 | name) | |
| 563 | (chaos-error 'panic)))) | |
| 564 | 564 | |
| 565 | 565 | ;;; |
| 566 | 566 | ;;; BUILTIN OPERATORS |
| 567 | 567 | ;;; |
| 568 | 568 | (defun find-trs-dummy-method (trs meth arity coarity) |
| 569 | 569 | (cdr (assoc (list meth arity coarity) |
| 570 | (trs$dummy-methods trs) | |
| 571 | :test #'equal))) | |
| 570 | (trs$dummy-methods trs) | |
| 571 | :test #'equal))) | |
| 572 | 572 | |
| 573 | 573 | (defun make-trs-dummy-method (trs meth arity coarity) |
| 574 | 574 | (or (find-trs-dummy-method trs meth arity coarity) |
| 575 | 575 | (with-in-module ((trs$module trs)) |
| 576 | (let* ((op (method-operator meth)) | |
| 577 | (new-meth (make-operator-method :name (operator-name op) | |
| 578 | :arity arity | |
| 579 | :coarity coarity))) | |
| 580 | (setf (method-constructor new-meth) | |
| 581 | (method-constructor meth)) | |
| 582 | (setf (method-is-behavioural new-meth) | |
| 583 | (method-is-behavioural meth)) | |
| 584 | (setf (method-module new-meth) | |
| 585 | *current-module*) | |
| 586 | (setf (method-supplied-strategy new-meth) | |
| 587 | (method-supplied-strategy meth)) | |
| 588 | (setf (method-precedence new-meth) | |
| 589 | (method-precedence meth)) | |
| 590 | (setf (method-associativity new-meth) | |
| 591 | (method-associativity meth)) | |
| 592 | (push (cons (list meth arity coarity) new-meth) | |
| 593 | (trs$dummy-methods trs)) | |
| 594 | ;; | |
| 595 | new-meth)))) | |
| 576 | (let* ((op (method-operator meth)) | |
| 577 | (new-meth (make-operator-method :name (operator-name op) | |
| 578 | :arity arity | |
| 579 | :coarity coarity))) | |
| 580 | (setf (method-constructor new-meth) | |
| 581 | (method-constructor meth)) | |
| 582 | (setf (method-is-behavioural new-meth) | |
| 583 | (method-is-behavioural meth)) | |
| 584 | (setf (method-module new-meth) | |
| 585 | *current-module*) | |
| 586 | (setf (method-supplied-strategy new-meth) | |
| 587 | (method-supplied-strategy meth)) | |
| 588 | (setf (method-precedence new-meth) | |
| 589 | (method-precedence meth)) | |
| 590 | (setf (method-associativity new-meth) | |
| 591 | (method-associativity meth)) | |
| 592 | (push (cons (list meth arity coarity) new-meth) | |
| 593 | (trs$dummy-methods trs)) | |
| 594 | ;; | |
| 595 | new-meth)))) | |
| 596 | 596 | |
| 597 | 597 | (defun make-trs-builtin-bin-op-info (trs meth arity coarity) |
| 598 | 598 | (let ((new-meth |
| 599 | (make-trs-dummy-method trs meth arity coarity))) | |
| 599 | (make-trs-dummy-method trs meth arity coarity))) | |
| 600 | 600 | ;; |
| 601 | 601 | (let ((info (make-trs-op-info meth trs)) |
| 602 | (r-arity (mapcar #'(lambda (x) | |
| 603 | (map-chaos-sort-to-trs-or-panic x trs)) | |
| 604 | arity)) | |
| 605 | (r-coarity (map-chaos-sort-to-trs-or-panic coarity trs))) | |
| 602 | (r-arity (mapcar #'(lambda (x) | |
| 603 | (map-chaos-sort-to-trs-or-panic x trs)) | |
| 604 | arity)) | |
| 605 | (r-coarity (map-chaos-sort-to-trs-or-panic coarity trs))) | |
| 606 | 606 | (setf (second info) r-arity |
| 607 | (third info) r-coarity) | |
| 607 | (third info) r-coarity) | |
| 608 | 608 | (cons new-meth info)))) |
| 609 | 609 | |
| 610 | 610 | (defun make-trs-if-then-else-info (trs sort) |
| 611 | 611 | (let ((new-meth (make-trs-dummy-method trs |
| 612 | *bool-if* | |
| 613 | (list *bool-sort* sort sort) | |
| 614 | sort)) | |
| 615 | (info (make-trs-op-info *bool-if* trs)) | |
| 616 | (bool (map-chaos-sort-to-trs-or-panic *bool-sort* trs)) | |
| 617 | (s (map-chaos-sort-to-trs-or-panic sort trs)) | |
| 618 | ) | |
| 612 | *bool-if* | |
| 613 | (list *bool-sort* sort sort) | |
| 614 | sort)) | |
| 615 | (info (make-trs-op-info *bool-if* trs)) | |
| 616 | (bool (map-chaos-sort-to-trs-or-panic *bool-sort* trs)) | |
| 617 | (s (map-chaos-sort-to-trs-or-panic sort trs)) | |
| 618 | ) | |
| 619 | 619 | (setf (second info) (list bool s s)) |
| 620 | 620 | (setf (third info) s) |
| 621 | 621 | (cons new-meth info))) |
| 622 | 622 | |
| 623 | 623 | (defun make-trs-if-then-else-axioms (trs sort) |
| 624 | 624 | (let* ((var-then (make-variable-term sort 'THEN)) |
| 625 | (var-else (make-variable-term sort 'ELSE)) | |
| 626 | (if-op (find-trs-dummy-method trs *bool-if* | |
| 627 | (list *bool-sort* sort sort) | |
| 628 | sort)) | |
| 629 | (lhs-1 (make-applform sort | |
| 630 | if-op | |
| 631 | (list *bool-true* var-then var-else))) | |
| 632 | (lhs-2 (make-applform sort | |
| 633 | if-op | |
| 634 | (list *bool-false* var-then var-else))) | |
| 635 | (rhs-1 var-then) | |
| 636 | (rhs-2 var-else)) | |
| 625 | (var-else (make-variable-term sort 'ELSE)) | |
| 626 | (if-op (find-trs-dummy-method trs *bool-if* | |
| 627 | (list *bool-sort* sort sort) | |
| 628 | sort)) | |
| 629 | (lhs-1 (make-applform sort | |
| 630 | if-op | |
| 631 | (list *bool-true* var-then var-else))) | |
| 632 | (lhs-2 (make-applform sort | |
| 633 | if-op | |
| 634 | (list *bool-false* var-then var-else))) | |
| 635 | (rhs-1 var-then) | |
| 636 | (rhs-2 var-else)) | |
| 637 | 637 | (list (make-rule :lhs lhs-1 :rhs rhs-1 :condition *bool-true* |
| 638 | :type :equation | |
| 639 | :no-method-computation t) | |
| 640 | (make-rule :lhs lhs-2 :rhs rhs-2 :condition *bool-true* | |
| 641 | :type :equation | |
| 642 | :no-method-computation t)) | |
| 638 | :type :equation | |
| 639 | :no-method-computation t) | |
| 640 | (make-rule :lhs lhs-2 :rhs rhs-2 :condition *bool-true* | |
| 641 | :type :equation | |
| 642 | :no-method-computation t)) | |
| 643 | 643 | )) |
| 644 | 644 | |
| 645 | 645 | (defun get-trs-top-sorts (trs) |
| 646 | 646 | (let ((top-sorts nil)) |
| 647 | 647 | (dolist (sort (maximal-sorts (trs$sorts trs) |
| 648 | (trs$sort-order trs))) | |
| 648 | (trs$sort-order trs))) | |
| 649 | 649 | (when (trs-proper-sort-p sort) |
| 650 | (push sort top-sorts))) | |
| 650 | (push sort top-sorts))) | |
| 651 | 651 | top-sorts)) |
| 652 | 652 | |
| 653 | 653 | (defun get-trs-error-sorts (trs) |
| 654 | 654 | (let ((error-sorts nil)) |
| 655 | 655 | (dolist (ent (trs$sort-name-map trs) error-sorts) |
| 656 | (when (err-sort-p (car ent)) | |
| 657 | (push (car ent) error-sorts))))) | |
| 656 | (when (err-sort-p (car ent)) | |
| 657 | (push (car ent) error-sorts))))) | |
| 658 | 658 | |
| 659 | 659 | (defun make-trs-biopinfos (trs sorts) |
| 660 | 660 | (let ((infos nil) |
| 661 | (axs nil)) | |
| 661 | (axs nil)) | |
| 662 | 662 | (dolist (sort sorts) |
| 663 | 663 | (if (sort-is-hidden sort) |
| 664 | (push (make-trs-builtin-bin-op-info trs *beh-equal* | |
| 665 | (list sort sort) | |
| 666 | *bool-sort*) | |
| 667 | infos) | |
| 668 | (progn | |
| 669 | ;; _==_ | |
| 670 | (push (make-trs-builtin-bin-op-info trs *bool-equal* | |
| 671 | (list sort sort) | |
| 672 | *bool-sort*) | |
| 673 | infos) | |
| 674 | ;; _=b=_ | |
| 675 | (when (sort-is-hidden sort) | |
| 676 | (push (make-trs-builtin-bin-op-info trs *beh-eq-pred* | |
| 677 | (list sort sort) | |
| 678 | *bool-sort*) | |
| 679 | infos)) | |
| 680 | ;; _=*=_ | |
| 681 | (when (sort-is-hidden sort) | |
| 682 | (push (make-trs-builtin-bin-op-info trs *beh-equal* | |
| 683 | (list sort sort) | |
| 684 | *bool-sort*) | |
| 685 | infos)) | |
| 686 | ;; _=/=_ | |
| 687 | (push (make-trs-builtin-bin-op-info trs *bool-nonequal* | |
| 688 | (list sort sort) | |
| 689 | *bool-sort*) | |
| 690 | infos))) | |
| 664 | (push (make-trs-builtin-bin-op-info trs *beh-equal* | |
| 665 | (list sort sort) | |
| 666 | *bool-sort*) | |
| 667 | infos) | |
| 668 | (progn | |
| 669 | ;; _==_ | |
| 670 | (push (make-trs-builtin-bin-op-info trs *bool-equal* | |
| 671 | (list sort sort) | |
| 672 | *bool-sort*) | |
| 673 | infos) | |
| 674 | ;; _=b=_ | |
| 675 | (when (sort-is-hidden sort) | |
| 676 | (push (make-trs-builtin-bin-op-info trs *beh-eq-pred* | |
| 677 | (list sort sort) | |
| 678 | *bool-sort*) | |
| 679 | infos)) | |
| 680 | ;; _=*=_ | |
| 681 | (when (sort-is-hidden sort) | |
| 682 | (push (make-trs-builtin-bin-op-info trs *beh-equal* | |
| 683 | (list sort sort) | |
| 684 | *bool-sort*) | |
| 685 | infos)) | |
| 686 | ;; _=/=_ | |
| 687 | (push (make-trs-builtin-bin-op-info trs *bool-nonequal* | |
| 688 | (list sort sort) | |
| 689 | *bool-sort*) | |
| 690 | infos))) | |
| 691 | 691 | ;; if_then_else_fi |
| 692 | 692 | (push (make-trs-if-then-else-info trs sort) |
| 693 | infos) | |
| 693 | infos) | |
| 694 | 694 | (push (make-trs-if-then-else-axioms trs sort) |
| 695 | axs) | |
| 695 | axs) | |
| 696 | 696 | ) |
| 697 | 697 | ;; |
| 698 | 698 | (values infos axs) |
| 700 | 700 | |
| 701 | 701 | (defun make-trs-builtin-op-maps (trs) |
| 702 | 702 | (let* ((mod (trs$module trs)) |
| 703 | (top-sorts nil) | |
| 704 | (rel-infos nil) | |
| 705 | (if-then-axs nil) | |
| 706 | ) | |
| 703 | (top-sorts nil) | |
| 704 | (rel-infos nil) | |
| 705 | (if-then-axs nil) | |
| 706 | ) | |
| 707 | 707 | ;; |
| 708 | 708 | (setq top-sorts (get-trs-top-sorts trs)) |
| 709 | 709 | ;; |
| 710 | 710 | (when (assq *truth-module* (module-all-submodules mod)) |
| 711 | 711 | (multiple-value-bind (infos axs) |
| 712 | (make-trs-biopinfos trs top-sorts) | |
| 713 | (setq rel-infos infos) | |
| 714 | (setq if-then-axs axs)) | |
| 712 | (make-trs-biopinfos trs top-sorts) | |
| 713 | (setq rel-infos infos) | |
| 714 | (setq if-then-axs axs)) | |
| 715 | 715 | ) |
| 716 | (when nil ; (or (eq *rwl-module* mod) | |
| 717 | ; (assq *rwl-module* (module-all-submodules mod))) | |
| 716 | (when nil ; (or (eq *rwl-module* mod) | |
| 717 | ; (assq *rwl-module* (module-all-submodules mod))) | |
| 718 | 718 | ;; _==>_ |
| 719 | 719 | (dolist (sort top-sorts) |
| 720 | (unless (sort-is-hidden sort) | |
| 721 | (push (make-trs-builtin-bin-op-info trs | |
| 722 | *rwl-predicate* | |
| 723 | (list sort sort) | |
| 724 | *bool-sort*) | |
| 725 | rel-infos) | |
| 726 | (push (make-trs-builtin-bin-op-info trs | |
| 727 | *rwl-predicate2* | |
| 728 | (list sort | |
| 729 | *rwl-nat-star-sort* | |
| 730 | sort) | |
| 731 | *bool-sort*) | |
| 732 | rel-infos) | |
| 733 | ))) | |
| 720 | (unless (sort-is-hidden sort) | |
| 721 | (push (make-trs-builtin-bin-op-info trs | |
| 722 | *rwl-predicate* | |
| 723 | (list sort sort) | |
| 724 | *bool-sort*) | |
| 725 | rel-infos) | |
| 726 | (push (make-trs-builtin-bin-op-info trs | |
| 727 | *rwl-predicate2* | |
| 728 | (list sort | |
| 729 | *rwl-nat-star-sort* | |
| 730 | sort) | |
| 731 | *bool-sort*) | |
| 732 | rel-infos) | |
| 733 | ))) | |
| 734 | 734 | ;; |
| 735 | 735 | (when *on-trs-debug* |
| 736 | 736 | (format t "~%sem-relations = ~A" rel-infos)) |
| 738 | 738 | (setf (trs$sem-relations trs) rel-infos) |
| 739 | 739 | (dolist (ax if-then-axs) |
| 740 | 740 | (let ((ax1 (car ax)) |
| 741 | (ax2 (cadr ax))) | |
| 742 | (push ax1 (trs$sem-axioms trs)) | |
| 743 | (push ax2 (trs$sem-axioms trs)))) | |
| 741 | (ax2 (cadr ax))) | |
| 742 | (push ax1 (trs$sem-axioms trs)) | |
| 743 | (push ax2 (trs$sem-axioms trs)))) | |
| 744 | 744 | )) |
| 745 | 745 | |
| 746 | 746 | ;;; ------ |
| 760 | 760 | |
| 761 | 761 | (defun trs-set-if-then-sort (res) |
| 762 | 762 | (if (and (eq :op (trs-term-type res)) |
| 763 | (null (trs-term-sort res)) | |
| 764 | (eq '|if_then_else_fi| (trs-term-head res))) | |
| 763 | (null (trs-term-sort res)) | |
| 764 | (eq '|if_then_else_fi| (trs-term-head res))) | |
| 765 | 765 | (let ((sort (trs-get-if-then-sort res))) |
| 766 | (setf (trs-term-sort res) sort) | |
| 767 | sort) | |
| 766 | (setf (trs-term-sort res) sort) | |
| 767 | sort) | |
| 768 | 768 | (trs-term-sort res))) |
| 769 | 769 | |
| 770 | 770 | (defun trs-get-if-then-sort (trs-term) |
| 771 | 771 | (let ((arg2 (second (trs-term-subterms trs-term))) |
| 772 | (sort nil)) | |
| 772 | (sort nil)) | |
| 773 | 773 | (setq sort (trs-term-sort arg2)) |
| 774 | 774 | (unless sort |
| 775 | 775 | (with-output-panic-message () |
| 776 | (format t "could not set sort for if-then-else-fi!") | |
| 777 | (break) | |
| 778 | (chaos-error 'panic))) | |
| 776 | (format t "could not set sort for if-then-else-fi!") | |
| 777 | (break) | |
| 778 | (chaos-error 'panic))) | |
| 779 | 779 | sort)) |
| 780 | 780 | |
| 781 | 781 | (defun trs$make-term-form* (term trs) |
| 782 | (cond ((term-is-simple-lisp-form? term) | |
| 783 | (list ':lisp (lisp-form-original-form term))) | |
| 784 | ((term-is-general-lisp-form? term) | |
| 785 | (list ':glisp (lisp-form-original-form term))) | |
| 786 | ((term-is-builtin-constant? term) | |
| 787 | (list :builtin-value | |
| 788 | (term-builtin-value term) | |
| 789 | (map-chaos-sort-to-trs (term-sort term) trs))) | |
| 790 | ((term-is-variable? term) | |
| 791 | (list :var (variable-name term) | |
| 792 | (map-chaos-sort-to-trs (variable-sort term) trs))) | |
| 793 | ((term-is-applform? term) | |
| 794 | (list* :op | |
| 795 | (map-chaos-op-to-trs (term-head term) trs) | |
| 796 | (map-chaos-sort-to-trs (term-sort term) trs) | |
| 797 | (mapcar #'(lambda (x) | |
| 798 | (trs$make-term-form x trs)) | |
| 799 | (term-subterms term)))) | |
| 800 | (t (with-output-panic-message () | |
| 801 | (format t "unknown term : ") | |
| 802 | (term-print term))))) | |
| 782 | (cond ((term-is-simple-lisp-form? term) | |
| 783 | (list ':lisp (lisp-form-original-form term))) | |
| 784 | ((term-is-general-lisp-form? term) | |
| 785 | (list ':glisp (lisp-form-original-form term))) | |
| 786 | ((term-is-builtin-constant? term) | |
| 787 | (list :builtin-value | |
| 788 | (term-builtin-value term) | |
| 789 | (map-chaos-sort-to-trs (term-sort term) trs))) | |
| 790 | ((term-is-variable? term) | |
| 791 | (list :var (variable-name term) | |
| 792 | (map-chaos-sort-to-trs (variable-sort term) trs))) | |
| 793 | ((term-is-applform? term) | |
| 794 | (list* :op | |
| 795 | (map-chaos-op-to-trs (term-head term) trs) | |
| 796 | (map-chaos-sort-to-trs (term-sort term) trs) | |
| 797 | (mapcar #'(lambda (x) | |
| 798 | (trs$make-term-form x trs)) | |
| 799 | (term-subterms term)))) | |
| 800 | (t (with-output-panic-message () | |
| 801 | (format t "unknown term : ") | |
| 802 | (term-print term))))) | |
| 803 | 803 | |
| 804 | 804 | (defun trs-term-variables (term) |
| 805 | 805 | (case (trs-term-type term) |
| 806 | 806 | (:var (list term)) |
| 807 | 807 | (:op (let ((res nil)) |
| 808 | (dolist (st (trs-term-subterms term) res) | |
| 809 | (setq res (union res (trs-term-variables st) | |
| 810 | :test #'equal))))) | |
| 808 | (dolist (st (trs-term-subterms term) res) | |
| 809 | (setq res (union res (trs-term-variables st) | |
| 810 | :test #'equal))))) | |
| 811 | 811 | (otherwise nil))) |
| 812 | 812 | |
| 813 | 813 | (defun trs-re-make-term-form (trs trs-term) |
| 814 | 814 | (with-in-module ((trs$module trs)) |
| 815 | 815 | (with-output-to-string (str) |
| 816 | 816 | (let ((*standard-output* str)) |
| 817 | (re-print-trs-term trs trs-term parser-max-precedence) | |
| 818 | str)))) | |
| 817 | (re-print-trs-term trs trs-term parser-max-precedence) | |
| 818 | str)))) | |
| 819 | 819 | |
| 820 | 820 | (defun re-print-trs-term (trs trs-term prec) |
| 821 | 821 | (declare (type fixnum prec)) |
| 822 | 822 | (case (trs-term-type trs-term) |
| 823 | 823 | (:var (princ (string (trs-term-head trs-term)))) |
| 824 | 824 | (:op (let ((op-name (trs-term-head trs-term))) |
| 825 | (let ((hd (trs-rev-op-name op-name trs)) | |
| 826 | (op nil)) | |
| 827 | (setq op (method-operator hd)) | |
| 828 | (cond ((not (operator-is-mixfix op)) | |
| 829 | (let ((subs (trs-term-subterms trs-term))) | |
| 830 | (format t "~{~a~^ ~}" (operator-symbol op)) | |
| 831 | (when subs | |
| 832 | (princ "(") | |
| 833 | (let ((flg nil)) | |
| 834 | (dolist (i subs) | |
| 835 | (if flg (princ ",") (setq flg t)) | |
| 836 | (re-print-trs-term trs i parser-max-precedence) | |
| 837 | )) | |
| 838 | (princ ")")))) | |
| 839 | (t (let ((prec-test (and (get-method-precedence hd) | |
| 840 | (<= prec | |
| 841 | (get-method-precedence hd)))) | |
| 842 | (assoc-test (method-is-associative hd))) | |
| 843 | (when prec-test (princ "(")) | |
| 844 | (let ((subs (trs-term-subterms trs-term)) | |
| 845 | (prv nil)) | |
| 846 | (dolist (i (operator-token-sequence op)) | |
| 847 | (cond | |
| 848 | ((eq i t) | |
| 849 | (when prv (princ " ")) | |
| 850 | (setq prv t) | |
| 851 | (let ((tm (car subs))) | |
| 852 | (re-print-trs-term | |
| 853 | trs | |
| 854 | tm | |
| 855 | (if (and assoc-test | |
| 856 | tm | |
| 857 | (eq :op (trs-term-type tm)) | |
| 858 | (eq (trs-term-head tm) | |
| 859 | (trs-term-head trs-term))) | |
| 860 | parser-max-precedence | |
| 861 | (or (get-method-precedence hd) | |
| 862 | 0))) | |
| 863 | (setq subs (cdr subs)))) | |
| 864 | (t (when prv (princ " ")) | |
| 865 | (setq prv t) | |
| 866 | (princ i))))) | |
| 867 | (when prec-test (princ ")")) | |
| 868 | )))))) | |
| 825 | (let ((hd (trs-rev-op-name op-name trs)) | |
| 826 | (op nil)) | |
| 827 | (setq op (method-operator hd)) | |
| 828 | (cond ((not (operator-is-mixfix op)) | |
| 829 | (let ((subs (trs-term-subterms trs-term))) | |
| 830 | (format t "~{~a~^ ~}" (operator-symbol op)) | |
| 831 | (when subs | |
| 832 | (princ "(") | |
| 833 | (let ((flg nil)) | |
| 834 | (dolist (i subs) | |
| 835 | (if flg (princ ",") (setq flg t)) | |
| 836 | (re-print-trs-term trs i parser-max-precedence) | |
| 837 | )) | |
| 838 | (princ ")")))) | |
| 839 | (t (let ((prec-test (and (get-method-precedence hd) | |
| 840 | (<= prec | |
| 841 | (get-method-precedence hd)))) | |
| 842 | (assoc-test (method-is-associative hd))) | |
| 843 | (when prec-test (princ "(")) | |
| 844 | (let ((subs (trs-term-subterms trs-term)) | |
| 845 | (prv nil)) | |
| 846 | (dolist (i (operator-token-sequence op)) | |
| 847 | (cond | |
| 848 | ((eq i t) | |
| 849 | (when prv (princ " ")) | |
| 850 | (setq prv t) | |
| 851 | (let ((tm (car subs))) | |
| 852 | (re-print-trs-term | |
| 853 | trs | |
| 854 | tm | |
| 855 | (if (and assoc-test | |
| 856 | tm | |
| 857 | (eq :op (trs-term-type tm)) | |
| 858 | (eq (trs-term-head tm) | |
| 859 | (trs-term-head trs-term))) | |
| 860 | parser-max-precedence | |
| 861 | (or (get-method-precedence hd) | |
| 862 | 0))) | |
| 863 | (setq subs (cdr subs)))) | |
| 864 | (t (when prv (princ " ")) | |
| 865 | (setq prv t) | |
| 866 | (princ i))))) | |
| 867 | (when prec-test (princ ")")) | |
| 868 | )))))) | |
| 869 | 869 | (:builtin-value (princ (trs-term-head trs-term))) |
| 870 | 870 | (otherwise (format t "!! not supported (~a)" trs-term))) |
| 871 | 871 | ) |
| 878 | 878 | (defun make-trs-axioms (trs) |
| 879 | 879 | (let ((mod (trs$module trs))) |
| 880 | 880 | (let ((own-axs (module-own-axioms-ordered mod nil)) |
| 881 | (imp-axs (module-imported-axioms mod nil)) | |
| 882 | (eqns nil) | |
| 883 | (trns nil) | |
| 884 | (val nil)) | |
| 881 | (imp-axs (module-imported-axioms mod nil)) | |
| 882 | (eqns nil) | |
| 883 | (trns nil) | |
| 884 | (val nil)) | |
| 885 | 885 | (setq val (trs$get-axioms own-axs trs)) |
| 886 | 886 | (setq eqns (car val) |
| 887 | trns (cadr val)) | |
| 887 | trns (cadr val)) | |
| 888 | 888 | (setq val (trs$get-axioms imp-axs trs)) |
| 889 | 889 | (setf (trs$eqns trs) (nconc eqns (car val))) |
| 890 | 890 | (setf (trs$trns trs) (nconc trns (cadr val)))))) |
| 892 | 892 | |
| 893 | 893 | (defun trs$get-axioms (axs trs &optional include-bad-rule) |
| 894 | 894 | (let ((eqs nil) |
| 895 | (trns nil) | |
| 896 | (tinfo nil)) | |
| 895 | (trns nil) | |
| 896 | (tinfo nil)) | |
| 897 | 897 | (dolist (ax axs (list eqs trns)) |
| 898 | 898 | (let ((lhs-top (term-head (axiom-lhs ax)))) |
| 899 | (unless (or (eq lhs-top *bool-if*) | |
| 900 | (eq lhs-top *bool-equal*) | |
| 901 | (eq lhs-top *beh-eq-pred*) | |
| 902 | (eq lhs-top *bool-nonequal*) | |
| 903 | ;; (eq lhs-top *rwl-predicate*) | |
| 904 | ) | |
| 905 | (setq tinfo (get-trs-axiom ax trs include-bad-rule)) | |
| 906 | (if (memq (axiom-type ax) '(:equation :pignose-axiom :pignose-goal)) | |
| 907 | (push tinfo eqs) | |
| 908 | (push tinfo trns))))) | |
| 899 | (unless (or (eq lhs-top *bool-if*) | |
| 900 | (eq lhs-top *bool-equal*) | |
| 901 | (eq lhs-top *beh-eq-pred*) | |
| 902 | (eq lhs-top *bool-nonequal*) | |
| 903 | ;; (eq lhs-top *rwl-predicate*) | |
| 904 | ) | |
| 905 | (setq tinfo (get-trs-axiom ax trs include-bad-rule)) | |
| 906 | (if (memq (axiom-type ax) '(:equation :pignose-axiom :pignose-goal)) | |
| 907 | (push tinfo eqs) | |
| 908 | (push tinfo trns))))) | |
| 909 | 909 | )) |
| 910 | 910 | |
| 911 | 911 | (defun get-trs-axiom (ax trs &optional include-bad-rule) |
| 912 | 912 | (let* ((lhs (axiom-lhs ax)) |
| 913 | (rhs (axiom-rhs ax)) | |
| 914 | (cond (axiom-condition ax)) | |
| 915 | (condp (not (is-true? cond))) | |
| 916 | (type (axiom-type ax)) | |
| 917 | (behavioural (axiom-is-behavioural ax)) | |
| 918 | (kind (axiom-kind ax)) | |
| 919 | (label (axiom-labels ax))) | |
| 913 | (rhs (axiom-rhs ax)) | |
| 914 | (cond (axiom-condition ax)) | |
| 915 | (condp (not (is-true? cond))) | |
| 916 | (type (axiom-type ax)) | |
| 917 | (behavioural (axiom-is-behavioural ax)) | |
| 918 | (kind (axiom-kind ax)) | |
| 919 | (label (axiom-labels ax))) | |
| 920 | 920 | (when (eq kind :bad-rule) |
| 921 | 921 | (unless include-bad-rule |
| 922 | (return-from get-trs-axiom nil))) | |
| 922 | (return-from get-trs-axiom nil))) | |
| 923 | 923 | (list* (case type |
| 924 | ((:equation :pignose-axiom :pignose-goal) | |
| 925 | (cond (behavioural | |
| 926 | (cond (condp :bceq) | |
| 927 | (t :beq))) | |
| 928 | (t (cond (condp :ceq) | |
| 929 | (t :eq))))) | |
| 930 | (t (cond (behavioural | |
| 931 | (cond (condp :bctrans) | |
| 932 | (t :btrans))) | |
| 933 | (t (cond (condp :ctrans) | |
| 934 | (t :trans)))))) | |
| 935 | (if label | |
| 936 | (string (car label)) | |
| 937 | nil) | |
| 938 | (trs$make-term-form lhs trs) | |
| 939 | (trs$make-term-form rhs trs) | |
| 940 | (if condp | |
| 941 | (list (trs$make-term-form cond trs)) | |
| 942 | nil)))) | |
| 924 | ((:equation :pignose-axiom :pignose-goal) | |
| 925 | (cond (behavioural | |
| 926 | (cond (condp :bceq) | |
| 927 | (t :beq))) | |
| 928 | (t (cond (condp :ceq) | |
| 929 | (t :eq))))) | |
| 930 | (t (cond (behavioural | |
| 931 | (cond (condp :bctrans) | |
| 932 | (t :btrans))) | |
| 933 | (t (cond (condp :ctrans) | |
| 934 | (t :trans)))))) | |
| 935 | (if label | |
| 936 | (string (car label)) | |
| 937 | nil) | |
| 938 | (trs$make-term-form lhs trs) | |
| 939 | (trs$make-term-form rhs trs) | |
| 940 | (if condp | |
| 941 | (list (trs$make-term-form cond trs)) | |
| 942 | nil)))) | |
| 943 | 943 | |
| 944 | 944 | (defmacro trs-axiom-type (ax) `(car ,ax)) |
| 945 | 945 | (defmacro trs-axiom-label (ax) `(cadr ,ax)) |
| 0 | 0 | ;;;-*- Mode:LISP; Package:CHAOS; Base:10; Syntax:Common-lisp -*- |
| 1 | 1 | ;;; |
| 2 | ;;; Copyright (c) 2000-2014, Toshimi Sawada. All rights reserved. | |
| 2 | ;;; Copyright (c) 2000-2015, Toshimi Sawada. All rights reserved. | |
| 3 | 3 | ;;; |
| 4 | 4 | ;;; Redistribution and use in source and binary forms, with or without |
| 5 | 5 | ;;; modification, are permitted provided that the following conditions |
| 27 | 27 | ;;; |
| 28 | 28 | (in-package :chaos) |
| 29 | 29 | #|============================================================================== |
| 30 | System: Chaos | |
| 31 | Module: construct | |
| 32 | File: variable.lisp | |
| 30 | System: Chaos | |
| 31 | Module: construct | |
| 32 | File: variable.lisp | |
| 33 | 33 | ==============================================================================|# |
| 34 | 34 | #-:chaos-debug |
| 35 | 35 | (declaim (optimize (speed 3) (safety 0) #-GCL (debug 0))) |
| 43 | 43 | (let ((sorts (module-all-sorts module))) |
| 44 | 44 | (dolist (bi sorts) |
| 45 | 45 | (when (and (sort-is-builtin bi) (not (sort= *id-sort* bi))) |
| 46 | (let ((token-pred (bsort-token-predicate bi))) | |
| 47 | (when (and token-pred | |
| 48 | (funcall token-pred var-name) | |
| 49 | (is-in-same-connected-component* sort | |
| 50 | bi | |
| 51 | (module-sort-order module))) | |
| 52 | (return-from check-var-name-overloading-with-builtin bi) | |
| 53 | )))) | |
| 46 | (let ((token-pred (bsort-token-predicate bi))) | |
| 47 | (when (and token-pred | |
| 48 | (funcall token-pred var-name) | |
| 49 | (is-in-same-connected-component* sort | |
| 50 | bi | |
| 51 | (module-sort-order module))) | |
| 52 | (return-from check-var-name-overloading-with-builtin bi) | |
| 53 | )))) | |
| 54 | 54 | nil)) |
| 55 | 55 | |
| 56 | 56 | (defun declare-variable-in-module (var-name sort-ref |
| 57 | &optional (module *current-module*)) | |
| 57 | &optional (module *current-module*)) | |
| 58 | 58 | |
| 59 | 59 | #|| |
| 60 | 60 | (when (and (consp var-name) |
| 61 | (eq (car var-name) '|String|)) | |
| 61 | (eq (car var-name) '|String|)) | |
| 62 | 62 | ;; (setq var-name (format nil "\"~s\"" (cadr var-name))) |
| 63 | 63 | (setq var-name (cadr var-name)) |
| 64 | 64 | ) |
| 65 | 65 | ||# |
| 66 | 66 | (let ((mod (if (module-p module) |
| 67 | module | |
| 68 | (find-module-in-env module)))) | |
| 67 | module | |
| 68 | (find-module-in-env module)))) | |
| 69 | 69 | (unless mod |
| 70 | 70 | (with-output-panic-message () |
| 71 | (princ "internal error, no such module ") | |
| 72 | (print-mod-name module) | |
| 73 | (princ ", variable declaration for ") | |
| 74 | (princ var-name) | |
| 75 | (princ " failed.") | |
| 76 | (chaos-error 'no-such-module))) | |
| 71 | (princ "internal error, no such module ") | |
| 72 | (print-mod-name module) | |
| 73 | (princ ", variable declaration for ") | |
| 74 | (princ var-name) | |
| 75 | (princ " failed.") | |
| 76 | (chaos-error 'no-such-module))) | |
| 77 | 77 | |
| 78 | 78 | (let ((sort (if (sort-struct-p sort-ref) sort-ref |
| 79 | (find-sort-in mod sort-ref)))) | |
| 79 | (find-sort-in mod sort-ref)))) | |
| 80 | 80 | (unless sort |
| 81 | (with-output-chaos-error ('no-such-sort) | |
| 82 | (princ "could not find sort ") | |
| 83 | (princ sort-ref) | |
| 84 | (princ ", variable declaration for ") | |
| 85 | (princ var-name) | |
| 86 | (princ " is ignored.") | |
| 87 | )) | |
| 81 | (with-output-chaos-error ('no-such-sort) | |
| 82 | (princ "could not find sort ") | |
| 83 | (princ sort-ref) | |
| 84 | (princ ", variable declaration for ") | |
| 85 | (princ var-name) | |
| 86 | (princ " is ignored.") | |
| 87 | )) | |
| 88 | 88 | ;; check name --- |
| 89 | 89 | (cond ((stringp var-name) |
| 90 | ;; name conflict check with builtin constants | |
| 91 | (let ((bi (check-var-name-overloading-with-builtin var-name sort module))) | |
| 92 | (when bi | |
| 93 | (with-output-chaos-warning () | |
| 94 | (format t "variable name ~s is conflicting with built-in constant of sort " var-name) | |
| 95 | (print-sort-name bi module) | |
| 96 | (print-next) | |
| 97 | (princ "... ignored.")) | |
| 98 | (return-from declare-variable-in-module nil))) | |
| 99 | #|| | |
| 100 | (let ((ops nil)) | |
| 101 | ;; name conflict check with existing op | |
| 102 | (setq ops (find-all-qual-operators-in module var-name 0)) | |
| 103 | (when ops | |
| 104 | (with-output-chaos-warning () | |
| 105 | (format t "declaring variable ~s:" var-name) | |
| 106 | (print-next) | |
| 107 | (format t " there already is an constant operator with the same name.") | |
| 108 | (print-next) | |
| 109 | (princ "... ignoring") | |
| 110 | (return-from declare-variable-in-module nil) | |
| 111 | )) | |
| 112 | ) | |
| 113 | ||# | |
| 114 | ;; check name -- | |
| 115 | (when (eql #\` (char var-name 0)) | |
| 116 | (with-output-chaos-error ('invalid-var-decl) | |
| 117 | (format t "variable name must not start with \"`\",") | |
| 118 | (print-next) | |
| 119 | (princ "'`' is reserved for the prefix of pseudo variables declared on the fly.") | |
| 120 | )) | |
| 121 | ;; name must be begin with | |
| 122 | (setf var-name (intern var-name))) | |
| 123 | (t (unless (symbolp var-name) | |
| 124 | (with-output-chaos-error ('invalid-variable-name) | |
| 125 | (princ "invalid variable name ") | |
| 126 | (princ var-name) | |
| 127 | (chaos-error 'invalid-var-decl)))) | |
| 128 | ) | |
| 90 | ;; name conflict check with builtin constants | |
| 91 | (let ((bi (check-var-name-overloading-with-builtin var-name sort module))) | |
| 92 | (when bi | |
| 93 | (with-output-chaos-warning () | |
| 94 | (format t "variable name ~s is conflicting with built-in constant of sort " var-name) | |
| 95 | (print-sort-name bi module) | |
| 96 | (print-next) | |
| 97 | (princ "... ignored.")) | |
| 98 | (return-from declare-variable-in-module nil))) | |
| 99 | #|| | |
| 100 | (let ((ops nil)) | |
| 101 | ;; name conflict check with existing op | |
| 102 | (setq ops (find-all-qual-operators-in module var-name 0)) | |
| 103 | (when ops | |
| 104 | (with-output-chaos-warning () | |
| 105 | (format t "declaring variable ~s:" var-name) | |
| 106 | (print-next) | |
| 107 | (format t " there already is an constant operator with the same name.") | |
| 108 | (print-next) | |
| 109 | (princ "... ignoring") | |
| 110 | (return-from declare-variable-in-module nil) | |
| 111 | )) | |
| 112 | ) | |
| 113 | ||# | |
| 114 | ;; check name -- | |
| 115 | (when (eql #\` (char var-name 0)) | |
| 116 | (with-output-chaos-error ('invalid-var-decl) | |
| 117 | (format t "variable name must not start with \"`\",") | |
| 118 | (print-next) | |
| 119 | (princ "'`' is reserved for the prefix of pseudo variables declared on the fly.") | |
| 120 | )) | |
| 121 | ;; name must be begin with | |
| 122 | (setf var-name (intern var-name))) | |
| 123 | (t (unless (symbolp var-name) | |
| 124 | (with-output-chaos-error ('invalid-variable-name) | |
| 125 | (princ "invalid variable name ") | |
| 126 | (princ var-name) | |
| 127 | (chaos-error 'invalid-var-decl)))) | |
| 128 | ) | |
| 129 | 129 | ;; |
| 130 | 130 | (let ((old (assoc var-name (module-variables mod))) |
| 131 | var) | |
| 132 | #|| | |
| 133 | (when (and old (sort= sort (variable-sort (cdr old)))) | |
| 134 | (return-from declare-variable-in-module (cdr old))) | |
| 135 | ||# | |
| 136 | (when old | |
| 137 | (with-output-chaos-warning () | |
| 138 | (princ "variable ") | |
| 139 | (princ (string var-name)) | |
| 140 | (princ " is already declared as sort ") | |
| 141 | (princ (string (sort-id (variable-sort (cdr old))))) | |
| 142 | #|| | |
| 143 | (princ ", but redefined as sort ") | |
| 144 | (princ (string (sort-id sort))) | |
| 145 | ||# | |
| 146 | (princ ", ignored.") | |
| 147 | (return-from declare-variable-in-module nil) | |
| 148 | )) | |
| 149 | (setf var (make-variable-term sort var-name)) | |
| 150 | (push (cons var-name var) (module-variables mod)) | |
| 151 | ;; | |
| 152 | (symbol-table-add (module-symbol-table mod) | |
| 153 | var-name | |
| 154 | var) | |
| 155 | ;; | |
| 156 | var)))) | |
| 131 | var) | |
| 132 | #|| | |
| 133 | (when (and old (sort= sort (variable-sort (cdr old)))) | |
| 134 | (return-from declare-variable-in-module (cdr old))) | |
| 135 | ||# | |
| 136 | (when old | |
| 137 | (with-output-chaos-warning () | |
| 138 | (princ "variable ") | |
| 139 | (princ (string var-name)) | |
| 140 | (princ " is already declared as sort ") | |
| 141 | (princ (string (sort-id (variable-sort (cdr old))))) | |
| 142 | #|| | |
| 143 | (princ ", but redefined as sort ") | |
| 144 | (princ (string (sort-id sort))) | |
| 145 | ||# | |
| 146 | (princ ", ignored.") | |
| 147 | (return-from declare-variable-in-module nil) | |
| 148 | )) | |
| 149 | (setf var (make-variable-term sort var-name)) | |
| 150 | (push (cons var-name var) (module-variables mod)) | |
| 151 | ;; | |
| 152 | (symbol-table-add (module-symbol-table mod) | |
| 153 | var-name | |
| 154 | var) | |
| 155 | ;; | |
| 156 | var)))) | |
| 157 | 157 | |
| 158 | 158 | (defun declare-pvariable-in-module (var-name sort-ref |
| 159 | &optional (module *current-module*)) | |
| 159 | &optional (module *current-module*)) | |
| 160 | 160 | (let ((mod (if (module-p module) |
| 161 | module | |
| 162 | (find-module-in-env module)))) | |
| 161 | module | |
| 162 | (find-module-in-env module)))) | |
| 163 | 163 | (unless mod |
| 164 | 164 | (with-output-panic-message () |
| 165 | (princ "internal error, no such module ") | |
| 166 | (print-mod-name module) | |
| 167 | (princ ", pseud constant declaration for ") | |
| 168 | (princ var-name) | |
| 169 | (princ " failed.") | |
| 170 | (chaos-error 'no-such-module))) | |
| 165 | (princ "internal error, no such module ") | |
| 166 | (print-mod-name module) | |
| 167 | (princ ", pseud constant declaration for ") | |
| 168 | (princ var-name) | |
| 169 | (princ " failed.") | |
| 170 | (chaos-error 'no-such-module))) | |
| 171 | 171 | |
| 172 | 172 | (let ((sort (if (sort-struct-p sort-ref) sort-ref |
| 173 | (find-sort-in mod sort-ref)))) | |
| 173 | (find-sort-in mod sort-ref)))) | |
| 174 | 174 | (unless sort |
| 175 | (with-output-chaos-error ('no-such-sort) | |
| 176 | (princ "could not find sort ") | |
| 177 | (princ sort-ref) | |
| 178 | (princ ", pseud constant declaration for ") | |
| 179 | (princ var-name) | |
| 180 | (princ " is ignored.") | |
| 181 | )) | |
| 175 | (with-output-chaos-error ('no-such-sort) | |
| 176 | (princ "could not find sort ") | |
| 177 | (princ sort-ref) | |
| 178 | (princ ", pseud constant declaration for ") | |
| 179 | (princ var-name) | |
| 180 | (princ " is ignored.") | |
| 181 | )) | |
| 182 | 182 | |
| 183 | 183 | #|| |
| 184 | 184 | ;; check name -- |
| 185 | 185 | (when (eql #\` (char (the simple-string (string var-name)) 0)) |
| 186 | (with-output-chaos-error ('invalid-var-decl) | |
| 187 | (format t "variable name must not start with \"`\",") | |
| 188 | (print-next) | |
| 189 | (princ "this is reserved for pseud variables declared on the fly.") | |
| 190 | )) | |
| 186 | (with-output-chaos-error ('invalid-var-decl) | |
| 187 | (format t "variable name must not start with \"`\",") | |
| 188 | (print-next) | |
| 189 | (princ "this is reserved for pseud variables declared on the fly.") | |
| 190 | )) | |
| 191 | 191 | ||# |
| 192 | 192 | ;; |
| 193 | 193 | (if (stringp var-name) |
| 194 | (setf var-name (intern var-name)) | |
| 195 | (unless (symbolp var-name) | |
| 196 | (with-output-panic-message () | |
| 197 | (princ "internal error: invalid pconstant name ") | |
| 198 | (princ var-name) | |
| 199 | (chaos-error 'invalid-var-decl)))) | |
| 194 | (setf var-name (intern var-name)) | |
| 195 | (unless (symbolp var-name) | |
| 196 | (with-output-panic-message () | |
| 197 | (princ "internal error: invalid pconstant name ") | |
| 198 | (princ var-name) | |
| 199 | (chaos-error 'invalid-var-decl)))) | |
| 200 | 200 | |
| 201 | 201 | (let ((old (assoc var-name (module-variables mod))) |
| 202 | var) | |
| 203 | (when (and old (sort= sort (variable-sort (cdr old)))) | |
| 204 | (return-from declare-pvariable-in-module (cdr old))) | |
| 205 | (when old | |
| 206 | (with-output-chaos-warning () | |
| 207 | (princ "pseud constant ") | |
| 208 | (princ (string var-name)) | |
| 209 | (princ " once declared as sort ") | |
| 210 | (princ (string (sort-id (variable-sort (cdr old))))) | |
| 211 | (princ ", but re-declared as sort ") | |
| 212 | (princ (string (sort-id sort))) | |
| 213 | (princ ", ignored.") | |
| 214 | (return-from declare-pvariable-in-module nil) | |
| 215 | )) | |
| 216 | (setf var (make-pvariable-term sort var-name)) | |
| 217 | (push (cons var-name var) (module-variables mod)) | |
| 218 | ;; | |
| 219 | (symbol-table-add (module-symbol-table mod) | |
| 220 | var-name | |
| 221 | var) | |
| 222 | ;; | |
| 223 | var)))) | |
| 202 | var) | |
| 203 | (when (and old (sort= sort (variable-sort (cdr old)))) | |
| 204 | (return-from declare-pvariable-in-module (cdr old))) | |
| 205 | (when old | |
| 206 | (with-output-chaos-warning () | |
| 207 | (princ "pseud constant ") | |
| 208 | (princ (string var-name)) | |
| 209 | (princ " once declared as sort ") | |
| 210 | (princ (string (sort-id (variable-sort (cdr old))))) | |
| 211 | (princ ", but re-declared as sort ") | |
| 212 | (princ (string (sort-id sort))) | |
| 213 | (princ ", ignored.") | |
| 214 | (return-from declare-pvariable-in-module nil) | |
| 215 | )) | |
| 216 | (setf var (make-pvariable-term sort var-name)) | |
| 217 | (push (cons var-name var) (module-variables mod)) | |
| 218 | ;; | |
| 219 | (symbol-table-add (module-symbol-table mod) | |
| 220 | var-name | |
| 221 | var) | |
| 222 | ;; | |
| 223 | var)))) | |
| 224 | 224 | |
| 225 | 225 | ;;; |
| 226 | 226 | ;;; DECLARE-ERROR-VARIABLES-IN |
| 0 | 0 | ;;;-*- Mode:LISP; Package:CHAOS; Base:10; Syntax:Common-lisp -*- |
| 1 | 1 | ;;; |
| 2 | ;;; Copyright (c) 2000-2014, Toshimi Sawada. All rights reserved. | |
| 2 | ;;; Copyright (c) 2000-2015, Toshimi Sawada. All rights reserved. | |
| 3 | 3 | ;;; |
| 4 | 4 | ;;; Redistribution and use in source and binary forms, with or without |
| 5 | 5 | ;;; modification, are permitted provided that the following conditions |
| 27 | 27 | ;;; |
| 28 | 28 | (in-package :chaos) |
| 29 | 29 | #|============================================================================== |
| 30 | System: CHAOS | |
| 31 | Module: deCafe | |
| 32 | File: dgram.lisp | |
| 30 | System: CHAOS | |
| 31 | Module: deCafe | |
| 32 | File: dgram.lisp | |
| 33 | 33 | ==============================================================================|# |
| 34 | 34 | #-:chaos-debug |
| 35 | 35 | (declaim (optimize (speed 3) (safety 0) #-GCL (debug 0))) |
| 0 | 0 | ;;;-*- Mode:LISP; Package:CHAOS; Base:10; Syntax:Common-lisp -*- |
| 1 | 1 | ;;; |
| 2 | ;;; Copyright (c) 2000-2014, Toshimi Sawada. All rights reserved. | |
| 2 | ;;; Copyright (c) 2000-2015, Toshimi Sawada. All rights reserved. | |
| 3 | 3 | ;;; |
| 4 | 4 | ;;; Redistribution and use in source and binary forms, with or without |
| 5 | 5 | ;;; modification, are permitted provided that the following conditions |
| 27 | 27 | ;;; |
| 28 | 28 | (in-package :chaos) |
| 29 | 29 | #|============================================================================== |
| 30 | System: CHAOS | |
| 31 | Module: deCafe | |
| 32 | File: meval.lisp | |
| 33 | ||
| 34 | -- based on the implemetation of OBJ3. | |
| 30 | System: CHAOS | |
| 31 | Module: deCafe | |
| 32 | File: meval.lisp | |
| 33 | ||
| 34 | -- based on the implemetation of OBJ3. | |
| 35 | 35 | ==============================================================================|# |
| 36 | 36 | #-:chaos-debug |
| 37 | 37 | (declaim (optimize (speed 3) (safety 0) #-GCL (debug 0))) |
| 61 | 61 | (defun eval-modexp+ (modexp) |
| 62 | 62 | (let ((mod (eval-modexp modexp t nil))) |
| 63 | 63 | (if (modexp-is-error mod) |
| 64 | nil | |
| 64 | nil | |
| 65 | 65 | mod))) |
| 66 | 66 | |
| 67 | 67 | (defun eval-modexp (modexp &optional also-local (reconstruct-if-need t)) |
| 69 | 69 | (when (module-p modexp) |
| 70 | 70 | (return-from eval-modexp |
| 71 | 71 | (if reconstruct-if-need |
| 72 | (reconstruct-module-if-need modexp) | |
| 73 | modexp))) | |
| 72 | (reconstruct-module-if-need modexp) | |
| 73 | modexp))) | |
| 74 | 74 | (let ((mod nil) |
| 75 | (me (normalize-modexp modexp))) | |
| 76 | (when (and (equal me "THE-LAST-MODULE") | |
| 77 | *last-module*) | |
| 78 | (return-from eval-modexp | |
| 79 | (if reconstruct-if-need | |
| 80 | (reconstruct-module-if-need *last-module*) | |
| 81 | *last-module*))) | |
| 75 | (me (normalize-modexp modexp))) | |
| 76 | ;; "." -> current context module | |
| 82 | 77 | (when (and (equal me ".") |
| 83 | *current-module*) | |
| 84 | (return-from eval-modexp | |
| 85 | *current-module*)) | |
| 78 | (get-context-module t)) | |
| 79 | (return-from eval-modexp (get-context-module t))) | |
| 86 | 80 | (when (stringp me) |
| 81 | ;; simple name | |
| 87 | 82 | (let ((pos (position #\. (the simple-string me) :from-end t))) |
| 88 | (if pos | |
| 89 | (let ((name (subseq (the simple-string me) 0 (the fixnum pos))) | |
| 90 | (qual (subseq (the simple-string me) (1+ (the fixnum pos)))) | |
| 91 | (context nil)) | |
| 92 | ;; the context can itself be a local module | |
| 93 | (setf context (eval-modexp qual t)) | |
| 94 | (if (modexp-is-error context) | |
| 95 | (with-output-chaos-error ('no-such-module) | |
| 96 | (format t "Could not evaluate modexpr ~a, " me) | |
| 97 | (format t " no such module ~a" qual) | |
| 98 | ) | |
| 99 | (setf mod (find-module-in-env name context)))) | |
| 100 | (setq mod (find-module-in-env me (if also-local | |
| 101 | *current-module* | |
| 102 | nil)))))) | |
| 83 | (if pos | |
| 84 | (let ((name (subseq (the simple-string me) 0 (the fixnum pos))) | |
| 85 | (qual (subseq (the simple-string me) (1+ (the fixnum pos)))) | |
| 86 | (context nil)) | |
| 87 | ;; the context can itself be a local module | |
| 88 | (setf context (eval-modexp qual t)) | |
| 89 | (if (modexp-is-error context) | |
| 90 | (with-output-chaos-error ('no-such-module) | |
| 91 | (format t "Could not evaluate modexpr ~s, " me) | |
| 92 | (when (and qual (not (equal qual ""))) | |
| 93 | (format t "~% no such module ~s" qual))) | |
| 94 | (setf mod (find-module-in-env name context)))) | |
| 95 | (setq mod (find-module-in-env me (if also-local | |
| 96 | (get-context-module t) | |
| 97 | nil)))))) | |
| 103 | 98 | (if mod |
| 104 | (if reconstruct-if-need | |
| 105 | (reconstruct-module-if-need mod) | |
| 106 | mod) | |
| 99 | (if reconstruct-if-need | |
| 100 | (reconstruct-module-if-need mod) | |
| 101 | mod) | |
| 107 | 102 | ;; autoloading |
| 108 | 103 | (let ((ent (assoc me *autoload-alist* :test #'equal))) |
| 109 | (cond ((and ent (not (equal (car ent) *on-autoload*))) | |
| 110 | (let ((*on-autoload* me)) | |
| 111 | (declare (special *on-autoload*)) | |
| 112 | (!input-file (cdr ent))) | |
| 113 | (setq mod (find-module-in-env me (if also-local | |
| 114 | *current-module* | |
| 115 | nil))) | |
| 116 | (if mod | |
| 117 | mod | |
| 118 | (cons :error me))) | |
| 119 | (t (let ((newmod (eval-modexp* me))) | |
| 120 | (if (modexp-is-error newmod) | |
| 121 | newmod | |
| 122 | (progn | |
| 123 | (add-modexp-defn me newmod) | |
| 124 | newmod))))))))) | |
| 104 | (cond ((and ent (not (equal (car ent) *on-autoload*))) | |
| 105 | (let ((*on-autoload* me)) | |
| 106 | (declare (special *on-autoload*)) | |
| 107 | (!input-file (cdr ent))) | |
| 108 | (setq mod (find-module-in-env me (if also-local | |
| 109 | (get-context-module t) | |
| 110 | nil))) | |
| 111 | (if mod | |
| 112 | mod | |
| 113 | (cons :error me))) | |
| 114 | (t (let ((newmod (eval-modexp* me))) | |
| 115 | (if (modexp-is-error newmod) | |
| 116 | newmod | |
| 117 | (progn | |
| 118 | (add-modexp-defn me newmod) | |
| 119 | newmod))))))))) | |
| 125 | 120 | |
| 126 | 121 | ;;; EVAL-MODEXP* : modexp -> module |
| 127 | 122 | ;;; creates a module from a canonicalized module expression. |
| 133 | 128 | ;;; |
| 134 | 129 | (defun eval-modexp* (modexp) |
| 135 | 130 | (cond ((stringp modexp) |
| 136 | (cons :error modexp)) ; simple name at this point is always | |
| 137 | ; treated as invalid modexp... can be | |
| 138 | ; optimized though. | |
| 139 | ((modexp-is-parameter-theory modexp) | |
| 140 | ; and also for (X "::" M) | |
| 141 | (cons :error modexp)) | |
| 142 | ||
| 143 | ;; PLUS | |
| 144 | ((or (%is-plus modexp) (int-plus-p modexp)) | |
| 145 | (compile-module (create-plus modexp) t)) | |
| 146 | ||
| 147 | ;; RENAME | |
| 148 | ((or (%is-rename modexp) (int-rename-p modexp)) | |
| 149 | (compile-module (create-rename modexp) t)) | |
| 150 | ||
| 151 | ;; INSTANTIATION | |
| 152 | ((or (%is-instantiation modexp) (int-instantiation-p modexp)) | |
| 153 | (compile-module (create-instantiation modexp) t)) | |
| 154 | ||
| 155 | ;; VIEW | |
| 156 | ((%is-view modexp) (complete-view modexp nil)) | |
| 157 | ||
| 158 | ;; MODULE | |
| 159 | ((module-p modexp) | |
| 160 | (compile-module modexp)) | |
| 161 | ||
| 162 | ;; Internal Error! | |
| 163 | (t (with-output-chaos-error ('invalid-modexp) | |
| 164 | (format t "bad modexp form ~s" modexp))) | |
| 165 | )) | |
| 131 | (cons :error modexp)) ; simple name at this point is always | |
| 132 | ; treated as invalid modexp... can be | |
| 133 | ; optimized though. | |
| 134 | ((modexp-is-parameter-theory modexp) | |
| 135 | ; and also for (X "::" M) | |
| 136 | (cons :error modexp)) | |
| 137 | ||
| 138 | ;; PLUS | |
| 139 | ((or (%is-plus modexp) (int-plus-p modexp)) | |
| 140 | (compile-module (create-plus modexp) t)) | |
| 141 | ||
| 142 | ;; RENAME | |
| 143 | ((or (%is-rename modexp) (int-rename-p modexp)) | |
| 144 | (compile-module (create-rename modexp) t)) | |
| 145 | ||
| 146 | ;; INSTANTIATION | |
| 147 | ((or (%is-instantiation modexp) (int-instantiation-p modexp)) | |
| 148 | (compile-module (create-instantiation modexp) t)) | |
| 149 | ||
| 150 | ;; VIEW | |
| 151 | ((%is-view modexp) (complete-view modexp nil)) | |
| 152 | ||
| 153 | ;; MODULE | |
| 154 | ((module-p modexp) | |
| 155 | (compile-module modexp)) | |
| 156 | ||
| 157 | ;; Internal Error! | |
| 158 | (t (with-output-chaos-error ('invalid-modexp) | |
| 159 | (format t "bad modexp form ~s" modexp))))) | |
| 166 | 160 | |
| 167 | 161 | ;;; ************************ |
| 168 | 162 | ;;; SPECIFIC MODULE CREATORS____________________________________________________ |
| 177 | 171 | (declaim (special *copy-variables*)) |
| 178 | 172 | (defvar *copy-variables* nil) |
| 179 | 173 | |
| 180 | #|| | |
| 181 | 174 | (defun create-renamed-module (mod name) |
| 182 | 175 | (let ((*beh-proof-in-progress* t) |
| 183 | (*copy-variables* t)) | |
| 176 | (*copy-variables* t) | |
| 177 | (*auto-context-change* nil)) | |
| 184 | 178 | (let ((newmod (eval-ast (%module-decl* (normalize-modexp name) |
| 185 | (module-kind mod) | |
| 186 | :user | |
| 187 | (list (%import* :using mod)))))) | |
| 188 | (add-modexp-defn (module-name newmod) newmod) | |
| 189 | (compile-module newmod) | |
| 190 | newmod) | |
| 191 | )) | |
| 192 | ||# | |
| 193 | (defun create-renamed-module (mod name) | |
| 194 | (let ((*beh-proof-in-progress* t) | |
| 195 | (*copy-variables* t) | |
| 196 | (*auto-context-change* nil)) | |
| 197 | (let ((newmod (eval-ast (%module-decl* (normalize-modexp name) | |
| 198 | (module-kind mod) | |
| 199 | :user | |
| 200 | nil)))) | |
| 179 | (module-kind mod) | |
| 180 | :user | |
| 181 | nil)))) | |
| 201 | 182 | (import-module newmod :using mod) |
| 202 | 183 | (add-modexp-defn (module-name newmod) newmod) |
| 203 | 184 | (compile-module newmod) |
| 204 | newmod) | |
| 205 | )) | |
| 185 | newmod))) | |
| 206 | 186 | |
| 207 | 187 | (defun create-renamed-module-2 (mod name context-module) |
| 208 | 188 | (let ((*copy-variables* t) |
| 209 | (*auto-context-change* nil)) | |
| 189 | (*auto-context-change* nil)) | |
| 210 | 190 | (let ((newmod (eval-ast (%module-decl* (normalize-modexp name) |
| 211 | (module-kind mod) | |
| 212 | :user | |
| 213 | nil)))) | |
| 191 | (module-kind mod) | |
| 192 | :user | |
| 193 | nil)))) | |
| 214 | 194 | (incorporate-module-copying newmod mod t nil context-module) |
| 215 | 195 | (add-modexp-defn (module-name newmod) newmod) |
| 216 | 196 | (compile-module newmod) |
| 217 | newmod) | |
| 218 | )) | |
| 197 | newmod))) | |
| 219 | 198 | |
| 220 | 199 | ;;; *********** |
| 221 | 200 | ;;; CREATE-PLUS : Modexp -> Module |
| 224 | 203 | ;;; |
| 225 | 204 | (defun create-plus (modexp) |
| 226 | 205 | (flet ((report-error (&rest ignore) |
| 227 | (declare (ignore ignore)) | |
| 228 | (with-output-msg () | |
| 229 | (format t "could not evaluate plus: ") | |
| 230 | (print-modexp modexp) | |
| 231 | (chaos-error 'modexp-error)))) | |
| 206 | (declare (ignore ignore)) | |
| 207 | (with-output-msg () | |
| 208 | (format t "could not evaluate plus: ") | |
| 209 | (print-modexp modexp) | |
| 210 | (chaos-error 'modexp-error)))) | |
| 232 | 211 | (with-chaos-error (#'report-error) |
| 233 | (cond ((int-plus-p modexp) ; evaluated internal rep. | |
| 234 | (let ((newmod (create-module modexp))) | |
| 235 | (with-in-module (newmod) | |
| 236 | (dolist (mod (int-plus-args modexp)) | |
| 237 | (import-module-internal newmod :protecting mod)) | |
| 238 | (compile-module newmod)) | |
| 239 | newmod)) | |
| 240 | (t ; no yet evaluated, generate from the | |
| 241 | ; scratch. | |
| 242 | (let ((args (%plus-args modexp)) | |
| 243 | (res nil)) | |
| 244 | (dolist (arg args) | |
| 245 | ;; arguments must not local module .. | |
| 246 | (let ((val (eval-modexp arg nil))) | |
| 247 | (when (modexp-is-error val) | |
| 248 | (with-output-chaos-error ('modexp-eval) | |
| 249 | (format t "could not evaluate an argument to `+' : ") | |
| 250 | (print-modexp arg) | |
| 251 | )) | |
| 252 | (push val res))) | |
| 253 | (let* ((name (make-int-plus :args res)) | |
| 254 | (newmod (or *modmorph-new-module* (create-module name)))) | |
| 255 | (setf (module-decl-form newmod) modexp) | |
| 256 | (with-in-module (newmod) | |
| 257 | (dolist (mod res) | |
| 258 | (import-module-internal newmod :protecting mod)) | |
| 259 | (compile-module newmod) | |
| 260 | newmod)))))))) | |
| 212 | (cond ((int-plus-p modexp) ; evaluated internal rep. | |
| 213 | (let ((newmod (create-module modexp))) | |
| 214 | (with-in-module (newmod) | |
| 215 | (dolist (mod (int-plus-args modexp)) | |
| 216 | (import-module-internal newmod :protecting mod)) | |
| 217 | (compile-module newmod)) | |
| 218 | newmod)) | |
| 219 | (t ; no yet evaluated, generate from the | |
| 220 | ; scratch. | |
| 221 | (let ((args (%plus-args modexp)) | |
| 222 | (res nil)) | |
| 223 | (dolist (arg args) | |
| 224 | ;; arguments must not local module .. | |
| 225 | (let ((val (eval-modexp arg nil))) | |
| 226 | (when (modexp-is-error val) | |
| 227 | (with-output-chaos-error ('modexp-eval) | |
| 228 | (format t "could not evaluate an argument to `+' : ") | |
| 229 | (print-modexp arg) | |
| 230 | )) | |
| 231 | (push val res))) | |
| 232 | (let* ((name (make-int-plus :args res)) | |
| 233 | (newmod (or *modmorph-new-module* (create-module name)))) | |
| 234 | (setf (module-decl-form newmod) modexp) | |
| 235 | (with-in-module (newmod) | |
| 236 | (dolist (mod res) | |
| 237 | (import-module-internal newmod :protecting mod)) | |
| 238 | (compile-module newmod) | |
| 239 | newmod)))))))) | |
| 261 | 240 | |
| 262 | 241 | ;;; ******************** |
| 263 | 242 | ;;; CREATE-INSTANTIATION : MODEXP -> MODULE |
| 264 | 243 | ;;; ******************** |
| 265 | 244 | ;;; *NOTE* apply-modmorph must use memo tables since mapping may affect |
| 266 | 245 | ;;; sub-modules (e.g. with "protecting A[X <= Y]") |
| 267 | ;;; | |
| 268 | ;;; | |
| 269 | #|| | |
| 246 | ||
| 270 | 247 | (defun create-instantiation (modexp) |
| 271 | 248 | (flet ((report-error (&rest ignore) |
| 272 | (declare (ignore ignore)) | |
| 273 | (with-output-msg () | |
| 274 | (princ "could not evaluate instantiation: ") | |
| 275 | (print-modexp modexp *standard-output* t t) | |
| 276 | (chaos-error 'modexp-error)))) | |
| 249 | (declare (ignore ignore)) | |
| 250 | (with-output-msg () | |
| 251 | (princ "could not evaluate instantiation: ") | |
| 252 | (print-modexp modexp *standard-output* t t) | |
| 253 | (chaos-error 'modexp-error)))) | |
| 277 | 254 | (with-chaos-error (#'report-error) |
| 278 | 255 | (cond ((int-instantiation-p modexp) ; evaluated internal modexp. |
| 279 | (let ((mappg (views-to-modmorph (int-instantiation-module modexp) | |
| 280 | (int-instantiation-args modexp)))) | |
| 281 | (apply-modmorph modexp mappg (int-instantiation-module modexp)))) | |
| 282 | (t ; not yet evaluated, build from the | |
| 283 | ; scratch. | |
| 284 | (let* ((*auto-context-change* nil) | |
| 285 | ;; parameter module must be a global | |
| 286 | (modpar (eval-modexp (%instantiation-module modexp)))) | |
| 287 | (unless (module-p modpar) | |
| 288 | (with-output-chaos-error ('modexp-err) | |
| 289 | (princ "Unknown parameterized module in instantiation: ") | |
| 290 | (when (modexp-is-error modpar) | |
| 291 | (princ (cdr modpar)) | |
| 292 | )) | |
| 293 | ) | |
| 294 | #|| | |
| 295 | (when (eq *current-module* modpar) | |
| 296 | (with-output-chaos-error ('modexp-eval) | |
| 297 | (princ "module ") | |
| 298 | (print-mod-name *current-module*) | |
| 299 | (princ "cannot instantiate itself") | |
| 300 | )) | |
| 301 | ||# | |
| 302 | (unless (get-module-parameters modpar) | |
| 303 | (with-output-chaos-error ('modexp-eval) | |
| 304 | (princ "module ") | |
| 305 | (print-mod-name modpar) | |
| 306 | (princ " has no parameters.") | |
| 307 | )) | |
| 308 | ;; | |
| 309 | (let ((args (do ((r (%instantiation-args modexp) (cdr r)) | |
| 310 | (res nil)) | |
| 311 | ((null r) (nreverse res)) | |
| 312 | (push (eval-view-arg (car r) | |
| 313 | modpar) | |
| 314 | res)))) | |
| 315 | (let ((name (make-int-instantiation :module modpar | |
| 316 | :args args)) | |
| 317 | (mappg (views-to-modmorph modpar args))) | |
| 318 | (let ((module (apply-modmorph name mappg modpar))) | |
| 319 | ;; (setf (module-name module) name) ; name is set by apply-modmorph. | |
| 320 | (setf (module-decl-form module) modexp) | |
| 321 | module))))))))) | |
| 322 | ||# | |
| 323 | ||
| 324 | (defun create-instantiation (modexp) | |
| 325 | (flet ((report-error (&rest ignore) | |
| 326 | (declare (ignore ignore)) | |
| 327 | (with-output-msg () | |
| 328 | (princ "could not evaluate instantiation: ") | |
| 329 | (print-modexp modexp *standard-output* t t) | |
| 330 | (chaos-error 'modexp-error)))) | |
| 331 | (with-chaos-error (#'report-error) | |
| 332 | (cond ((int-instantiation-p modexp) ; evaluated internal modexp. | |
| 333 | (let ((mappg (views-to-modmorph (int-instantiation-module modexp) | |
| 334 | (int-instantiation-args modexp)))) | |
| 335 | (apply-modmorph modexp mappg (int-instantiation-module modexp)))) | |
| 336 | (t ; not yet evaluated, build from the | |
| 337 | ; scratch. | |
| 338 | (let* ((*auto-context-change* nil) | |
| 339 | ;; parameter module must be a global | |
| 340 | (modpar (eval-modexp (%instantiation-module modexp)))) | |
| 341 | (unless (module-p modpar) | |
| 342 | (with-output-chaos-error ('modexp-err) | |
| 343 | (princ "Unknown parameterized module in instantiation: ") | |
| 344 | (when (modexp-is-error modpar) | |
| 345 | (princ (cdr modpar)) | |
| 346 | )) | |
| 347 | ) | |
| 348 | (unless (get-module-parameters modpar) | |
| 349 | (with-output-chaos-error ('modexp-eval) | |
| 350 | (princ "module ") | |
| 351 | (print-mod-name modpar) | |
| 352 | (princ " has no parameters.") | |
| 353 | )) | |
| 354 | ;; | |
| 355 | (let ((args nil) | |
| 356 | (mappg nil)) | |
| 357 | (push (eval-view-arg (car (%instantiation-args modexp)) | |
| 358 | modpar | |
| 359 | nil) | |
| 360 | args) | |
| 361 | (setq mappg (view->modmorph modpar (car args))) | |
| 362 | ;; | |
| 363 | (dolist (r (cdr (%instantiation-args modexp))) | |
| 364 | (push (eval-view-arg r modpar mappg) args) | |
| 365 | (setq mappg | |
| 366 | (modmorph-merge mappg | |
| 367 | (view->modmorph modpar (car args))))) | |
| 368 | (setq args (nreverse args)) | |
| 369 | ;; | |
| 370 | (let ((name (make-int-instantiation :module modpar | |
| 371 | :args args))) | |
| 372 | (let ((module (apply-modmorph name mappg modpar))) | |
| 373 | ;; (setf (module-name module) name) ; name is set by apply-modmorph. | |
| 374 | (setf (module-decl-form module) modexp) | |
| 375 | module))))))))) | |
| 256 | (let ((mappg (views-to-modmorph (int-instantiation-module modexp) | |
| 257 | (int-instantiation-args modexp)))) | |
| 258 | (apply-modmorph modexp mappg (int-instantiation-module modexp)))) | |
| 259 | (t ; not yet evaluated, build from the | |
| 260 | ; scratch. | |
| 261 | (let* ((*auto-context-change* nil) | |
| 262 | ;; parameter module must be a global | |
| 263 | (modpar (eval-modexp (%instantiation-module modexp)))) | |
| 264 | (unless (module-p modpar) | |
| 265 | (with-output-chaos-error ('modexp-err) | |
| 266 | (princ "Unknown parameterized module in instantiation: ") | |
| 267 | (when (modexp-is-error modpar) | |
| 268 | (princ (cdr modpar))))) | |
| 269 | (unless (get-module-parameters modpar) | |
| 270 | (with-output-chaos-error ('modexp-eval) | |
| 271 | (princ "module ") | |
| 272 | (print-mod-name modpar) | |
| 273 | (princ " has no parameters."))) | |
| 274 | ;; | |
| 275 | (let ((args nil) | |
| 276 | (mappg nil)) | |
| 277 | (push (eval-view-arg (car (%instantiation-args modexp)) | |
| 278 | modpar | |
| 279 | nil) | |
| 280 | args) | |
| 281 | (setq mappg (view->modmorph modpar (car args))) | |
| 282 | ;; | |
| 283 | (dolist (r (cdr (%instantiation-args modexp))) | |
| 284 | (push (eval-view-arg r modpar mappg) args) | |
| 285 | (setq mappg | |
| 286 | (modmorph-merge mappg | |
| 287 | (view->modmorph modpar (car args))))) | |
| 288 | (setq args (nreverse args)) | |
| 289 | ;; | |
| 290 | (let ((name (make-int-instantiation :module modpar | |
| 291 | :args args))) | |
| 292 | (let ((module (apply-modmorph name mappg modpar))) | |
| 293 | ;; (setf (module-name module) name) ; name is set by apply-modmorph. | |
| 294 | (setf (module-decl-form module) modexp) | |
| 295 | module))))))))) | |
| 376 | 296 | |
| 377 | 297 | ;;; EVAL-VIEW-ARG : Arg Module pre-maps -> Arg' |
| 378 | 298 | ;;; Arg == (%!arg formal-arg-name View) |
| 381 | 301 | ;;; |
| 382 | 302 | (defun eval-view-arg (arg mod pre-maps) |
| 383 | 303 | (let ((arg-name (%!arg-name arg)) |
| 384 | (vw (%!arg-view arg))) | |
| 385 | (unless (%is-view vw) (break "Invalid view in instantition!")) ; panic | |
| 304 | (vw (%!arg-view arg))) | |
| 305 | (unless (%is-view vw) (break "Invalid view in instantition!")) ; panic | |
| 386 | 306 | (%!arg* arg-name |
| 387 | (complete-view vw arg-name mod pre-maps)))) | |
| 307 | (complete-view vw arg-name mod pre-maps)))) | |
| 388 | 308 | |
| 389 | 309 | ;;; ************* |
| 390 | 310 | ;;; CREATE-RENAME : modexp -> module |
| 395 | 315 | (let ((sort (find-sort-in mod name))) |
| 396 | 316 | (unless sort |
| 397 | 317 | (with-output-chaos-error ('no-such-sort) |
| 398 | (princ "sort is not found for rename.") | |
| 399 | (print-sort-ref name) | |
| 400 | )) | |
| 318 | (princ "sort is not found for rename.") | |
| 319 | (print-sort-ref name) | |
| 320 | )) | |
| 401 | 321 | (when (and sort (eq *chaos-module* (sort-module sort))) |
| 402 | 322 | (with-output-chaos-error ('sort-hard-wired) |
| 403 | (format t "sorry! sort `~a' is hard-wired, cannot be renamed." | |
| 404 | (string (sort-id sort))) | |
| 405 | )) | |
| 323 | (format t "sorry! sort `~a' is hard-wired, cannot be renamed." | |
| 324 | (string (sort-id sort))) | |
| 325 | )) | |
| 406 | 326 | (when (or (and (eq type :visible) (sort-is-hidden sort)) |
| 407 | (and (eq type :hidden) (not (sort-is-hidden sort)))) | |
| 327 | (and (eq type :hidden) (not (sort-is-hidden sort)))) | |
| 408 | 328 | (with-output-chaos-error ('sort-type-error) |
| 409 | (format t "~a must be ~a for `~a' renaming." | |
| 410 | (string (sort-id sort)) | |
| 411 | type | |
| 412 | (if (eq type :visible) | |
| 413 | "sort" | |
| 414 | "hsort") | |
| 415 | ) | |
| 416 | )) | |
| 329 | (format t "~a must be ~a for `~a' renaming." | |
| 330 | (string (sort-id sort)) | |
| 331 | type | |
| 332 | (if (eq type :visible) | |
| 333 | "sort" | |
| 334 | "hsort")))) | |
| 417 | 335 | sort)) |
| 418 | 336 | |
| 419 | 337 | (defun create-rename (modexp) |
| 420 | 338 | (flet ((report-error (&rest ignore) |
| 421 | (declare (ignore ignore)) | |
| 422 | (with-output-msg () | |
| 423 | (princ "could not evaluate the renaming: ") | |
| 424 | (print-modexp modexp) | |
| 425 | (chaos-error 'modexp-error)))) | |
| 426 | (cond ((int-rename-p modexp) ; internal evaluated | |
| 427 | (let* ((newmod (!create-module modexp)) | |
| 428 | (target-mod (eval-modexp* (int-rename-module modexp))) | |
| 429 | (modmap (acons target-mod newmod nil)) | |
| 430 | (map (create-modmorph modexp | |
| 431 | (int-rename-sort-maps modexp) | |
| 432 | (int-rename-op-maps modexp) | |
| 433 | modmap))) | |
| 434 | (with-in-module (newmod) | |
| 435 | (apply-modmorph-internal map target-mod newmod)) | |
| 436 | newmod)) | |
| 437 | (t ; pure modexp | |
| 438 | ;; create new module from the scratch. | |
| 439 | (let ((target-module nil)) | |
| 440 | (with-chaos-error (#'report-error) | |
| 441 | ;; target must be global | |
| 442 | (setq target-module (eval-modexp (%rename-module modexp))) | |
| 443 | (when *on-modexp-debug* | |
| 444 | (with-output-msg() | |
| 445 | (format t "create rename: target = ") | |
| 446 | (print-modexp target-module))) | |
| 447 | (when (modexp-is-error target-module) | |
| 448 | (with-output-chaos-error ('no-such-module) | |
| 449 | (princ "no such module: ") | |
| 450 | (print-modexp (%rename-module modexp)))) | |
| 451 | (setf (%rename-module modexp) target-module) | |
| 452 | (let* ((mod target-module) | |
| 453 | (ren (if (%is-rmap (%rename-map modexp)) | |
| 454 | (%rmap-map (%rename-map modexp)) | |
| 455 | (%rename-map modexp))) | |
| 456 | (mod-name modexp) ; dummy at this time, will changed by | |
| 457 | ; int-rename later. | |
| 458 | (newmod (!create-module mod-name)) | |
| 459 | (modmap (acons mod newmod nil)) | |
| 460 | (map (create-modmorph modexp nil nil modmap))) | |
| 461 | ;; | |
| 462 | (let ((check (is-rename-injective ren))) | |
| 463 | (when (eq check :warn) | |
| 464 | (with-output-chaos-warning () | |
| 465 | (princ "rename map may not be injective: ") | |
| 466 | (print-modexp modexp))) | |
| 467 | (when (eq check :invalid) | |
| 468 | (with-output-chaos-error () | |
| 469 | (princ "invalid rename map: ") | |
| 470 | (print-modexp modexp)))) | |
| 471 | ;; | |
| 472 | (dolist (x (cadr (assq '%ren-sort ren))) | |
| 473 | (let ((sort (find-renaming-sort-in mod (car x) :visible))) | |
| 474 | ;; NOTE: `rename-sort' may modify module map & sort map | |
| 475 | ;; iff it generates a dummy module. | |
| 476 | (rename-sort map mod newmod sort (%sort-ref-name (cadr x))))) | |
| 477 | ;; | |
| 478 | (dolist (x (cadr (assq '%ren-hsort ren))) | |
| 479 | (let ((sort (find-renaming-sort-in mod (car x) :hidden))) | |
| 480 | (rename-sort map mod newmod sort (%sort-ref-name (cadr x))))) | |
| 481 | ||
| 482 | ;; generate new operator (opinfo + methods) with making | |
| 483 | ;; operator map in map. | |
| 484 | ;; `rename-op' may modify module map iff it generated a dummy | |
| 485 | ;; module. | |
| 486 | ;; operator map is set by `rename-op'. | |
| 487 | (dolist (x (cadr (assq '%ren-op ren))) | |
| 488 | (let ((opinfos (find-qual-operators (car x) mod ':functional))) | |
| 489 | (unless opinfos | |
| 490 | (with-output-chaos-error ('no-such-operator) | |
| 491 | (princ "operator not found in rename: ") | |
| 492 | (print-ast (car x)) | |
| 493 | (princ " in module ") (print-modexp mod))) | |
| 494 | (dolist (opinfo opinfos) | |
| 495 | (rename-op map mod newmod opinfo (cadr x) mod)))) | |
| 496 | ;; | |
| 497 | (dolist (x (cadr (assq '%ren-bop ren))) | |
| 498 | (let ((opinfos (find-qual-operators (car x) mod ':behavioural))) | |
| 499 | (unless opinfos | |
| 500 | (with-output-chaos-error ('no-such-operator) | |
| 501 | (princ "behavioural operator not found in rename: ") | |
| 502 | (print-ast (car x)) | |
| 503 | (princ " in module ") (print-modexp mod))) | |
| 504 | (dolist (opinfo opinfos) | |
| 505 | (rename-op map mod newmod opinfo (cadr x) mod)))) | |
| 506 | ;; we must make maps of SortId constants iff the | |
| 507 | ;; coressponding sort is mapped. | |
| 508 | (dolist (s-map (modmorph-sort map)) | |
| 509 | (let* ((source (car s-map)) | |
| 510 | (target (cdr s-map)) | |
| 511 | (old-name (list (string (sort-id source)))) | |
| 512 | (new-name (list (string (sort-id target)))) | |
| 513 | (s-opinfo nil) | |
| 514 | (s-method nil)) | |
| 515 | (setq s-opinfo (find-operators-in-module | |
| 516 | old-name | |
| 517 | 0 | |
| 518 | mod | |
| 519 | ':functional)) | |
| 520 | (when (cdr s-opinfo) | |
| 521 | (with-output-chaos-error ('too-may-opinfos) | |
| 522 | (princ "automatic generation of operator renaming failed") | |
| 523 | (format t "~& for SortId ~a" old-name))) | |
| 524 | (setq s-opinfo (car s-opinfo)) | |
| 525 | (with-in-module (mod) | |
| 526 | (setq s-method (lowest-method* (car (opinfo-methods s-opinfo))))) | |
| 527 | (unless (*find-method-in-map (modmorph-op map) s-method) | |
| 528 | (rename-op map mod newmod s-opinfo new-name mod)))) | |
| 529 | ||
| 530 | ;; now we've constructed the maps, | |
| 531 | ;; we can make real module name here. | |
| 532 | (setq mod-name (make-int-rename :module mod | |
| 533 | :sort-maps (modmorph-sort map) | |
| 534 | :op-maps (modmorph-op map))) | |
| 535 | (setf (module-name newmod) mod-name) | |
| 536 | ;; | |
| 537 | ;; finally, apply generated modmorph. | |
| 538 | ;; | |
| 539 | (with-in-module (newmod) | |
| 540 | (apply-modmorph-internal map mod newmod)) | |
| 541 | (setf (module-decl-form newmod) modexp) | |
| 542 | newmod ))))))) | |
| 339 | (declare (ignore ignore)) | |
| 340 | (with-output-msg () | |
| 341 | (princ "could not evaluate the renaming: ") | |
| 342 | (print-modexp modexp) | |
| 343 | (chaos-error 'modexp-error)))) | |
| 344 | (cond ((int-rename-p modexp) ; internal evaluated | |
| 345 | (let* ((newmod (!create-module modexp)) | |
| 346 | (target-mod (eval-modexp* (int-rename-module modexp))) | |
| 347 | (modmap (acons target-mod newmod nil)) | |
| 348 | (map (create-modmorph modexp | |
| 349 | (int-rename-sort-maps modexp) | |
| 350 | (int-rename-op-maps modexp) | |
| 351 | modmap))) | |
| 352 | (with-in-module (newmod) | |
| 353 | (apply-modmorph-internal map target-mod newmod)) | |
| 354 | newmod)) | |
| 355 | (t ; pure modexp | |
| 356 | ;; create new module from the scratch. | |
| 357 | (let ((target-module nil)) | |
| 358 | (with-chaos-error (#'report-error) | |
| 359 | ;; target must be global | |
| 360 | (setq target-module (eval-modexp (%rename-module modexp))) | |
| 361 | (when *on-modexp-debug* | |
| 362 | (with-output-msg() | |
| 363 | (format t "create rename: target = ") | |
| 364 | (print-modexp target-module))) | |
| 365 | (when (modexp-is-error target-module) | |
| 366 | (with-output-chaos-error ('no-such-module) | |
| 367 | (princ "no such module: ") | |
| 368 | (print-modexp (%rename-module modexp)))) | |
| 369 | (setf (%rename-module modexp) target-module) | |
| 370 | (let* ((mod target-module) | |
| 371 | (ren (if (%is-rmap (%rename-map modexp)) | |
| 372 | (%rmap-map (%rename-map modexp)) | |
| 373 | (%rename-map modexp))) | |
| 374 | (mod-name modexp) ; dummy at this time, will changed by | |
| 375 | ; int-rename later. | |
| 376 | (newmod (!create-module mod-name)) | |
| 377 | (modmap (acons mod newmod nil)) | |
| 378 | (map (create-modmorph modexp nil nil modmap))) | |
| 379 | ;; | |
| 380 | (let ((check (is-rename-injective ren))) | |
| 381 | (when (eq check :warn) | |
| 382 | (with-output-chaos-warning () | |
| 383 | (princ "rename map may not be injective: ") | |
| 384 | (print-modexp modexp))) | |
| 385 | (when (eq check :invalid) | |
| 386 | (with-output-chaos-error () | |
| 387 | (princ "invalid rename map: ") | |
| 388 | (print-modexp modexp)))) | |
| 389 | ;; | |
| 390 | (dolist (x (cadr (assq '%ren-sort ren))) | |
| 391 | (let ((sort (find-renaming-sort-in mod (car x) :visible))) | |
| 392 | ;; NOTE: `rename-sort' may modify module map & sort map | |
| 393 | ;; iff it generates a dummy module. | |
| 394 | (rename-sort map mod newmod sort (%sort-ref-name (cadr x))))) | |
| 395 | ;; | |
| 396 | (dolist (x (cadr (assq '%ren-hsort ren))) | |
| 397 | (let ((sort (find-renaming-sort-in mod (car x) :hidden))) | |
| 398 | (rename-sort map mod newmod sort (%sort-ref-name (cadr x))))) | |
| 399 | ||
| 400 | ;; generate new operator (opinfo + methods) with making | |
| 401 | ;; operator map in map. | |
| 402 | ;; `rename-op' may modify module map iff it generated a dummy | |
| 403 | ;; module. | |
| 404 | ;; operator map is set by `rename-op'. | |
| 405 | (dolist (x (cadr (assq '%ren-op ren))) | |
| 406 | (let ((opinfos (find-qual-operators (car x) mod ':functional))) | |
| 407 | (unless opinfos | |
| 408 | (with-output-chaos-error ('no-such-operator) | |
| 409 | (princ "operator not found in rename: ") | |
| 410 | (print-ast (car x)) | |
| 411 | (princ " in module ") (print-modexp mod))) | |
| 412 | (dolist (opinfo opinfos) | |
| 413 | (rename-op map mod newmod opinfo (cadr x) mod)))) | |
| 414 | ;; | |
| 415 | (dolist (x (cadr (assq '%ren-bop ren))) | |
| 416 | (let ((opinfos (find-qual-operators (car x) mod ':behavioural))) | |
| 417 | (unless opinfos | |
| 418 | (with-output-chaos-error ('no-such-operator) | |
| 419 | (princ "behavioural operator not found in rename: ") | |
| 420 | (print-ast (car x)) | |
| 421 | (princ " in module ") (print-modexp mod))) | |
| 422 | (dolist (opinfo opinfos) | |
| 423 | (rename-op map mod newmod opinfo (cadr x) mod)))) | |
| 424 | ;; we must make maps of SortId constants iff the | |
| 425 | ;; coressponding sort is mapped. | |
| 426 | (dolist (s-map (modmorph-sort map)) | |
| 427 | (let* ((source (car s-map)) | |
| 428 | (target (cdr s-map)) | |
| 429 | (old-name (list (string (sort-id source)))) | |
| 430 | (new-name (list (string (sort-id target)))) | |
| 431 | (s-opinfo nil) | |
| 432 | (s-method nil)) | |
| 433 | (setq s-opinfo (find-operators-in-module | |
| 434 | old-name | |
| 435 | 0 | |
| 436 | mod | |
| 437 | ':functional)) | |
| 438 | (when (cdr s-opinfo) | |
| 439 | (with-output-chaos-error ('too-may-opinfos) | |
| 440 | (princ "automatic generation of operator renaming failed") | |
| 441 | (format t "~% for SortId ~a" old-name))) | |
| 442 | (setq s-opinfo (car s-opinfo)) | |
| 443 | (with-in-module (mod) | |
| 444 | (setq s-method (lowest-method* (car (opinfo-methods s-opinfo))))) | |
| 445 | (unless (*find-method-in-map (modmorph-op map) s-method) | |
| 446 | (rename-op map mod newmod s-opinfo new-name mod)))) | |
| 447 | ||
| 448 | ;; now we've constructed the maps, | |
| 449 | ;; we can make real module name here. | |
| 450 | (setq mod-name (make-int-rename :module mod | |
| 451 | :sort-maps (modmorph-sort map) | |
| 452 | :op-maps (modmorph-op map))) | |
| 453 | (setf (module-name newmod) mod-name) | |
| 454 | ;; | |
| 455 | ;; finally, apply generated modmorph. | |
| 456 | ;; | |
| 457 | (with-in-module (newmod) | |
| 458 | (apply-modmorph-internal map mod newmod)) | |
| 459 | (setf (module-decl-form newmod) modexp) | |
| 460 | newmod ))))))) | |
| 543 | 461 | |
| 544 | 462 | ;;; EOF |
| 0 | 0 | ;;;-*- Mode:LISP; Package:CHAOS; Base:10; Syntax:Common-lisp -*- |
| 1 | 1 | ;;; |
| 2 | ;;; Copyright (c) 2000-2014, Toshimi Sawada. All rights reserved. | |
| 2 | ;;; Copyright (c) 2000-2015, Toshimi Sawada. All rights reserved. | |
| 3 | 3 | ;;; |
| 4 | 4 | ;;; Redistribution and use in source and binary forms, with or without |
| 5 | 5 | ;;; modification, are permitted provided that the following conditions |
| 27 | 27 | ;;; |
| 28 | 28 | (in-package :chaos) |
| 29 | 29 | #|============================================================================== |
| 30 | System: CHAOS | |
| 31 | Module: deCafe | |
| 32 | File: mimport.lisp | |
| 30 | System: CHAOS | |
| 31 | Module: deCafe | |
| 32 | File: mimport.lisp | |
| 33 | 33 | ==============================================================================|# |
| 34 | 34 | #-:chaos-debug |
| 35 | 35 | (declaim (optimize (speed 3) (safety 0) #-GCL (debug 0))) |
| 67 | 67 | (let ((*auto-context-change* nil)) |
| 68 | 68 | (setq *import-sort-map* nil) |
| 69 | 69 | (prog1 |
| 70 | (import-module-internal im mode sub parameter nil alias) | |
| 70 | (import-module-internal im mode sub parameter nil alias) | |
| 71 | 71 | (setq *import-sort-map* nil)))) |
| 72 | 72 | |
| 73 | 73 | (defun import-module-internal (im mode sub &optional parameter theory-mod alias) |
| 74 | 74 | (when *on-import-debug* |
| 75 | (format t "~&[import-module]: ") | |
| 75 | (format t "~%[import-module]: ") | |
| 76 | 76 | (print-next) |
| 77 | 77 | (princ " ") (print-modexp im) |
| 78 | 78 | (format t " <==(~a)== " mode) |
| 80 | 80 | (if parameter (format t " : ~a" parameter))) |
| 81 | 81 | ;; |
| 82 | 82 | (flet ((eval-modexp-or-error (modexp) |
| 83 | (let (val) | |
| 84 | (if (module-p modexp) | |
| 85 | (setf val modexp) | |
| 86 | (progn | |
| 87 | (setf val (eval-modexp modexp)) ; must be global | |
| 88 | (when (modexp-is-error val) | |
| 89 | (with-output-chaos-error ('modexp-eval) | |
| 90 | (princ "importing module, cannot evaluate module expression ") | |
| 91 | (print-modexp modexp) | |
| 92 | )))) | |
| 93 | val)) | |
| 94 | (is-directly-using (mod1 mod2) | |
| 95 | ;; IS-DIRECTLY-USING : Module-1 Module-2 -> Bool | |
| 96 | ;; returns t iff the module-1 imports module-2 directly. | |
| 97 | ;; `directly' means that some own constructs of Module-2 (sors and | |
| 98 | ;; operators declared in Module-2) are included in Module-1's | |
| 99 | ;; constructs, i.e., Module-2 is a node of a module hierarchy with | |
| 100 | ;; Module-1 at top. | |
| 101 | (or (some #'(lambda (x) (eq mod2 (sort-module x))) | |
| 102 | (module-all-sorts mod1)) | |
| 103 | (some #'(lambda (x) | |
| 104 | (eq mod2 (operator-module (opinfo-operator x)))) | |
| 105 | (module-all-operators mod1)))) | |
| 106 | (create-variant-name (parent mod) | |
| 107 | ;; CREATE-VARIANT-NAME | |
| 108 | ;; variant name ::= (:name <module name> <natural>) | |
| 109 | ;; We carete a brand new module when imported module refers some | |
| 110 | ;; soncstructs of importing module. this can happen when we import an | |
| 111 | ;; instantiated module with an actual parameter includes some sorts | |
| 112 | ;; or operators of importing module in its module morphism. In such | |
| 113 | ;; case, we create a module with the same name of importing module, | |
| 114 | ;; then importing module is changed its name to `variant-name'. The | |
| 115 | ;; newly created module, then imports this module. | |
| 116 | (let ((modname (module-name parent)) | |
| 117 | (num -1)) | |
| 118 | (declare (type fixnum num)) | |
| 119 | (dolist (sm (module-submodules mod)) | |
| 120 | (when (eq :protecting (cdr sm)) | |
| 121 | (let ((smnm (module-name (car sm)))) | |
| 122 | (when (and (consp smnm) | |
| 123 | (eq :name (car smnm)) | |
| 124 | (eq (cadr smnm) modname) ; by construction works | |
| 125 | (< num (the fixnum (caddr smnm)))) | |
| 126 | (setq num (caddr smnm)))))) | |
| 127 | `(:name ,modname ,(1+ (the fixnum num))) | |
| 128 | ))) | |
| 83 | (let (val) | |
| 84 | (if (module-p modexp) | |
| 85 | (setf val modexp) | |
| 86 | (progn | |
| 87 | (setf val (eval-modexp modexp)) ; must be global | |
| 88 | (when (modexp-is-error val) | |
| 89 | (with-output-chaos-error ('modexp-eval) | |
| 90 | (princ "importing module, cannot evaluate module expression ") | |
| 91 | (print-modexp modexp) | |
| 92 | )))) | |
| 93 | val)) | |
| 94 | (is-directly-using (mod1 mod2) | |
| 95 | ;; IS-DIRECTLY-USING : Module-1 Module-2 -> Bool | |
| 96 | ;; returns t iff the module-1 imports module-2 directly. | |
| 97 | ;; `directly' means that some own constructs of Module-2 (sors and | |
| 98 | ;; operators declared in Module-2) are included in Module-1's | |
| 99 | ;; constructs, i.e., Module-2 is a node of a module hierarchy with | |
| 100 | ;; Module-1 at top. | |
| 101 | (or (some #'(lambda (x) (eq mod2 (sort-module x))) | |
| 102 | (module-all-sorts mod1)) | |
| 103 | (some #'(lambda (x) | |
| 104 | (eq mod2 (operator-module (opinfo-operator x)))) | |
| 105 | (module-all-operators mod1)))) | |
| 106 | (create-variant-name (parent mod) | |
| 107 | ;; CREATE-VARIANT-NAME | |
| 108 | ;; variant name ::= (:name <module name> <natural>) | |
| 109 | ;; We carete a brand new module when imported module refers some | |
| 110 | ;; soncstructs of importing module. this can happen when we import an | |
| 111 | ;; instantiated module with an actual parameter includes some sorts | |
| 112 | ;; or operators of importing module in its module morphism. In such | |
| 113 | ;; case, we create a module with the same name of importing module, | |
| 114 | ;; then importing module is changed its name to `variant-name'. The | |
| 115 | ;; newly created module, then imports this module. | |
| 116 | (let ((modname (module-name parent)) | |
| 117 | (num -1)) | |
| 118 | (declare (type fixnum num)) | |
| 119 | (dolist (sm (module-submodules mod)) | |
| 120 | (when (eq :protecting (cdr sm)) | |
| 121 | (let ((smnm (module-name (car sm)))) | |
| 122 | (when (and (consp smnm) | |
| 123 | (eq :name (car smnm)) | |
| 124 | (eq (cadr smnm) modname) ; by construction works | |
| 125 | (< num (the fixnum (caddr smnm)))) | |
| 126 | (setq num (caddr smnm)))))) | |
| 127 | `(:name ,modname ,(1+ (the fixnum num))) | |
| 128 | ))) | |
| 129 | 129 | ;; |
| 130 | 130 | (let ((module (eval-modexp-or-error im)) |
| 131 | (submodule (eval-modexp-or-error sub))) | |
| 131 | (submodule (eval-modexp-or-error sub))) | |
| 132 | 132 | (unless (and (module-p module) (module-p submodule)) |
| 133 | ;; (break) | |
| 134 | (return-from import-module-internal nil)) | |
| 133 | ;; (break) | |
| 134 | (return-from import-module-internal nil)) | |
| 135 | 135 | (when (eq module submodule) |
| 136 | (with-output-chaos-error ('invalid-import) | |
| 137 | (princ "module cannot import itself!") | |
| 138 | )) | |
| 136 | (with-output-chaos-error ('invalid-import) | |
| 137 | (princ "module cannot import itself!") | |
| 138 | )) | |
| 139 | 139 | |
| 140 | 140 | ;; compile submodule if need |
| 141 | 141 | (compile-module submodule) |
| 142 | 142 | ;; |
| 143 | 143 | (symbol-table-add (module-symbol-table module) |
| 144 | (if alias | |
| 145 | alias | |
| 146 | (module-name submodule)) | |
| 147 | submodule) | |
| 144 | (if alias | |
| 145 | alias | |
| 146 | (module-name submodule)) | |
| 147 | submodule) | |
| 148 | 148 | ;; |
| 149 | 149 | #|| |
| 150 | 150 | (when (and *include-bool* |
| 151 | (assq *bool-module* | |
| 152 | (module-all-submodules submodule))) | |
| 153 | (include-bool module)) | |
| 151 | (assq *bool-module* | |
| 152 | (module-all-submodules submodule))) | |
| 153 | (include-bool module)) | |
| 154 | 154 | ||# |
| 155 | 155 | ;; |
| 156 | 156 | (with-in-module (module) |
| 157 | ;; | |
| 158 | ;; | |
| 159 | (if parameter | |
| 160 | ;; PARAMETERIZED MODULE IMPORTATION. | |
| 161 | ;; We carete a new module with name `(formal-name "::" module-object)' | |
| 162 | ;; where, formal-name is the name of formal parameter name (we get | |
| 163 | ;; this as the argument param), module-object is the object of | |
| 164 | ;; submodule to be imported as parameter theory. | |
| 165 | ;; The `parameters' module will be updated to including this | |
| 166 | ;; importation, each entry is is the form of | |
| 167 | ;; `((formal-name . parameter-module) . mode) | |
| 168 | (let ((true-name (list parameter "::" submodule module)) | |
| 169 | (*include-bool* (if (memq *bool-sort* (module-all-sorts submodule)) | |
| 170 | t | |
| 171 | nil))) | |
| 172 | (let ((param-mod (create-renamed-module-2 submodule true-name module))) | |
| 173 | ;; register it to local environment. | |
| 174 | (add-modexp-local-defn (list parameter (module-name module)) | |
| 175 | param-mod) | |
| 176 | (push (cons (cons parameter param-mod) mode) | |
| 177 | (module-parameters module)) | |
| 178 | (import-module-internal module mode param-mod) | |
| 179 | )) | |
| 180 | ;; | |
| 181 | ;; NON PARAMETERIZED MODULE IMPORTATION. | |
| 182 | ;; | |
| 183 | (if (or (eq :using mode) | |
| 184 | (not (is-directly-using submodule *current-module*))) | |
| 185 | (let* ((subs (module-all-submodules module)) | |
| 186 | (val (assq submodule subs))) | |
| 187 | (when val | |
| 188 | (let ((real-mode (get-real-importing-mode submodule module))) | |
| 189 | (if (and *check-import-mode* | |
| 190 | (not (or (eq real-mode :using) | |
| 191 | (eq (cdr val) :using))) | |
| 192 | (not (eq mode real-mode))) | |
| 193 | (with-output-chaos-error ('import-error) | |
| 194 | (format t "module ~a is already imported into ~a" | |
| 195 | (make-module-print-name submodule) | |
| 196 | (make-module-print-name module)) | |
| 197 | (print-next) | |
| 198 | (format t "with the effective mode : ~a," real-mode) | |
| 199 | (print-next) | |
| 200 | (format t "this conflicts to the new mode : ~a." mode) | |
| 201 | ) | |
| 202 | ;; we omit this importation | |
| 203 | (progn | |
| 204 | (when *on-import-debug* | |
| 205 | (format t "~&module is already imported, skipping..")) | |
| 206 | (return-from import-module-internal t) | |
| 207 | )) | |
| 208 | )) | |
| 209 | (when *check-import-mode* | |
| 210 | ;; other more complex importation check. | |
| 211 | ;; checks confliction among shared submodules. | |
| 212 | (let ((s-subs (mapcar #'car | |
| 213 | (module-all-submodules submodule)))) | |
| 214 | (dolist (ms subs) | |
| 215 | (when (memq (car ms) s-subs) | |
| 216 | (let ((m1 (get-real-importing-mode (car ms) module)) | |
| 217 | (m2 (get-real-importing-mode (car ms) submodule))) | |
| 218 | (unless (eq m1 m2) | |
| 219 | (if (or (memq m1 '(:?extending :extending)) | |
| 220 | (memq m2 '(:?extending :extending))) | |
| 221 | ;; | |
| 222 | nil ; do nothing now | |
| 223 | (when (not (or (eq m1 :using) | |
| 224 | (eq m2 :using))) | |
| 225 | (with-output-chaos-error ('import-error) | |
| 226 | (format t "confliction in importation mode of common submodule ~a" | |
| 227 | (get-module-print-name (car ms))) | |
| 228 | (print-next) | |
| 229 | (format t "module ~a already imports with effective mode ~a," | |
| 230 | (get-module-print-name module) | |
| 231 | m1) | |
| 232 | (print-next) | |
| 233 | (format t "module ~a imports with effective mode ~a." | |
| 234 | (get-module-print-name submodule) | |
| 235 | m2) | |
| 236 | ))))))))) | |
| 237 | ||
| 238 | ;; `incorporate-module' do the real importation. | |
| 239 | (incorporate-module module mode submodule theory-mod) | |
| 240 | ||
| 241 | ;; imported modules are stored at `module-submodules' in a form | |
| 242 | ;; (<module> <mode>), <mode> is one of :protecting, :extending, | |
| 243 | ;; :using, and :including. | |
| 244 | (add-imported-module module mode submodule) | |
| 245 | ;; | |
| 246 | module) | |
| 247 | ||
| 248 | ;; MUTUALLY RECURSIVE CASE. | |
| 249 | ;; imported module refers some constructs of importing module. | |
| 250 | ;; current-module --> variant | |
| 251 | ;; | |
| 252 | (let ((newmod (make-module :name (module-name module))) | |
| 253 | (modname (module-name module)) | |
| 254 | (submod module)) | |
| 255 | (initialize-module newmod) | |
| 256 | (setf (module-parameters newmod) | |
| 257 | (module-parameters module)) | |
| 258 | (setf *current-module* newmod) | |
| 259 | (setf *current-sort-order* (module-sort-order newmod)) | |
| 260 | (setf *current-opinfo-table* (module-opinfo-table newmod)) | |
| 261 | (let ((subname (create-variant-name newmod submod))) | |
| 262 | (setf (module-name submod) subname) | |
| 263 | ;; (add-canon-modexp subname subname) | |
| 264 | (modexp-update-name subname submod)) | |
| 265 | (final-setup submod) | |
| 266 | (add-modexp-defn modname newmod) | |
| 267 | (add-imported-module newmod :protecting submod) | |
| 268 | (incorporate-module newmod :protecting submod) | |
| 269 | (add-imported-module newmod mode submodule) | |
| 270 | (incorporate-module newmod mode submodule) | |
| 271 | (dolist (par (module-parameters newmod)) | |
| 272 | (add-imported-module newmod (cdr par)(cdar par)) | |
| 273 | (incorporate-module newmod (cdr par) (cdar par))) | |
| 274 | (unless *chaos-quiet* (princ ")" *error-output*)) | |
| 275 | newmod))) | |
| 276 | )))) | |
| 157 | ;; | |
| 158 | ;; | |
| 159 | (if parameter | |
| 160 | ;; PARAMETERIZED MODULE IMPORTATION. | |
| 161 | ;; We carete a new module with name `(formal-name "::" module-object)' | |
| 162 | ;; where, formal-name is the name of formal parameter name (we get | |
| 163 | ;; this as the argument param), module-object is the object of | |
| 164 | ;; submodule to be imported as parameter theory. | |
| 165 | ;; The `parameters' module will be updated to including this | |
| 166 | ;; importation, each entry is is the form of | |
| 167 | ;; `((formal-name . parameter-module) . mode) | |
| 168 | (let ((true-name (list parameter "::" submodule module)) | |
| 169 | (*include-bool* (if (memq *bool-sort* (module-all-sorts submodule)) | |
| 170 | t | |
| 171 | nil))) | |
| 172 | (let ((param-mod (create-renamed-module-2 submodule true-name module))) | |
| 173 | ;; register it to local environment. | |
| 174 | (add-modexp-local-defn (list parameter (module-name module)) | |
| 175 | param-mod) | |
| 176 | (push (cons (cons parameter param-mod) mode) | |
| 177 | (module-parameters module)) | |
| 178 | (import-module-internal module mode param-mod) | |
| 179 | )) | |
| 180 | ;; | |
| 181 | ;; NON PARAMETERIZED MODULE IMPORTATION. | |
| 182 | ;; | |
| 183 | (if (or (eq :using mode) | |
| 184 | (not (is-directly-using submodule *current-module*))) | |
| 185 | (let* ((subs (module-all-submodules module)) | |
| 186 | (val (assq submodule subs))) | |
| 187 | (when val | |
| 188 | (let ((real-mode (get-real-importing-mode submodule module))) | |
| 189 | (if (and *check-import-mode* | |
| 190 | (not (or (eq real-mode :using) | |
| 191 | (eq (cdr val) :using))) | |
| 192 | (not (eq mode real-mode))) | |
| 193 | (with-output-chaos-error ('import-error) | |
| 194 | (format t "module ~a is already imported into ~a" | |
| 195 | (make-module-print-name submodule) | |
| 196 | (make-module-print-name module)) | |
| 197 | (print-next) | |
| 198 | (format t "with the effective mode : ~a," real-mode) | |
| 199 | (print-next) | |
| 200 | (format t "this conflicts to the new mode : ~a." mode) | |
| 201 | ) | |
| 202 | ;; we omit this importation | |
| 203 | (progn | |
| 204 | (when *on-import-debug* | |
| 205 | (format t "~&module is already imported, skipping..")) | |
| 206 | (return-from import-module-internal t) | |
| 207 | )) | |
| 208 | )) | |
| 209 | (when *check-import-mode* | |
| 210 | ;; other more complex importation check. | |
| 211 | ;; checks confliction among shared submodules. | |
| 212 | (let ((s-subs (mapcar #'car | |
| 213 | (module-all-submodules submodule)))) | |
| 214 | (dolist (ms subs) | |
| 215 | (when (memq (car ms) s-subs) | |
| 216 | (let ((m1 (get-real-importing-mode (car ms) module)) | |
| 217 | (m2 (get-real-importing-mode (car ms) submodule))) | |
| 218 | (unless (eq m1 m2) | |
| 219 | (if (or (memq m1 '(:?extending :extending)) | |
| 220 | (memq m2 '(:?extending :extending))) | |
| 221 | ;; | |
| 222 | nil ; do nothing now | |
| 223 | (when (not (or (eq m1 :using) | |
| 224 | (eq m2 :using))) | |
| 225 | (with-output-chaos-error ('import-error) | |
| 226 | (format t "confliction in importation mode of common submodule ~a" | |
| 227 | (get-module-print-name (car ms))) | |
| 228 | (print-next) | |
| 229 | (format t "module ~a already imports with effective mode ~a," | |
| 230 | (get-module-print-name module) | |
| 231 | m1) | |
| 232 | (print-next) | |
| 233 | (format t "module ~a imports with effective mode ~a." | |
| 234 | (get-module-print-name submodule) | |
| 235 | m2) | |
| 236 | ))))))))) | |
| 237 | ||
| 238 | ;; `incorporate-module' do the real importation. | |
| 239 | (incorporate-module module mode submodule theory-mod) | |
| 240 | ||
| 241 | ;; imported modules are stored at `module-submodules' in a form | |
| 242 | ;; (<module> <mode>), <mode> is one of :protecting, :extending, | |
| 243 | ;; :using, and :including. | |
| 244 | (add-imported-module module mode submodule) | |
| 245 | ;; | |
| 246 | module) | |
| 247 | ||
| 248 | ;; MUTUALLY RECURSIVE CASE. | |
| 249 | ;; imported module refers some constructs of importing module. | |
| 250 | ;; current-module --> variant | |
| 251 | ;; | |
| 252 | (let ((newmod (make-module :name (module-name module))) | |
| 253 | (modname (module-name module)) | |
| 254 | (submod module)) | |
| 255 | (initialize-module newmod) | |
| 256 | (setf (module-parameters newmod) | |
| 257 | (module-parameters module)) | |
| 258 | (setf *current-module* newmod) | |
| 259 | (setf *current-sort-order* (module-sort-order newmod)) | |
| 260 | (setf *current-opinfo-table* (module-opinfo-table newmod)) | |
| 261 | (let ((subname (create-variant-name newmod submod))) | |
| 262 | (setf (module-name submod) subname) | |
| 263 | ;; (add-canon-modexp subname subname) | |
| 264 | (modexp-update-name subname submod)) | |
| 265 | (final-setup submod) | |
| 266 | (add-modexp-defn modname newmod) | |
| 267 | (add-imported-module newmod :protecting submod) | |
| 268 | (incorporate-module newmod :protecting submod) | |
| 269 | (add-imported-module newmod mode submodule) | |
| 270 | (incorporate-module newmod mode submodule) | |
| 271 | (dolist (par (module-parameters newmod)) | |
| 272 | (add-imported-module newmod (cdr par)(cdar par)) | |
| 273 | (incorporate-module newmod (cdr par) (cdar par))) | |
| 274 | (unless *chaos-quiet* (princ ")" *error-output*)) | |
| 275 | newmod))) | |
| 276 | )))) | |
| 277 | 277 | |
| 278 | 278 | ;;; INCORPORATE-MODULE : Module Mode SubModule -> Module' |
| 279 | 279 | ;;; Do the importation. |
| 287 | 287 | (defun incorporate-module (module mode submodule &optional theory-mod) |
| 288 | 288 | (if (memq mode '(:protecting :extending :including)) |
| 289 | 289 | (prog1 (incorporate-module-sharing module submodule theory-mod) |
| 290 | (when (eq mode :including) | |
| 291 | (when (and (module-psort-declaration submodule) | |
| 292 | (null (module-psort-declaration module))) | |
| 293 | (setf (module-psort-declaration module) | |
| 294 | (copy-tree (module-psort-declaration submodule)))))) | |
| 290 | (when (eq mode :including) | |
| 291 | (when (and (module-psort-declaration submodule) | |
| 292 | (null (module-psort-declaration module))) | |
| 293 | (setf (module-psort-declaration module) | |
| 294 | (copy-tree (module-psort-declaration submodule)))))) | |
| 295 | 295 | (incorporate-module-copying module submodule nil theory-mod))) |
| 296 | 296 | |
| 297 | 297 | (defun make-sort-ref-if-need (sref) |
| 308 | 308 | ;;----------------------------------------------- |
| 309 | 309 | ;; import sorts |
| 310 | 310 | (dolist (s (reverse (module-all-sorts submodule))) |
| 311 | ;; we imports only sorts user declared. | |
| 312 | (unless (sort-is-for-regularity? s submodule) | |
| 313 | (add-sort-to-module s module))) | |
| 311 | ;; we imports only sorts user declared. | |
| 312 | (unless (sort-is-for-regularity? s submodule) | |
| 313 | (add-sort-to-module s module))) | |
| 314 | 314 | ;; import error-sorts |
| 315 | 315 | #|| |
| 316 | 316 | (dolist (s (module-error-sorts submodule)) |
| 317 | (pushnew s (module-error-sorts module) :test #'eq)) | |
| 317 | (pushnew s (module-error-sorts module) :test #'eq)) | |
| 318 | 318 | ||# |
| 319 | 319 | ;; import sort relations |
| 320 | 320 | (let ((so (module-sort-order module))) |
| 321 | (dolist (sl (module-sort-relations submodule)) | |
| 322 | (let ((new-sl (elim-sys-sorts-from-relation sl))) | |
| 323 | (when new-sl | |
| 324 | (adjoin-sort-relation new-sl module) | |
| 325 | (add-relation-to-order new-sl so))))) | |
| 321 | (dolist (sl (module-sort-relations submodule)) | |
| 322 | (let ((new-sl (elim-sys-sorts-from-relation sl))) | |
| 323 | (when new-sl | |
| 324 | (adjoin-sort-relation new-sl module) | |
| 325 | (add-relation-to-order new-sl so))))) | |
| 326 | 326 | ;; at this point, we want |
| 327 | 327 | ;; import operators + axioms. |
| 328 | 328 | (setf (module-methods-with-rwl-axiom module) |
| 329 | (delete-duplicates (append (module-methods-with-rwl-axiom module) | |
| 330 | (module-methods-with-rwl-axiom | |
| 331 | submodule)) | |
| 332 | :test #'eq)) | |
| 329 | (delete-duplicates (append (module-methods-with-rwl-axiom module) | |
| 330 | (module-methods-with-rwl-axiom | |
| 331 | submodule)) | |
| 332 | :test #'eq)) | |
| 333 | 333 | (setf (module-rules-with-rwl-axiom module) |
| 334 | (delete-duplicates (append (module-rules-with-rwl-axiom module) | |
| 335 | (module-rules-with-rwl-axiom submodule)) | |
| 336 | :test #'eq)) | |
| 334 | (delete-duplicates (append (module-rules-with-rwl-axiom module) | |
| 335 | (module-rules-with-rwl-axiom submodule)) | |
| 336 | :test #'eq)) | |
| 337 | 337 | (let ((opinfos (module-all-operators submodule))) |
| 338 | (dolist (opinfo opinfos) | |
| 339 | (transfer-operator module submodule opinfo nil theory-mod)) | |
| 340 | ) | |
| 338 | (dolist (opinfo opinfos) | |
| 339 | (transfer-operator module submodule opinfo nil theory-mod)) | |
| 340 | ) | |
| 341 | 341 | ;; #|| |
| 342 | 342 | ;; import error operators which might be reused. |
| 343 | 343 | (dolist (em (module-error-methods submodule)) |
| 344 | (pushnew em (module-error-methods module) :test #'eq)) | |
| 344 | (pushnew em (module-error-methods module) :test #'eq)) | |
| 345 | 345 | ;; ||# |
| 346 | 346 | ;; user defined error ops ----- |
| 347 | 347 | #|| |
| 348 | 348 | (when (module-error-op-decl submodule) |
| 349 | (when *on-import-debug* | |
| 350 | (format t "~&** importing error operator decl.") | |
| 351 | (dolist (edecl (module-error-op-decl submodule)) | |
| 352 | (print edecl))) | |
| 353 | (let ((eops (copy-tree (module-error-op-decl submodule)))) | |
| 354 | (dolist (ed eops) | |
| 355 | (let ((e-coarity (let ((sref (make-sort-ref-if-need (%op-decl-coarity ed)))) | |
| 356 | (setf (%sort-ref-qualifier sref) submodule) | |
| 357 | sref)) | |
| 358 | (e-arity (mapcar #'(lambda (x) | |
| 359 | (let ((sref (make-sort-ref-if-need x))) | |
| 360 | (setf (%sort-ref-qualifier sref) submodule) | |
| 361 | sref)) | |
| 362 | (%op-decl-arity ed))) | |
| 363 | ) | |
| 364 | (setf (%op-decl-arity ed) e-arity) | |
| 365 | (setf (%op-decl-coarity ed) e-coarity) | |
| 366 | )) | |
| 367 | (setf (module-error-op-decl module) | |
| 368 | (nconc (module-error-op-decl module) eops)) | |
| 369 | )) | |
| 349 | (when *on-import-debug* | |
| 350 | (format t "~&** importing error operator decl.") | |
| 351 | (dolist (edecl (module-error-op-decl submodule)) | |
| 352 | (print edecl))) | |
| 353 | (let ((eops (copy-tree (module-error-op-decl submodule)))) | |
| 354 | (dolist (ed eops) | |
| 355 | (let ((e-coarity (let ((sref (make-sort-ref-if-need (%op-decl-coarity ed)))) | |
| 356 | (setf (%sort-ref-qualifier sref) submodule) | |
| 357 | sref)) | |
| 358 | (e-arity (mapcar #'(lambda (x) | |
| 359 | (let ((sref (make-sort-ref-if-need x))) | |
| 360 | (setf (%sort-ref-qualifier sref) submodule) | |
| 361 | sref)) | |
| 362 | (%op-decl-arity ed))) | |
| 363 | ) | |
| 364 | (setf (%op-decl-arity ed) e-arity) | |
| 365 | (setf (%op-decl-coarity ed) e-coarity) | |
| 366 | )) | |
| 367 | (setf (module-error-op-decl module) | |
| 368 | (nconc (module-error-op-decl module) eops)) | |
| 369 | )) | |
| 370 | 370 | ||# |
| 371 | 371 | #|| |
| 372 | 372 | (dolist (edecl (module-error-op-decl submodule)) |
| 373 | (eval-ast edecl)) | |
| 373 | (eval-ast edecl)) | |
| 374 | 374 | ||# |
| 375 | 375 | ;; import macros |
| 376 | 376 | (dolist (macro (module-macros submodule)) |
| 377 | (add-macro-to-module module macro)) | |
| 377 | (add-macro-to-module module macro)) | |
| 378 | 378 | ;; |
| 379 | 379 | ;; all done, anyway ... |
| 380 | 380 | ))) |
| 381 | 381 | |
| 382 | 382 | ;;; import module copying |
| 383 | 383 | (defun incorporate-module-copying (module submodule |
| 384 | &optional | |
| 385 | copy-parameters | |
| 386 | theory-module | |
| 387 | (context-module *current-module*)) | |
| 384 | &optional | |
| 385 | copy-parameters | |
| 386 | theory-module | |
| 387 | (context-module *current-module*)) | |
| 388 | 388 | (let ((*import-local-vars* nil) |
| 389 | (imported-params nil)) | |
| 389 | (imported-params nil)) | |
| 390 | 390 | (labels ((import-recreate-sort (s) |
| 391 | (%copy-sort s module nil t)) | |
| 392 | (using-recreate-sort-if-need (sort_) | |
| 393 | (if (and (eq (sort-module sort_) submodule) | |
| 394 | (not (member sort_ | |
| 395 | (module-sorts-for-regularity submodule)))) | |
| 396 | (or (cdr (assq sort_ *import-sort-map*)) | |
| 397 | (let ((news (import-recreate-sort sort_))) | |
| 398 | (when *on-import-debug* | |
| 399 | (format t "~%[copy] putting ~a to *import-sort-map*" | |
| 400 | (cons sort_ news))) | |
| 401 | (push (cons sort_ news) *import-sort-map*) | |
| 402 | news)) | |
| 403 | sort_)) | |
| 404 | ||
| 405 | (using-find-sort (_sort) | |
| 406 | (or (cdr (assq _sort *import-sort-map*)) _sort)) | |
| 407 | ||
| 408 | ;; for debug | |
| 409 | #|| | |
| 410 | (!using-find-sort (_sort) | |
| 411 | (or (cdr (assq _sort *import-sort-map*)) | |
| 412 | (progn (break) _sort))) | |
| 413 | ||# | |
| 414 | (using-import-var (var) | |
| 415 | (let ((nm (variable-name var)) | |
| 416 | (sort (using-find-sort (variable-sort var)))) | |
| 417 | (let ((val (find-variable-in module nm))) | |
| 418 | (if (and val (not (sort= sort (variable-sort val)))) | |
| 419 | (with-output-chaos-warning () | |
| 420 | (princ "imported variable discarded due to name conflict") | |
| 421 | (print-next) | |
| 422 | (format t "with the existing variable: ~a" nm)) | |
| 423 | (unless val | |
| 424 | (setq val (make-variable-term sort nm)) | |
| 425 | (when *copy-variables* | |
| 426 | (push (cons nm val) (module-variables module))) | |
| 427 | (push (cons nm val) *import-local-vars*) | |
| 428 | ))))) | |
| 429 | ;; | |
| 430 | (using-find-sort-err (s) | |
| 431 | (let ((sort (cdr (assq s *import-sort-map*)))) | |
| 432 | (cond (sort sort) | |
| 433 | ((err-sort-p s) | |
| 434 | (setq sort | |
| 435 | (find-compatible-err-sort s module | |
| 436 | *import-sort-map*)) | |
| 437 | (if sort | |
| 438 | (progn | |
| 439 | (when *on-import-debug* | |
| 440 | (format t "~%-- adding import sort map: ~a" | |
| 441 | (cons s sort))) | |
| 442 | (push (cons s sort) *import-sort-map*) | |
| 443 | sort) | |
| 444 | (with-output-panic-message () | |
| 445 | (format t "could not find compatible error sort of ~a" | |
| 446 | s)))) | |
| 447 | (t s)))) | |
| 448 | ;; | |
| 449 | (using-recreate-term (term) | |
| 450 | (cond ((term-is-builtin-constant? term) | |
| 451 | (make-bconst-term (using-find-sort-err (term-sort term)) | |
| 452 | (term-builtin-value term))) | |
| 453 | ((term-is-variable? term) | |
| 454 | (let ((var-name (variable-name term)) | |
| 455 | (new-sort (using-find-sort-err (variable-sort term)))) | |
| 456 | (let ((val2 (assq var-name *import-local-vars*))) | |
| 457 | (if (and val2 (sort= new-sort | |
| 458 | (variable-sort (cdr val2)))) | |
| 459 | (cdr val2) | |
| 460 | (let ((new-var (make-variable-term | |
| 461 | new-sort var-name))) | |
| 462 | (push (cons var-name new-var) | |
| 463 | *import-local-vars*) | |
| 464 | new-var)))) | |
| 465 | ) | |
| 466 | ((term-is-lisp-form? term) term) | |
| 467 | (t (let ((head (term-head term))) | |
| 468 | (let ((new-head | |
| 469 | (find-method-in | |
| 470 | module | |
| 471 | (method-symbol head) | |
| 472 | (mapcar #'(lambda (x) | |
| 473 | (using-find-sort-err x)) | |
| 474 | (method-arity head)) | |
| 475 | (using-find-sort-err | |
| 476 | (method-coarity head))))) | |
| 477 | (when (null new-head) | |
| 478 | (when *on-import-debug* | |
| 479 | (format t "~&!! recreate-term null new-head") | |
| 480 | (with-in-module (module) | |
| 481 | (print-chaos-object head) | |
| 482 | (format t "~% arity = ~a" (method-arity head)) | |
| 483 | (format t "~% coarity = ~a" | |
| 484 | (method-coarity head)))) | |
| 485 | (setq new-head head)) | |
| 486 | (make-applform (method-coarity new-head) | |
| 487 | new-head | |
| 488 | (mapcar #'(lambda (tm) | |
| 489 | (using-recreate-term tm)) | |
| 490 | (term-subterms term)))))))) | |
| 491 | (using-recreate-axiom (axiom) | |
| 492 | (make-rule :lhs (using-recreate-term (axiom-lhs axiom)) | |
| 493 | :rhs (using-recreate-term (axiom-rhs axiom)) | |
| 494 | :condition (if (is-true? (axiom-condition axiom)) | |
| 495 | *bool-true* | |
| 496 | (using-recreate-term (axiom-condition axiom))) | |
| 497 | :labels (axiom-labels axiom) | |
| 498 | :type (axiom-type axiom) | |
| 499 | :behavioural (axiom-is-behavioural axiom) | |
| 500 | :kind (axiom-kind axiom) | |
| 501 | :meta-and-or (axiom-meta-and-or axiom))) | |
| 502 | ;; | |
| 503 | (using-import-sub (s mode) | |
| 504 | (let ((subs (module-all-submodules module))) | |
| 505 | (unless (assq s subs) | |
| 506 | (if (module-is-parameter-theory s) | |
| 507 | (let ((param-mod s) | |
| 508 | (arg-name (car (module-name s)))) | |
| 509 | (push param-mod imported-params) | |
| 510 | (if (and copy-parameters | |
| 511 | (not (eq (fourth (module-name s)) | |
| 512 | context-module))) | |
| 513 | (import-module-internal module | |
| 514 | mode | |
| 515 | param-mod | |
| 516 | arg-name | |
| 517 | module) | |
| 518 | (progn | |
| 519 | (import-module-internal module | |
| 520 | mode | |
| 521 | param-mod | |
| 522 | nil | |
| 523 | (or theory-module | |
| 524 | submodule)) | |
| 525 | (add-modexp-local-defn (list arg-name | |
| 526 | (module-name module)) | |
| 527 | param-mod) | |
| 528 | (push (cons (cons arg-name param-mod) mode) | |
| 529 | (module-parameters module)) | |
| 530 | ))) | |
| 531 | (if (eq mode :using) | |
| 532 | (using-import-subs s) | |
| 533 | (import-module-internal module | |
| 534 | mode | |
| 535 | s | |
| 536 | nil | |
| 537 | (or theory-module submodule))) | |
| 538 | )))) | |
| 539 | (using-import-subs (smod) | |
| 540 | (dolist (s (reverse (module-direct-submodules smod))) | |
| 541 | (using-import-sub (car s) (cdr s)))) | |
| 542 | ) | |
| 391 | (%copy-sort s module nil t)) | |
| 392 | (using-recreate-sort-if-need (sort_) | |
| 393 | (if (and (eq (sort-module sort_) submodule) | |
| 394 | (not (member sort_ | |
| 395 | (module-sorts-for-regularity submodule)))) | |
| 396 | (or (cdr (assq sort_ *import-sort-map*)) | |
| 397 | (let ((news (import-recreate-sort sort_))) | |
| 398 | (when *on-import-debug* | |
| 399 | (format t "~%[copy] putting ~a to *import-sort-map*" | |
| 400 | (cons sort_ news))) | |
| 401 | (push (cons sort_ news) *import-sort-map*) | |
| 402 | news)) | |
| 403 | sort_)) | |
| 404 | ||
| 405 | (using-find-sort (_sort) | |
| 406 | (or (cdr (assq _sort *import-sort-map*)) _sort)) | |
| 407 | ||
| 408 | ;; for debug | |
| 409 | #|| | |
| 410 | (!using-find-sort (_sort) | |
| 411 | (or (cdr (assq _sort *import-sort-map*)) | |
| 412 | (progn (break) _sort))) | |
| 413 | ||# | |
| 414 | (using-import-var (var) | |
| 415 | (let ((nm (variable-name var)) | |
| 416 | (sort (using-find-sort (variable-sort var)))) | |
| 417 | (let ((val (find-variable-in module nm))) | |
| 418 | (if (and val (not (sort= sort (variable-sort val)))) | |
| 419 | (with-output-chaos-warning () | |
| 420 | (princ "imported variable discarded due to name conflict") | |
| 421 | (print-next) | |
| 422 | (format t "with the existing variable: ~a" nm)) | |
| 423 | (unless val | |
| 424 | (setq val (make-variable-term sort nm)) | |
| 425 | (when *copy-variables* | |
| 426 | (push (cons nm val) (module-variables module))) | |
| 427 | (push (cons nm val) *import-local-vars*) | |
| 428 | ))))) | |
| 429 | ;; | |
| 430 | (using-find-sort-err (s) | |
| 431 | (let ((sort (cdr (assq s *import-sort-map*)))) | |
| 432 | (cond (sort sort) | |
| 433 | ((err-sort-p s) | |
| 434 | (setq sort | |
| 435 | (find-compatible-err-sort s module | |
| 436 | *import-sort-map*)) | |
| 437 | (if sort | |
| 438 | (progn | |
| 439 | (when *on-import-debug* | |
| 440 | (format t "~%-- adding import sort map: ~a" | |
| 441 | (cons s sort))) | |
| 442 | (push (cons s sort) *import-sort-map*) | |
| 443 | sort) | |
| 444 | (with-output-panic-message () | |
| 445 | (format t "could not find compatible error sort of ~a" | |
| 446 | s)))) | |
| 447 | (t s)))) | |
| 448 | ;; | |
| 449 | (using-recreate-term (term) | |
| 450 | (cond ((term-is-builtin-constant? term) | |
| 451 | (make-bconst-term (using-find-sort-err (term-sort term)) | |
| 452 | (term-builtin-value term))) | |
| 453 | ((term-is-variable? term) | |
| 454 | (let ((var-name (variable-name term)) | |
| 455 | (new-sort (using-find-sort-err (variable-sort term)))) | |
| 456 | (let ((val2 (assq var-name *import-local-vars*))) | |
| 457 | (if (and val2 (sort= new-sort | |
| 458 | (variable-sort (cdr val2)))) | |
| 459 | (cdr val2) | |
| 460 | (let ((new-var (make-variable-term | |
| 461 | new-sort var-name))) | |
| 462 | (push (cons var-name new-var) | |
| 463 | *import-local-vars*) | |
| 464 | new-var)))) | |
| 465 | ) | |
| 466 | ((term-is-lisp-form? term) term) | |
| 467 | (t (let ((head (term-head term))) | |
| 468 | (let ((new-head | |
| 469 | (find-method-in | |
| 470 | module | |
| 471 | (method-symbol head) | |
| 472 | (mapcar #'(lambda (x) | |
| 473 | (using-find-sort-err x)) | |
| 474 | (method-arity head)) | |
| 475 | (using-find-sort-err | |
| 476 | (method-coarity head))))) | |
| 477 | (when (null new-head) | |
| 478 | (when *on-import-debug* | |
| 479 | (format t "~&!! recreate-term null new-head") | |
| 480 | (with-in-module (module) | |
| 481 | (print-chaos-object head) | |
| 482 | (format t "~% arity = ~a" (method-arity head)) | |
| 483 | (format t "~% coarity = ~a" | |
| 484 | (method-coarity head)))) | |
| 485 | (setq new-head head)) | |
| 486 | (make-applform (method-coarity new-head) | |
| 487 | new-head | |
| 488 | (mapcar #'(lambda (tm) | |
| 489 | (using-recreate-term tm)) | |
| 490 | (term-subterms term)))))))) | |
| 491 | (using-recreate-axiom (axiom) | |
| 492 | (make-rule :lhs (using-recreate-term (axiom-lhs axiom)) | |
| 493 | :rhs (using-recreate-term (axiom-rhs axiom)) | |
| 494 | :condition (if (is-true? (axiom-condition axiom)) | |
| 495 | *bool-true* | |
| 496 | (using-recreate-term (axiom-condition axiom))) | |
| 497 | :labels (axiom-labels axiom) | |
| 498 | :type (axiom-type axiom) | |
| 499 | :behavioural (axiom-is-behavioural axiom) | |
| 500 | :kind (axiom-kind axiom) | |
| 501 | :meta-and-or (axiom-meta-and-or axiom))) | |
| 502 | ;; | |
| 503 | (using-import-sub (s mode) | |
| 504 | (let ((subs (module-all-submodules module))) | |
| 505 | (unless (assq s subs) | |
| 506 | (if (module-is-parameter-theory s) | |
| 507 | (let ((param-mod s) | |
| 508 | (arg-name (car (module-name s)))) | |
| 509 | (push param-mod imported-params) | |
| 510 | (if (and copy-parameters | |
| 511 | (not (eq (fourth (module-name s)) | |
| 512 | context-module))) | |
| 513 | (import-module-internal module | |
| 514 | mode | |
| 515 | param-mod | |
| 516 | arg-name | |
| 517 | module) | |
| 518 | (progn | |
| 519 | (import-module-internal module | |
| 520 | mode | |
| 521 | param-mod | |
| 522 | nil | |
| 523 | (or theory-module | |
| 524 | submodule)) | |
| 525 | (add-modexp-local-defn (list arg-name | |
| 526 | (module-name module)) | |
| 527 | param-mod) | |
| 528 | (push (cons (cons arg-name param-mod) mode) | |
| 529 | (module-parameters module)) | |
| 530 | ))) | |
| 531 | (if (eq mode :using) | |
| 532 | (using-import-subs s) | |
| 533 | (import-module-internal module | |
| 534 | mode | |
| 535 | s | |
| 536 | nil | |
| 537 | (or theory-module submodule))) | |
| 538 | )))) | |
| 539 | (using-import-subs (smod) | |
| 540 | (dolist (s (reverse (module-direct-submodules smod))) | |
| 541 | (using-import-sub (car s) (cdr s)))) | |
| 542 | ) | |
| 543 | 543 | ;; |
| 544 | 544 | (with-in-module (module) |
| 545 | ;; *NOTE* : the follwing code is executed in the context of given | |
| 546 | ;; `module' = *current-module*. | |
| 547 | ;; | |
| 548 | ;; import submodules of submodule | |
| 549 | ;; | |
| 550 | (using-import-subs submodule) | |
| 551 | ;; | |
| 552 | ;; import sorts of submodule recreating | |
| 553 | ;; | |
| 554 | (dolist (s (reverse (module-sorts submodule))) | |
| 555 | ; sorts of sub-sumodules should already be | |
| 556 | ; imported at this point. | |
| 557 | (let ((new-sort (using-recreate-sort-if-need s))) | |
| 558 | ; thus, `if-need' is redundant though.. | |
| 559 | (when new-sort | |
| 560 | (add-sort-to-module new-sort module)))) | |
| 561 | ;; | |
| 562 | ;; reconstruct sort relations | |
| 563 | ;; | |
| 564 | (let ((so (module-sort-order module))) | |
| 565 | (dolist (rel (module-sort-relations submodule)) | |
| 566 | (let* ((new-rel (elim-sys-sorts-from-relation rel)) | |
| 567 | (xnew-rel (when new-rel | |
| 568 | (make-sort-relation | |
| 569 | (using-find-sort (sort-relation-sort new-rel)) | |
| 570 | (mapcar #'(lambda (x) (using-find-sort x)) | |
| 571 | (_subsorts new-rel)) | |
| 572 | (mapcar #'(lambda (x) (using-find-sort x)) | |
| 573 | (_supersorts new-rel)))))) | |
| 574 | (when xnew-rel | |
| 575 | (adjoin-sort-relation xnew-rel module)) | |
| 576 | (add-relation-to-order xnew-rel so))) | |
| 577 | (generate-err-sorts so) | |
| 578 | ) | |
| 579 | ;; | |
| 580 | ;; import operators(methods) copying | |
| 581 | ;; | |
| 582 | (dolist (opinfo (reverse (module-all-operators submodule))) | |
| 583 | ; again, operators(methods) of | |
| 584 | ; sub-submodules already be imported at | |
| 585 | ; this point. | |
| 586 | ; BUT, operator object is not created | |
| 587 | ; iff strictly overloaded. thus we must | |
| 588 | ; check ALL operators. | |
| 589 | (let ((op-symbol (operator-symbol (opinfo-operator opinfo)))) | |
| 590 | (dolist (meth (opinfo-methods opinfo)) | |
| 591 | (if (eq submodule (method-module meth)) | |
| 592 | (when (or ;; (method-is-user-defined-error-method meth) | |
| 593 | (and (not (method-is-error-method meth)) | |
| 594 | (not (method-is-user-defined-error-method meth)) | |
| 595 | (not (memq meth | |
| 596 | (module-methods-for-regularity | |
| 597 | submodule))))) | |
| 598 | (let* ((new-arity (mapcar #'(lambda (x) | |
| 599 | (using-find-sort-err x)) | |
| 600 | (method-arity meth))) | |
| 601 | (new-coarity (using-find-sort-err | |
| 602 | (method-coarity meth))) | |
| 603 | #|| | |
| 604 | (new-meth (recreate-method | |
| 605 | submodule | |
| 606 | meth | |
| 607 | module | |
| 608 | op-symbol | |
| 609 | (mapcar #'(lambda (x) | |
| 610 | (using-find-sort-err x)) | |
| 611 | (method-arity meth)) | |
| 612 | (using-find-sort-err | |
| 613 | (method-coarity meth)))) | |
| 614 | ||# | |
| 615 | (new-meth nil) | |
| 616 | ) | |
| 617 | (when *on-import-debug* | |
| 618 | (format t "~%* trying to make new method ~a:" | |
| 619 | op-symbol) | |
| 620 | (format t "~% arity = ~a" new-arity) | |
| 621 | (format t "~% coarity = ~a" new-coarity)) | |
| 622 | (setq new-meth (recreate-method submodule | |
| 623 | meth | |
| 624 | module | |
| 625 | op-symbol | |
| 626 | new-arity | |
| 627 | new-coarity | |
| 628 | *import-sort-map*)) | |
| 629 | (when *on-import-debug* | |
| 630 | (format t "~%* created method ~a: " new-meth) | |
| 631 | (print-chaos-object new-meth)) | |
| 632 | ;; check identity in theory | |
| 633 | (let ((theory (method-theory meth (module-opinfo-table | |
| 634 | submodule)))) | |
| 635 | (when (theory-contains-identity theory) | |
| 636 | (let ((zero (theory-zero theory))) | |
| 637 | (setq zero (cons (using-recreate-term (car zero)) | |
| 638 | (cdr zero))) | |
| 639 | (setf (method-theory new-meth) | |
| 640 | (theory-make (theory-info theory) zero)) | |
| 641 | (compute-method-theory-info-for-matching new-meth) | |
| 642 | ))) | |
| 643 | )) | |
| 644 | )))) | |
| 645 | ;; | |
| 646 | ;; dumn it! | |
| 647 | ;; | |
| 648 | (dolist (e (reverse (module-opattrs submodule))) | |
| 649 | (eval-ast e)) | |
| 650 | ;; | |
| 651 | ;; vertually import variables copying | |
| 652 | ;; | |
| 653 | (dolist (v (nreverse (mapcar #'cdr (module-variables submodule)))) | |
| 654 | (using-import-var v)) | |
| 655 | ;; (setq *import-local-vars* (module-variables module)) | |
| 656 | ;; inherit principal-sort if defined. | |
| 657 | ;;(break) | |
| 658 | (when (and (module-psort-declaration submodule) | |
| 659 | (null (module-psort-declaration module))) | |
| 660 | (setf (module-psort-declaration module) | |
| 661 | (copy-tree (module-psort-declaration submodule)))) | |
| 662 | ;; | |
| 663 | ;; import error operator declarations | |
| 664 | ;; | |
| 665 | ||
| 666 | (when (module-error-op-decl submodule) | |
| 667 | (setf (module-error-op-decl module) | |
| 668 | (nconc (module-error-op-decl module) | |
| 669 | (copy-tree (module-error-op-decl submodule))))) | |
| 670 | ||
| 671 | #|| | |
| 672 | (when (module-error-op-decl submodule) | |
| 673 | (when *on-import-debug* | |
| 674 | (format t "~&** importing error operator decl.") | |
| 675 | (dolist (edecl (module-error-op-decl submodule)) | |
| 676 | (print edecl))) | |
| 677 | (let ((eops (copy-tree (module-error-op-decl submodule)))) | |
| 678 | (dolist (ed eops) | |
| 679 | (let ((e-coarity (let ((sref (make-sort-ref-if-need (%op-decl-coarity ed)))) | |
| 680 | (setf (%sort-ref-qualifier sref) submodule) | |
| 681 | sref)) | |
| 682 | (e-arity (mapcar #'(lambda (x) | |
| 683 | (let ((sref (make-sort-ref-if-need x))) | |
| 684 | (setf (%sort-ref-qualifier sref) submodule) | |
| 685 | sref)) | |
| 686 | (%op-decl-arity ed))) | |
| 687 | ) | |
| 688 | (setf (%op-decl-arity ed) e-arity) | |
| 689 | (setf (%op-decl-coarity ed) e-coarity) | |
| 690 | )) | |
| 691 | (setf (module-error-op-decl module) | |
| 692 | (nconc (module-error-op-decl module) eops)) | |
| 693 | )) | |
| 694 | ||# | |
| 695 | #|| | |
| 696 | (dolist (eop (module-error-op-decl submodule)) | |
| 697 | (when *on-import-debug* | |
| 698 | (with-output-msg () | |
| 699 | (format t "* evaluating imported err op decl:") | |
| 700 | (print-next) (princ " ") | |
| 701 | (print-chaos-object eop))) | |
| 702 | (eval-ast eop)) | |
| 703 | ||# | |
| 704 | ;; | |
| 705 | ;; import variable declarations of error sorts | |
| 706 | ;; | |
| 707 | #|| | |
| 708 | (when (module-error-var-decl submodule) | |
| 709 | (setf (module-error-var-decl module) | |
| 710 | (nconc (module-error-var-decl module) | |
| 711 | (copy-tree (module-error-var-decl submodule))))) | |
| 545 | ;; *NOTE* : the follwing code is executed in the context of given | |
| 546 | ;; `module' = *current-module*. | |
| 547 | ;; | |
| 548 | ;; import submodules of submodule | |
| 549 | ;; | |
| 550 | (using-import-subs submodule) | |
| 551 | ;; | |
| 552 | ;; import sorts of submodule recreating | |
| 553 | ;; | |
| 554 | (dolist (s (reverse (module-sorts submodule))) | |
| 555 | ; sorts of sub-sumodules should already be | |
| 556 | ; imported at this point. | |
| 557 | (let ((new-sort (using-recreate-sort-if-need s))) | |
| 558 | ; thus, `if-need' is redundant though.. | |
| 559 | (when new-sort | |
| 560 | (add-sort-to-module new-sort module)))) | |
| 561 | ;; | |
| 562 | ;; reconstruct sort relations | |
| 563 | ;; | |
| 564 | (let ((so (module-sort-order module))) | |
| 565 | (dolist (rel (module-sort-relations submodule)) | |
| 566 | (let* ((new-rel (elim-sys-sorts-from-relation rel)) | |
| 567 | (xnew-rel (when new-rel | |
| 568 | (make-sort-relation | |
| 569 | (using-find-sort (sort-relation-sort new-rel)) | |
| 570 | (mapcar #'(lambda (x) (using-find-sort x)) | |
| 571 | (_subsorts new-rel)) | |
| 572 | (mapcar #'(lambda (x) (using-find-sort x)) | |
| 573 | (_supersorts new-rel)))))) | |
| 574 | (when xnew-rel | |
| 575 | (adjoin-sort-relation xnew-rel module)) | |
| 576 | (add-relation-to-order xnew-rel so))) | |
| 577 | (generate-err-sorts so) | |
| 578 | ) | |
| 579 | ;; | |
| 580 | ;; import operators(methods) copying | |
| 581 | ;; | |
| 582 | (dolist (opinfo (reverse (module-all-operators submodule))) | |
| 583 | ; again, operators(methods) of | |
| 584 | ; sub-submodules already be imported at | |
| 585 | ; this point. | |
| 586 | ; BUT, operator object is not created | |
| 587 | ; iff strictly overloaded. thus we must | |
| 588 | ; check ALL operators. | |
| 589 | (let ((op-symbol (operator-symbol (opinfo-operator opinfo)))) | |
| 590 | (dolist (meth (opinfo-methods opinfo)) | |
| 591 | (if (eq submodule (method-module meth)) | |
| 592 | (when (or ;; (method-is-user-defined-error-method meth) | |
| 593 | (and (not (method-is-error-method meth)) | |
| 594 | (not (method-is-user-defined-error-method meth)) | |
| 595 | (not (memq meth | |
| 596 | (module-methods-for-regularity | |
| 597 | submodule))))) | |
| 598 | (let* ((new-arity (mapcar #'(lambda (x) | |
| 599 | (using-find-sort-err x)) | |
| 600 | (method-arity meth))) | |
| 601 | (new-coarity (using-find-sort-err | |
| 602 | (method-coarity meth))) | |
| 603 | #|| | |
| 604 | (new-meth (recreate-method | |
| 605 | submodule | |
| 606 | meth | |
| 607 | module | |
| 608 | op-symbol | |
| 609 | (mapcar #'(lambda (x) | |
| 610 | (using-find-sort-err x)) | |
| 611 | (method-arity meth)) | |
| 612 | (using-find-sort-err | |
| 613 | (method-coarity meth)))) | |
| 614 | ||# | |
| 615 | (new-meth nil) | |
| 616 | ) | |
| 617 | (when *on-import-debug* | |
| 618 | (format t "~%* trying to make new method ~a:" | |
| 619 | op-symbol) | |
| 620 | (format t "~% arity = ~a" new-arity) | |
| 621 | (format t "~% coarity = ~a" new-coarity)) | |
| 622 | (setq new-meth (recreate-method submodule | |
| 623 | meth | |
| 624 | module | |
| 625 | op-symbol | |
| 626 | new-arity | |
| 627 | new-coarity | |
| 628 | *import-sort-map*)) | |
| 629 | (when *on-import-debug* | |
| 630 | (format t "~%* created method ~a: " new-meth) | |
| 631 | (print-chaos-object new-meth)) | |
| 632 | ;; check identity in theory | |
| 633 | (let ((theory (method-theory meth (module-opinfo-table | |
| 634 | submodule)))) | |
| 635 | (when (theory-contains-identity theory) | |
| 636 | (let ((zero (theory-zero theory))) | |
| 637 | (setq zero (cons (using-recreate-term (car zero)) | |
| 638 | (cdr zero))) | |
| 639 | (setf (method-theory new-meth) | |
| 640 | (theory-make (theory-info theory) zero)) | |
| 641 | (compute-method-theory-info-for-matching new-meth) | |
| 642 | ))) | |
| 643 | )) | |
| 644 | )))) | |
| 645 | ;; | |
| 646 | ;; dumn it! | |
| 647 | ;; | |
| 648 | (dolist (e (reverse (module-opattrs submodule))) | |
| 649 | (eval-ast e)) | |
| 650 | ;; | |
| 651 | ;; vertually import variables copying | |
| 652 | ;; | |
| 653 | (dolist (v (nreverse (mapcar #'cdr (module-variables submodule)))) | |
| 654 | (using-import-var v)) | |
| 655 | ;; (setq *import-local-vars* (module-variables module)) | |
| 656 | ;; inherit principal-sort if defined. | |
| 657 | ;;(break) | |
| 658 | (when (and (module-psort-declaration submodule) | |
| 659 | (null (module-psort-declaration module))) | |
| 660 | (setf (module-psort-declaration module) | |
| 661 | (copy-tree (module-psort-declaration submodule)))) | |
| 662 | ;; | |
| 663 | ;; import error operator declarations | |
| 664 | ;; | |
| 665 | ||
| 666 | (when (module-error-op-decl submodule) | |
| 667 | (setf (module-error-op-decl module) | |
| 668 | (nconc (module-error-op-decl module) | |
| 669 | (copy-tree (module-error-op-decl submodule))))) | |
| 670 | ||
| 671 | #|| | |
| 672 | (when (module-error-op-decl submodule) | |
| 673 | (when *on-import-debug* | |
| 674 | (format t "~&** importing error operator decl.") | |
| 675 | (dolist (edecl (module-error-op-decl submodule)) | |
| 676 | (print edecl))) | |
| 677 | (let ((eops (copy-tree (module-error-op-decl submodule)))) | |
| 678 | (dolist (ed eops) | |
| 679 | (let ((e-coarity (let ((sref (make-sort-ref-if-need (%op-decl-coarity ed)))) | |
| 680 | (setf (%sort-ref-qualifier sref) submodule) | |
| 681 | sref)) | |
| 682 | (e-arity (mapcar #'(lambda (x) | |
| 683 | (let ((sref (make-sort-ref-if-need x))) | |
| 684 | (setf (%sort-ref-qualifier sref) submodule) | |
| 685 | sref)) | |
| 686 | (%op-decl-arity ed))) | |
| 687 | ) | |
| 688 | (setf (%op-decl-arity ed) e-arity) | |
| 689 | (setf (%op-decl-coarity ed) e-coarity) | |
| 690 | )) | |
| 691 | (setf (module-error-op-decl module) | |
| 692 | (nconc (module-error-op-decl module) eops)) | |
| 693 | )) | |
| 712 | 694 | ||# |
| 713 | ;; | |
| 714 | ;; copy macros | |
| 715 | ;; | |
| 716 | (dolist (macro (module-macros submodule)) | |
| 717 | (let ((new-macro (make-macro :lhs (using-recreate-term | |
| 718 | (macro-lhs macro)) | |
| 719 | :rhs (using-recreate-term | |
| 720 | (macro-rhs macro))))) | |
| 721 | ;; (print macro) | |
| 722 | (add-macro-to-module module new-macro))) | |
| 723 | ||
| 724 | ;;(eval-psort-declaration (module-psort-declaration submodule) | |
| 725 | ;; module) | |
| 726 | ;; | |
| 727 | ;; import equations & rules copying | |
| 728 | ;; | |
| 729 | (prepare-for-parsing module nil t) | |
| 730 | ;; in this stage, error sorts & methods are all available, | |
| 731 | ;; but there can happen reorganizing operators in different ways, | |
| 732 | ;; thus we need still `check-axiom-error-method'. | |
| 733 | (dolist (e (reverse (module-equations submodule))) | |
| 734 | (adjoin-axiom-to-module module | |
| 735 | (check-axiom-error-method | |
| 736 | module | |
| 737 | (using-recreate-axiom e)) | |
| 738 | )) | |
| 739 | ||
| 740 | (dolist (r (reverse (module-rules submodule))) | |
| 741 | (adjoin-axiom-to-module module | |
| 742 | (check-axiom-error-method | |
| 743 | module | |
| 744 | (using-recreate-axiom r)) | |
| 745 | )) | |
| 746 | ;; | |
| 747 | ;; all done, hopefully | |
| 748 | ;; | |
| 749 | )))) | |
| 695 | #|| | |
| 696 | (dolist (eop (module-error-op-decl submodule)) | |
| 697 | (when *on-import-debug* | |
| 698 | (with-output-msg () | |
| 699 | (format t "* evaluating imported err op decl:") | |
| 700 | (print-next) (princ " ") | |
| 701 | (print-chaos-object eop))) | |
| 702 | (eval-ast eop)) | |
| 703 | ||# | |
| 704 | ;; | |
| 705 | ;; import variable declarations of error sorts | |
| 706 | ;; | |
| 707 | #|| | |
| 708 | (when (module-error-var-decl submodule) | |
| 709 | (setf (module-error-var-decl module) | |
| 710 | (nconc (module-error-var-decl module) | |
| 711 | (copy-tree (module-error-var-decl submodule))))) | |
| 712 | ||# | |
| 713 | ;; | |
| 714 | ;; copy macros | |
| 715 | ;; | |
| 716 | (dolist (macro (module-macros submodule)) | |
| 717 | (let ((new-macro (make-macro :lhs (using-recreate-term | |
| 718 | (macro-lhs macro)) | |
| 719 | :rhs (using-recreate-term | |
| 720 | (macro-rhs macro))))) | |
| 721 | ;; (print macro) | |
| 722 | (add-macro-to-module module new-macro))) | |
| 723 | ||
| 724 | ;;(eval-psort-declaration (module-psort-declaration submodule) | |
| 725 | ;; module) | |
| 726 | ;; | |
| 727 | ;; import equations & rules copying | |
| 728 | ;; | |
| 729 | (prepare-for-parsing module nil t) | |
| 730 | ;; in this stage, error sorts & methods are all available, | |
| 731 | ;; but there can happen reorganizing operators in different ways, | |
| 732 | ;; thus we need still `check-axiom-error-method'. | |
| 733 | (dolist (e (reverse (module-equations submodule))) | |
| 734 | (adjoin-axiom-to-module module | |
| 735 | (check-axiom-error-method | |
| 736 | module | |
| 737 | (using-recreate-axiom e)) | |
| 738 | )) | |
| 739 | ||
| 740 | (dolist (r (reverse (module-rules submodule))) | |
| 741 | (adjoin-axiom-to-module module | |
| 742 | (check-axiom-error-method | |
| 743 | module | |
| 744 | (using-recreate-axiom r)) | |
| 745 | )) | |
| 746 | ;; | |
| 747 | ;; all done, hopefully | |
| 748 | ;; | |
| 749 | )))) | |
| 750 | 750 | |
| 751 | 751 | ;;; TRANSFER-OPERATOR : Module Module OpInfo -> Void |
| 752 | 752 | ;;; |
| 753 | 753 | (defun transfer-operator (module from-module opinfo &optional (given-opinfos nil) |
| 754 | theory-mod) | |
| 754 | theory-mod) | |
| 755 | 755 | (let* ((opinfos given-opinfos) |
| 756 | (from-op (opinfo-operator opinfo)) | |
| 757 | (proto-method (car (opinfo-methods opinfo))) | |
| 758 | (a-len (length (method-arity proto-method))) | |
| 759 | (new-op nil) | |
| 760 | (new-opinfo nil)) | |
| 756 | (from-op (opinfo-operator opinfo)) | |
| 757 | (proto-method (car (opinfo-methods opinfo))) | |
| 758 | (a-len (length (method-arity proto-method))) | |
| 759 | (new-op nil) | |
| 760 | (new-opinfo nil)) | |
| 761 | 761 | ;; |
| 762 | 762 | (when *on-import-debug* |
| 763 | 763 | (format t "~&[transfer-operator]: ~a from " (operator-symbol from-op)) |
| 767 | 767 | ;; |
| 768 | 768 | (unless opinfos |
| 769 | 769 | (setq opinfos (find-operators-in-module (operator-symbol from-op) |
| 770 | a-len | |
| 771 | module))) | |
| 770 | a-len | |
| 771 | module))) | |
| 772 | 772 | ;; |
| 773 | 773 | (with-in-module (module) |
| 774 | 774 | (let ((from-opinfo (module-opinfo-table from-module)) |
| 775 | (to-opinfo (module-opinfo-table module)) | |
| 776 | (so (module-sort-order module))) | |
| 777 | ;; find the method group to be inserted | |
| 778 | #|| | |
| 779 | (dolist (method (opinfo-methods opinfo)) | |
| 780 | (when (or (method-is-user-defined-error-method method) | |
| 781 | (and (not (method-is-error-method method)) | |
| 782 | (not (method-is-for-regularity? method from-module)))) | |
| 783 | (setq new-opinfo | |
| 784 | (dolist (x opinfos nil) | |
| 785 | (when (or (null (method-arity method)) | |
| 786 | (is-in-same-connected-component* | |
| 787 | (method-coarity method) | |
| 788 | (method-coarity (or (cadr (opinfo-methods x)) | |
| 789 | (car (opinfo-methods x)))) | |
| 790 | so)) | |
| 791 | (return x)))) | |
| 792 | (return nil))) | |
| 793 | ||# | |
| 794 | ||
| 795 | (dolist (method (opinfo-methods opinfo)) | |
| 796 | (when (and (not (method-is-error-method method)) | |
| 797 | (not (method-is-for-regularity? method from-module))) | |
| 798 | (setq new-opinfo | |
| 799 | (dolist (x opinfos nil) | |
| 800 | (when (or (null (method-arity method)) | |
| 801 | (is-in-same-connected-component* | |
| 802 | (method-coarity method) | |
| 803 | (method-coarity (or (cadr (opinfo-methods x)) | |
| 804 | (car (opinfo-methods x)))) | |
| 805 | so)) | |
| 806 | (return x)))) | |
| 807 | (return nil))) | |
| 808 | ||
| 809 | ;; create new operaotr info if could not find. | |
| 810 | (cond (new-opinfo | |
| 811 | (setq new-op (opinfo-operator new-opinfo)) | |
| 812 | ) | |
| 813 | (t | |
| 814 | (when *on-import-debug* | |
| 815 | (format t "~%* creating new opinfo for operator ~s : " | |
| 816 | (opinfo-operator opinfo)) | |
| 817 | (print-chaos-object (opinfo-operator opinfo))) | |
| 818 | ;; | |
| 819 | (setq new-op (opinfo-operator opinfo)) | |
| 820 | (setq new-opinfo | |
| 821 | (make-opinfo :operator new-op)) | |
| 822 | (push new-opinfo (module-all-operators module)) | |
| 823 | (push new-opinfo opinfos))) | |
| 824 | ;; | |
| 825 | ||
| 826 | (dolist (method (reverse (opinfo-methods opinfo))) | |
| 827 | ;; | |
| 828 | (when (or (method-is-user-defined-error-method method) ; !!!! | |
| 829 | (and (not (method-is-error-method method)) | |
| 830 | (not (method-is-for-regularity? method from-module)))) | |
| 831 | (when *on-import-debug* | |
| 832 | (format t "~&-- importing method ~s : " method) | |
| 833 | (print-chaos-object method)) | |
| 834 | ;; | |
| 835 | #|| | |
| 836 | (when (modexp-add-method-to-table new-opinfo method module) | |
| 837 | (when *on-import-debug* | |
| 838 | (format t "~&-- importing method-theory ~s:" | |
| 839 | (method-theory method from-opinfo)) | |
| 840 | (finish-output *error-output*))) | |
| 841 | ||# | |
| 842 | ||
| 843 | (modexp-add-method-to-table new-opinfo method module) | |
| 844 | (transfer-operator-attributes method module from-module theory-mod) | |
| 845 | ||
| 846 | ;; import axioms | |
| 847 | (let ((all-rules (module-all-rules module))) | |
| 848 | (dolist (rule (rule-ring-to-list | |
| 849 | (method-rules-with-same-top method from-opinfo))) | |
| 850 | (when (or (not (memq rule all-rules)) | |
| 851 | (eq method (term-head (axiom-lhs rule)))) | |
| 852 | (when *on-import-debug* | |
| 853 | (with-in-module (from-module) | |
| 854 | (format t "~%-- importing axiom ") | |
| 855 | (print-chaos-object rule) | |
| 856 | (format t "~% for method : ") | |
| 857 | (print-chaos-object method))) | |
| 858 | (add-rule-to-method (check-axiom-error-method module rule) | |
| 859 | method to-opinfo) | |
| 860 | (pushnew rule (module-all-rules module) :test #'rule-is-similar?) | |
| 861 | ) | |
| 862 | ) | |
| 863 | ;; | |
| 864 | (dolist (r (reverse (method-rules-with-different-top method | |
| 865 | from-opinfo))) | |
| 866 | (when (or (not (memq r all-rules)) | |
| 867 | (eq method (term-head (axiom-lhs r)))) | |
| 868 | (when *on-import-debug* | |
| 869 | (with-in-module (from-module) | |
| 870 | (format t "~%-- importing axiom ") | |
| 871 | (print-chaos-object r) | |
| 872 | (format t "~% for method : ") | |
| 873 | (print-chaos-object method))) | |
| 874 | (add-rule-to-method (check-axiom-error-method module r) | |
| 875 | method to-opinfo) | |
| 876 | (pushnew r (module-all-rules module) :test #'rule-is-similar?))) | |
| 877 | ))) | |
| 878 | ||
| 879 | ;; | |
| 880 | #|| | |
| 881 | (dolist (method (reverse (opinfo-methods opinfo))) | |
| 882 | (when (and ;; (not (method-is-error-method method)) | |
| 883 | (not (method-is-for-regularity? method from-module))) | |
| 884 | (when *on-import-debug* | |
| 885 | (format t "~&-- importing method ~s : " method) | |
| 886 | (print-chaos-object method)) | |
| 887 | ;; | |
| 888 | #|| | |
| 889 | (when (modexp-add-method-to-table new-opinfo method module) | |
| 890 | (when *on-import-debug* | |
| 891 | (format t "~&-- importing method-theory ~s:" | |
| 892 | (method-theory method from-opinfo)) | |
| 893 | (finish-output *error-output*))) | |
| 894 | ||# | |
| 895 | (modexp-add-method-to-table new-opinfo method module) | |
| 896 | (transfer-operator-attributes method module from-module theory-mod) | |
| 897 | ;; import axioms | |
| 898 | (let ((all-rules (module-all-rules module))) | |
| 899 | (dolist (rule (rule-ring-to-list | |
| 900 | (method-rules-with-same-top method from-opinfo))) | |
| 901 | (when (or (not (memq rule all-rules)) | |
| 902 | (eq method (term-head (axiom-lhs rule)))) | |
| 903 | (when *on-import-debug* | |
| 904 | (with-in-module (from-module) | |
| 905 | (format t "~%-- importing axiom ") | |
| 906 | (print-chaos-object rule) | |
| 907 | (format t "~% for method : ") | |
| 908 | (print-chaos-object method))) | |
| 909 | (add-rule-to-method (check-axiom-error-method module rule) | |
| 910 | method to-opinfo) | |
| 911 | (pushnew rule (module-all-rules module) :test #'rule-is-similar?) | |
| 912 | ) | |
| 913 | ) | |
| 914 | ;; | |
| 915 | (dolist (r (reverse (method-rules-with-different-top method | |
| 916 | from-opinfo))) | |
| 917 | (when (or (not (memq r all-rules)) | |
| 918 | (eq method (term-head (axiom-lhs r)))) | |
| 919 | (when *on-import-debug* | |
| 920 | (with-in-module (from-module) | |
| 921 | (format t "~%-- importing axiom ") | |
| 922 | (print-chaos-object r) | |
| 923 | (format t "~% for method : ") | |
| 924 | (print-chaos-object method))) | |
| 925 | (add-rule-to-method (check-axiom-error-method module r) | |
| 926 | method to-opinfo) | |
| 927 | (pushnew r (module-all-rules module) :test #'rule-is-similar?))) | |
| 928 | ))) | |
| 929 | ||# | |
| 930 | ;; | |
| 931 | (when *on-import-debug* | |
| 932 | (format t "~&* done transfer-operator")) | |
| 933 | )) | |
| 775 | (to-opinfo (module-opinfo-table module)) | |
| 776 | (so (module-sort-order module))) | |
| 777 | ;; find the method group to be inserted | |
| 778 | #|| | |
| 779 | (dolist (method (opinfo-methods opinfo)) | |
| 780 | (when (or (method-is-user-defined-error-method method) | |
| 781 | (and (not (method-is-error-method method)) | |
| 782 | (not (method-is-for-regularity? method from-module)))) | |
| 783 | (setq new-opinfo | |
| 784 | (dolist (x opinfos nil) | |
| 785 | (when (or (null (method-arity method)) | |
| 786 | (is-in-same-connected-component* | |
| 787 | (method-coarity method) | |
| 788 | (method-coarity (or (cadr (opinfo-methods x)) | |
| 789 | (car (opinfo-methods x)))) | |
| 790 | so)) | |
| 791 | (return x)))) | |
| 792 | (return nil))) | |
| 793 | ||# | |
| 794 | ||
| 795 | (dolist (method (opinfo-methods opinfo)) | |
| 796 | (when (and (not (method-is-error-method method)) | |
| 797 | (not (method-is-for-regularity? method from-module))) | |
| 798 | (setq new-opinfo | |
| 799 | (dolist (x opinfos nil) | |
| 800 | (when (or (null (method-arity method)) | |
| 801 | (is-in-same-connected-component* | |
| 802 | (method-coarity method) | |
| 803 | (method-coarity (or (cadr (opinfo-methods x)) | |
| 804 | (car (opinfo-methods x)))) | |
| 805 | so)) | |
| 806 | (return x)))) | |
| 807 | (return nil))) | |
| 808 | ||
| 809 | ;; create new operaotr info if could not find. | |
| 810 | (cond (new-opinfo | |
| 811 | (setq new-op (opinfo-operator new-opinfo)) | |
| 812 | ) | |
| 813 | (t | |
| 814 | (when *on-import-debug* | |
| 815 | (format t "~%* creating new opinfo for operator ~s : " | |
| 816 | (opinfo-operator opinfo)) | |
| 817 | (print-chaos-object (opinfo-operator opinfo))) | |
| 818 | ;; | |
| 819 | (setq new-op (opinfo-operator opinfo)) | |
| 820 | (setq new-opinfo | |
| 821 | (make-opinfo :operator new-op)) | |
| 822 | (push new-opinfo (module-all-operators module)) | |
| 823 | (push new-opinfo opinfos))) | |
| 824 | ;; | |
| 825 | ||
| 826 | (dolist (method (reverse (opinfo-methods opinfo))) | |
| 827 | ;; | |
| 828 | (when (or (method-is-user-defined-error-method method) ; !!!! | |
| 829 | (and (not (method-is-error-method method)) | |
| 830 | (not (method-is-for-regularity? method from-module)))) | |
| 831 | (when *on-import-debug* | |
| 832 | (format t "~&-- importing method ~s : " method) | |
| 833 | (print-chaos-object method)) | |
| 834 | ;; | |
| 835 | #|| | |
| 836 | (when (modexp-add-method-to-table new-opinfo method module) | |
| 837 | (when *on-import-debug* | |
| 838 | (format t "~&-- importing method-theory ~s:" | |
| 839 | (method-theory method from-opinfo)) | |
| 840 | (finish-output *error-output*))) | |
| 841 | ||# | |
| 842 | ||
| 843 | (modexp-add-method-to-table new-opinfo method module) | |
| 844 | (transfer-operator-attributes method module from-module theory-mod) | |
| 845 | ||
| 846 | ;; import axioms | |
| 847 | (let ((all-rules (module-all-rules module))) | |
| 848 | (dolist (rule (rule-ring-to-list | |
| 849 | (method-rules-with-same-top method from-opinfo))) | |
| 850 | (when (or (not (memq rule all-rules)) | |
| 851 | (eq method (term-head (axiom-lhs rule)))) | |
| 852 | (when *on-import-debug* | |
| 853 | (with-in-module (from-module) | |
| 854 | (format t "~%-- importing axiom ") | |
| 855 | (print-chaos-object rule) | |
| 856 | (format t "~% for method : ") | |
| 857 | (print-chaos-object method))) | |
| 858 | (add-rule-to-method (check-axiom-error-method module rule) | |
| 859 | method to-opinfo) | |
| 860 | (pushnew rule (module-all-rules module) :test #'rule-is-similar?) | |
| 861 | ) | |
| 862 | ) | |
| 863 | ;; | |
| 864 | (dolist (r (reverse (method-rules-with-different-top method | |
| 865 | from-opinfo))) | |
| 866 | (when (or (not (memq r all-rules)) | |
| 867 | (eq method (term-head (axiom-lhs r)))) | |
| 868 | (when *on-import-debug* | |
| 869 | (with-in-module (from-module) | |
| 870 | (format t "~%-- importing axiom ") | |
| 871 | (print-chaos-object r) | |
| 872 | (format t "~% for method : ") | |
| 873 | (print-chaos-object method))) | |
| 874 | (add-rule-to-method (check-axiom-error-method module r) | |
| 875 | method to-opinfo) | |
| 876 | (pushnew r (module-all-rules module) :test #'rule-is-similar?))) | |
| 877 | ))) | |
| 878 | ||
| 879 | ;; | |
| 880 | #|| | |
| 881 | (dolist (method (reverse (opinfo-methods opinfo))) | |
| 882 | (when (and ;; (not (method-is-error-method method)) | |
| 883 | (not (method-is-for-regularity? method from-module))) | |
| 884 | (when *on-import-debug* | |
| 885 | (format t "~&-- importing method ~s : " method) | |
| 886 | (print-chaos-object method)) | |
| 887 | ;; | |
| 888 | #|| | |
| 889 | (when (modexp-add-method-to-table new-opinfo method module) | |
| 890 | (when *on-import-debug* | |
| 891 | (format t "~&-- importing method-theory ~s:" | |
| 892 | (method-theory method from-opinfo)) | |
| 893 | (finish-output *error-output*))) | |
| 894 | ||# | |
| 895 | (modexp-add-method-to-table new-opinfo method module) | |
| 896 | (transfer-operator-attributes method module from-module theory-mod) | |
| 897 | ;; import axioms | |
| 898 | (let ((all-rules (module-all-rules module))) | |
| 899 | (dolist (rule (rule-ring-to-list | |
| 900 | (method-rules-with-same-top method from-opinfo))) | |
| 901 | (when (or (not (memq rule all-rules)) | |
| 902 | (eq method (term-head (axiom-lhs rule)))) | |
| 903 | (when *on-import-debug* | |
| 904 | (with-in-module (from-module) | |
| 905 | (format t "~%-- importing axiom ") | |
| 906 | (print-chaos-object rule) | |
| 907 | (format t "~% for method : ") | |
| 908 | (print-chaos-object method))) | |
| 909 | (add-rule-to-method (check-axiom-error-method module rule) | |
| 910 | method to-opinfo) | |
| 911 | (pushnew rule (module-all-rules module) :test #'rule-is-similar?) | |
| 912 | ) | |
| 913 | ) | |
| 914 | ;; | |
| 915 | (dolist (r (reverse (method-rules-with-different-top method | |
| 916 | from-opinfo))) | |
| 917 | (when (or (not (memq r all-rules)) | |
| 918 | (eq method (term-head (axiom-lhs r)))) | |
| 919 | (when *on-import-debug* | |
| 920 | (with-in-module (from-module) | |
| 921 | (format t "~%-- importing axiom ") | |
| 922 | (print-chaos-object r) | |
| 923 | (format t "~% for method : ") | |
| 924 | (print-chaos-object method))) | |
| 925 | (add-rule-to-method (check-axiom-error-method module r) | |
| 926 | method to-opinfo) | |
| 927 | (pushnew r (module-all-rules module) :test #'rule-is-similar?))) | |
| 928 | ))) | |
| 929 | ||# | |
| 930 | ;; | |
| 931 | (when *on-import-debug* | |
| 932 | (format t "~&* done transfer-operator")) | |
| 933 | )) | |
| 934 | 934 | )) |
| 935 | 935 | |
| 936 | 936 | (defun modexp-add-method-to-table (opinfo method module) |
| 937 | 937 | (let ((pmeth (find method (opinfo-methods opinfo) |
| 938 | :test #'(lambda (x y) | |
| 939 | (and (sort-list= (method-arity x) | |
| 940 | (method-arity y)) | |
| 941 | (sort= (method-coarity x) | |
| 942 | (method-coarity y)))))) | |
| 943 | (method-info-table (module-opinfo-table module))) | |
| 938 | :test #'(lambda (x y) | |
| 939 | (and (sort-list= (method-arity x) | |
| 940 | (method-arity y)) | |
| 941 | (sort= (method-coarity x) | |
| 942 | (method-coarity y)))))) | |
| 943 | (method-info-table (module-opinfo-table module))) | |
| 944 | 944 | (if (or (eq pmeth method) |
| 945 | ;; dirty kludge! | |
| 946 | (and pmeth (method-is-of-same-operator method *rwl-predicate*))) | |
| 947 | nil | |
| 948 | (progn | |
| 949 | (setf (get-method-info method method-info-table) | |
| 950 | (make-method-info method | |
| 951 | module | |
| 952 | (opinfo-operator opinfo))) | |
| 953 | (pushnew method (opinfo-methods opinfo)) | |
| 954 | (setf (opinfo-method-table opinfo) nil) | |
| 955 | (when (method-is-behavioural method) | |
| 956 | (if (sort-is-hidden (method-coarity method)) | |
| 957 | (pushnew method (module-beh-methods module)) | |
| 958 | (pushnew method (module-beh-attributes module)))) | |
| 959 | t)))) | |
| 945 | ;; dirty kludge! | |
| 946 | (and pmeth (method-is-of-same-operator method *rwl-predicate*))) | |
| 947 | nil | |
| 948 | (progn | |
| 949 | (setf (get-method-info method method-info-table) | |
| 950 | (make-method-info method | |
| 951 | module | |
| 952 | (opinfo-operator opinfo))) | |
| 953 | (pushnew method (opinfo-methods opinfo)) | |
| 954 | (setf (opinfo-method-table opinfo) nil) | |
| 955 | (when (method-is-behavioural method) | |
| 956 | (if (sort-is-hidden (method-coarity method)) | |
| 957 | (pushnew method (module-beh-methods module)) | |
| 958 | (pushnew method (module-beh-attributes module)))) | |
| 959 | t)))) | |
| 960 | 960 | |
| 961 | 961 | (defun transfer-operator-attributes (method to-module from-module |
| 962 | &optional theory-mod) | |
| 962 | &optional theory-mod) | |
| 963 | 963 | ;; transfer operator theory |
| 964 | 964 | (transfer-operator-theory method to-module from-module theory-mod) |
| 965 | 965 | ;; transfer other attributes |
| 966 | 966 | (transfer-operator-attrs method to-module from-module theory-mod)) |
| 967 | 967 | |
| 968 | 968 | (defun transfer-operator-theory (method to-module from-module |
| 969 | &optional theory-mod) | |
| 969 | &optional theory-mod) | |
| 970 | 970 | (let ((new-theory (modexp-merge-operator-theory method |
| 971 | to-module | |
| 972 | from-module | |
| 973 | theory-mod))) | |
| 971 | to-module | |
| 972 | from-module | |
| 973 | theory-mod))) | |
| 974 | 974 | (when new-theory |
| 975 | 975 | (setf (method-theory method (module-opinfo-table to-module)) |
| 976 | new-theory) | |
| 976 | new-theory) | |
| 977 | 977 | (compute-method-theory-info-for-matching method |
| 978 | (module-opinfo-table to-module)) | |
| 978 | (module-opinfo-table to-module)) | |
| 979 | 979 | ))) |
| 980 | 980 | |
| 981 | 981 | (defun modexp-merge-operator-theory (method to-module from-module |
| 982 | &optional theory-mod) | |
| 982 | &optional theory-mod) | |
| 983 | 983 | (let* ((to-opinfo (module-opinfo-table to-module)) |
| 984 | (th1 (method-theory method to-opinfo)) | |
| 985 | (from-opinfo (if theory-mod | |
| 986 | (module-opinfo-table theory-mod) | |
| 987 | (module-opinfo-table from-module))) | |
| 988 | (th2 (method-theory method from-opinfo))) | |
| 984 | (th1 (method-theory method to-opinfo)) | |
| 985 | (from-opinfo (if theory-mod | |
| 986 | (module-opinfo-table theory-mod) | |
| 987 | (module-opinfo-table from-module))) | |
| 988 | (th2 (method-theory method from-opinfo))) | |
| 989 | 989 | (merge-operator-theory-in to-module method th1 th2))) |
| 990 | 990 | |
| 991 | 991 | (defun transfer-operator-attrs (meth to-module from-module &optional theory-mod) |
| 992 | 992 | (declare (ignore theory-mod)) |
| 993 | 993 | (let ((coh nil) |
| 994 | (meta-demod nil)) | |
| 994 | (meta-demod nil)) | |
| 995 | 995 | (with-in-module (from-module) |
| 996 | 996 | (setq coh (method-is-coherent meth)) |
| 997 | 997 | (setq meta-demod (method-is-meta-demod meth))) |
| 1020 | 1020 | (defun include-BOOL (&optional (module *current-module*)) |
| 1021 | 1021 | (when *include-BOOL* |
| 1022 | 1022 | (unless (memq *Bool-sort* |
| 1023 | (module-all-sorts module)) | |
| 1023 | (module-all-sorts module)) | |
| 1024 | 1024 | (with-in-module (module) |
| 1025 | (eval-import-modexp *import-bool-ast*)))) | |
| 1025 | (eval-import-modexp *import-bool-ast*)))) | |
| 1026 | 1026 | (include-chaos-module) |
| 1027 | 1027 | ) |
| 1028 | 1028 | ||# |
| 1030 | 1030 | (defun include-BOOL (&optional (module *current-module*)) |
| 1031 | 1031 | (when *include-BOOL* |
| 1032 | 1032 | (unless (assq *bool-module* |
| 1033 | (module-all-submodules module)) | |
| 1033 | (module-all-submodules module)) | |
| 1034 | 1034 | (with-in-module (module) |
| 1035 | (eval-import-modexp *import-bool-ast*)))) | |
| 1035 | (eval-import-modexp *import-bool-ast*)))) | |
| 1036 | 1036 | (include-chaos-module) |
| 1037 | 1037 | ) |
| 1038 | 1038 | |
| 1041 | 1041 | |
| 1042 | 1042 | (defun include-object () |
| 1043 | 1043 | (unless (memq *class-id-sort* |
| 1044 | (module-all-sorts *current-module*)) | |
| 1044 | (module-all-sorts *current-module*)) | |
| 1045 | 1045 | (eval-import-modexp *import-object-ast*) |
| 1046 | 1046 | )) |
| 1047 | 1047 | |
| 1050 | 1050 | |
| 1051 | 1051 | (defun include-record () |
| 1052 | 1052 | (unless (memq *record-id-sort* |
| 1053 | (module-all-sorts *current-module*)) | |
| 1053 | (module-all-sorts *current-module*)) | |
| 1054 | 1054 | (eval-import-modexp *import-record-ast*))) |
| 1055 | 1055 | |
| 1056 | 1056 | (defparameter *import-rwl-ast* |
| 1057 | 1057 | (%import* :protecting (%modexp* "RWL"))) |
| 1058 | 1058 | |
| 1059 | (defun include-rwl (&optional (module (or *current-module* *last-module*))) | |
| 1059 | (defun include-rwl (&optional (module (get-context-module))) | |
| 1060 | 1060 | (when *include-rwl* |
| 1061 | 1061 | (unless (module-includes-rwl module) |
| 1062 | 1062 | (with-in-module (module) |
| 1063 | (eval-import-modexp *import-rwl-ast*) | |
| 1064 | ))) | |
| 1065 | ) | |
| 1063 | (eval-import-modexp *import-rwl-ast*))))) | |
| 1066 | 1064 | |
| 1067 | 1065 | ;;; |
| 1068 | 1066 | ;;; IMPORT-VARIABLES |
| 1071 | 1069 | (let ((vs (module-variables from))) |
| 1072 | 1070 | (dolist (v vs) |
| 1073 | 1071 | (let ((s (find-sort-in to (sort-id (variable-sort v)))) |
| 1074 | (name (variable-name v))) | |
| 1075 | (if s | |
| 1076 | (push (cons name (make-variable-term s name)) | |
| 1077 | (module-variables to)) | |
| 1078 | (with-output-chaos-warning () | |
| 1079 | (format t "importing variable ~a, could not find sort ~a" | |
| 1080 | name | |
| 1081 | (sort-id (variable-sort v))))))) | |
| 1072 | (name (variable-name v))) | |
| 1073 | (if s | |
| 1074 | (push (cons name (make-variable-term s name)) | |
| 1075 | (module-variables to)) | |
| 1076 | (with-output-chaos-warning () | |
| 1077 | (format t "importing variable ~a, could not find sort ~a" | |
| 1078 | name | |
| 1079 | (sort-id (variable-sort v))))))) | |
| 1082 | 1080 | )) |
| 1083 | 1081 | |
| 1084 | 1082 | ;;; EOF |
| 0 | 0 | ;;;-*- Mode:LISP; Package:CHAOS; Base:10; Syntax:Common-lisp -*- |
| 1 | 1 | ;;; |
| 2 | ;;; Copyright (c) 2000-2014, Toshimi Sawada. All rights reserved. | |
| 2 | ;;; Copyright (c) 2000-2015, Toshimi Sawada. All rights reserved. | |
| 3 | 3 | ;;; |
| 4 | 4 | ;;; Redistribution and use in source and binary forms, with or without |
| 5 | 5 | ;;; modification, are permitted provided that the following conditions |
| 27 | 27 | ;;; |
| 28 | 28 | (in-package :chaos) |
| 29 | 29 | #|============================================================================== |
| 30 | System: CHAOS | |
| 31 | Module: deCafe | |
| 32 | File: mimport.lisp | |
| 30 | System: CHAOS | |
| 31 | Module: deCafe | |
| 32 | File: mimport.lisp | |
| 33 | 33 | ==============================================================================|# |
| 34 | 34 | #-:chaos-debug |
| 35 | 35 | (declaim (optimize (speed 3) (safety 0) #-GCL (debug 0))) |
| 67 | 67 | (let ((*auto-context-change* nil)) |
| 68 | 68 | (setq *import-sort-map* nil) |
| 69 | 69 | (prog1 |
| 70 | (import-module-internal im mode sub parameter nil alias) | |
| 70 | (import-module-internal im mode sub parameter nil alias) | |
| 71 | 71 | (setq *import-sort-map* nil)))) |
| 72 | 72 | |
| 73 | 73 | (defun import-module-internal (im mode sub &optional parameter theory-mod alias) |
| 74 | 74 | (when *on-import-debug* |
| 75 | (format t "~&[import-module]: ") | |
| 75 | (format t "~%[import-module]: ") | |
| 76 | 76 | (print-next) |
| 77 | 77 | (princ " ") (print-modexp im) |
| 78 | 78 | (format t " <==(~a)== " mode) |
| 80 | 80 | (if parameter (format t " : ~a" parameter))) |
| 81 | 81 | ;; |
| 82 | 82 | (flet ((eval-modexp-or-error (modexp) |
| 83 | (let (val) | |
| 84 | (if (module-p modexp) | |
| 85 | (setf val modexp) | |
| 86 | (progn | |
| 87 | (setf val (eval-modexp modexp)) ; must be global | |
| 88 | (when (modexp-is-error val) | |
| 89 | (with-output-chaos-error ('modexp-eval) | |
| 90 | (princ "importing module, cannot evaluate module expression ") | |
| 91 | (print-modexp modexp) | |
| 92 | )))) | |
| 93 | val)) | |
| 94 | (is-directly-using (mod1 mod2) | |
| 95 | ;; IS-DIRECTLY-USING : Module-1 Module-2 -> Bool | |
| 96 | ;; returns t iff the module-1 imports module-2 directly. | |
| 97 | ;; `directly' means that some own constructs of Module-2 (sors and | |
| 98 | ;; operators declared in Module-2) are included in Module-1's | |
| 99 | ;; constructs, i.e., Module-2 is a node of a module hierarchy with | |
| 100 | ;; Module-1 at top. | |
| 101 | (or (some #'(lambda (x) (eq mod2 (sort-module x))) | |
| 102 | (module-all-sorts mod1)) | |
| 103 | (some #'(lambda (x) | |
| 104 | (eq mod2 (operator-module (opinfo-operator x)))) | |
| 105 | (module-all-operators mod1)))) | |
| 106 | (create-variant-name (parent mod) | |
| 107 | ;; CREATE-VARIANT-NAME | |
| 108 | ;; variant name ::= (:name <module name> <natural>) | |
| 109 | ;; We carete a brand new module when imported module refers some | |
| 110 | ;; soncstructs of importing module. this can happen when we import an | |
| 111 | ;; instantiated module with an actual parameter includes some sorts | |
| 112 | ;; or operators of importing module in its module morphism. In such | |
| 113 | ;; case, we create a module with the same name of importing module, | |
| 114 | ;; then importing module is changed its name to `variant-name'. The | |
| 115 | ;; newly created module, then imports this module. | |
| 116 | (let ((modname (module-name parent)) | |
| 117 | (num -1)) | |
| 118 | (declare (type fixnum num)) | |
| 119 | (dolist (sm (module-submodules mod)) | |
| 120 | (when (eq :protecting (cdr sm)) | |
| 121 | (let ((smnm (module-name (car sm)))) | |
| 122 | (when (and (consp smnm) | |
| 123 | (eq :name (car smnm)) | |
| 124 | (eq (cadr smnm) modname) ; by construction works | |
| 125 | (< num (the fixnum (caddr smnm)))) | |
| 126 | (setq num (caddr smnm)))))) | |
| 127 | `(:name ,modname ,(1+ (the fixnum num))) | |
| 128 | ))) | |
| 83 | (let (val) | |
| 84 | (if (module-p modexp) | |
| 85 | (setf val modexp) | |
| 86 | (progn | |
| 87 | (setf val (eval-modexp modexp)) ; must be global | |
| 88 | (when (modexp-is-error val) | |
| 89 | (with-output-chaos-error ('modexp-eval) | |
| 90 | (princ "importing module, cannot evaluate module expression ") | |
| 91 | (print-modexp modexp) | |
| 92 | )))) | |
| 93 | val)) | |
| 94 | (is-directly-using (mod1 mod2) | |
| 95 | ;; IS-DIRECTLY-USING : Module-1 Module-2 -> Bool | |
| 96 | ;; returns t iff the module-1 imports module-2 directly. | |
| 97 | ;; `directly' means that some own constructs of Module-2 (sors and | |
| 98 | ;; operators declared in Module-2) are included in Module-1's | |
| 99 | ;; constructs, i.e., Module-2 is a node of a module hierarchy with | |
| 100 | ;; Module-1 at top. | |
| 101 | (or (some #'(lambda (x) (eq mod2 (sort-module x))) | |
| 102 | (module-all-sorts mod1)) | |
| 103 | (some #'(lambda (x) | |
| 104 | (eq mod2 (operator-module (opinfo-operator x)))) | |
| 105 | (module-all-operators mod1)))) | |
| 106 | (create-variant-name (parent mod) | |
| 107 | ;; CREATE-VARIANT-NAME | |
| 108 | ;; variant name ::= (:name <module name> <natural>) | |
| 109 | ;; We carete a brand new module when imported module refers some | |
| 110 | ;; soncstructs of importing module. this can happen when we import an | |
| 111 | ;; instantiated module with an actual parameter includes some sorts | |
| 112 | ;; or operators of importing module in its module morphism. In such | |
| 113 | ;; case, we create a module with the same name of importing module, | |
| 114 | ;; then importing module is changed its name to `variant-name'. The | |
| 115 | ;; newly created module, then imports this module. | |
| 116 | (let ((modname (module-name parent)) | |
| 117 | (num -1)) | |
| 118 | (declare (type fixnum num)) | |
| 119 | (dolist (sm (module-submodules mod)) | |
| 120 | (when (eq :protecting (cdr sm)) | |
| 121 | (let ((smnm (module-name (car sm)))) | |
| 122 | (when (and (consp smnm) | |
| 123 | (eq :name (car smnm)) | |
| 124 | (eq (cadr smnm) modname) ; by construction works | |
| 125 | (< num (the fixnum (caddr smnm)))) | |
| 126 | (setq num (caddr smnm)))))) | |
| 127 | `(:name ,modname ,(1+ (the fixnum num))) | |
| 128 | ))) | |
| 129 | 129 | ;; |
| 130 | 130 | (let ((module (eval-modexp-or-error im)) |
| 131 | (submodule (eval-modexp-or-error sub))) | |
| 131 | (submodule (eval-modexp-or-error sub))) | |
| 132 | 132 | (unless (and (module-p module) (module-p submodule)) |
| 133 | ;; (break) | |
| 134 | (return-from import-module-internal nil)) | |
| 133 | ;; (break) | |
| 134 | (return-from import-module-internal nil)) | |
| 135 | 135 | (when (eq module submodule) |
| 136 | (with-output-chaos-error ('invalid-import) | |
| 137 | (princ "module cannot import itself!") | |
| 138 | )) | |
| 136 | (with-output-chaos-error ('invalid-import) | |
| 137 | (princ "module cannot import itself!"))) | |
| 139 | 138 | |
| 140 | 139 | ;; compile submodule if need |
| 141 | 140 | (compile-module submodule) |
| 142 | 141 | ;; alias |
| 143 | 142 | (when alias |
| 144 | (symbol-table-add (module-symbol-table module) | |
| 145 | alias | |
| 146 | submodule)) | |
| 143 | (symbol-table-add (module-symbol-table module) | |
| 144 | alias | |
| 145 | submodule)) | |
| 147 | 146 | ;; |
| 148 | 147 | (dolist (al (module-alias submodule)) |
| 149 | (let ((mod (car al)) | |
| 150 | (nm (cdr al))) | |
| 151 | (add-module-alias module mod nm))) | |
| 152 | ;; | |
| 153 | #|| | |
| 154 | (when (and *include-bool* | |
| 155 | (assq *bool-module* | |
| 156 | (module-all-submodules submodule))) | |
| 157 | (include-bool module)) | |
| 158 | ||# | |
| 148 | (let ((mod (car al)) | |
| 149 | (nm (cdr al))) | |
| 150 | (add-module-alias module mod nm))) | |
| 159 | 151 | ;; |
| 160 | 152 | (with-in-module (module) |
| 161 | ;; | |
| 162 | ;; | |
| 163 | (if parameter | |
| 164 | ;; PARAMETERIZED MODULE IMPORTATION. | |
| 165 | ;; We carete a new module with name `(formal-name "::" module-object)' | |
| 166 | ;; where, formal-name is the name of formal parameter name (we get | |
| 167 | ;; this as the argument param), module-object is the object of | |
| 168 | ;; submodule to be imported as parameter theory. | |
| 169 | ;; The `parameters' module will be updated to including this | |
| 170 | ;; importation, each entry is is the form of | |
| 171 | ;; `((formal-name . parameter-module) . mode) | |
| 172 | (let ((true-name (list parameter "::" submodule module)) | |
| 173 | (*include-bool* (if (memq *bool-sort* (module-all-sorts submodule)) | |
| 174 | t | |
| 175 | nil))) | |
| 176 | (let ((param-mod (create-renamed-module-2 submodule true-name module))) | |
| 177 | ;; register it to local environment. | |
| 178 | (add-modexp-local-defn (list parameter (module-name module)) | |
| 179 | param-mod) | |
| 180 | (push (cons (cons parameter param-mod) mode) | |
| 181 | (module-parameters module)) | |
| 182 | (import-module-internal module mode param-mod) | |
| 183 | )) | |
| 184 | ;; | |
| 185 | ;; NON PARAMETERIZED MODULE IMPORTATION. | |
| 186 | ;; | |
| 187 | (if (or (eq :using mode) | |
| 188 | (not (is-directly-using submodule *current-module*))) | |
| 189 | (let* ((subs (module-all-submodules module)) | |
| 190 | (val (assq submodule subs))) | |
| 191 | (when val | |
| 192 | (let ((real-mode (get-real-importing-mode submodule module))) | |
| 193 | (if (and *check-import-mode* | |
| 194 | (not (or (eq real-mode :using) | |
| 195 | (eq (cdr val) :using))) | |
| 196 | (not (eq mode real-mode))) | |
| 197 | (with-output-chaos-error ('import-error) | |
| 198 | (format t "module ~a is already imported into ~a" | |
| 199 | (make-module-print-name submodule) | |
| 200 | (make-module-print-name module)) | |
| 201 | (print-next) | |
| 202 | (format t "with the effective mode : ~a," real-mode) | |
| 203 | (print-next) | |
| 204 | (format t "this conflicts to the new mode : ~a." mode) | |
| 205 | ) | |
| 206 | ;; we omit this importation | |
| 207 | (progn | |
| 208 | (when *on-import-debug* | |
| 209 | (format t "~&module is already imported, skipping..")) | |
| 210 | (return-from import-module-internal t) | |
| 211 | )) | |
| 212 | )) | |
| 213 | (when *check-import-mode* | |
| 214 | ;; other more complex importation check. | |
| 215 | ;; checks confliction among shared submodules. | |
| 216 | (let ((s-subs (mapcar #'car | |
| 217 | (module-all-submodules submodule)))) | |
| 218 | (dolist (ms subs) | |
| 219 | (when (memq (car ms) s-subs) | |
| 220 | (let ((m1 (get-real-importing-mode (car ms) module)) | |
| 221 | (m2 (get-real-importing-mode (car ms) submodule))) | |
| 222 | (unless (eq m1 m2) | |
| 223 | (if (or (memq m1 '(:?extending :extending)) | |
| 224 | (memq m2 '(:?extending :extending))) | |
| 225 | ;; | |
| 226 | nil ; do nothing now | |
| 227 | (when (not (or (eq m1 :using) | |
| 228 | (eq m2 :using))) | |
| 229 | (with-output-chaos-error ('import-error) | |
| 230 | (format t "confliction in importation mode of common submodule ~a" | |
| 231 | (get-module-print-name (car ms))) | |
| 232 | (print-next) | |
| 233 | (format t "module ~a already imports with effective mode ~a," | |
| 234 | (get-module-print-name module) | |
| 235 | m1) | |
| 236 | (print-next) | |
| 237 | (format t "module ~a imports with effective mode ~a." | |
| 238 | (get-module-print-name submodule) | |
| 239 | m2) | |
| 240 | ))))))))) | |
| 241 | ||
| 242 | ;; `incorporate-module' do the real importation. | |
| 243 | (incorporate-module module mode submodule theory-mod) | |
| 244 | ||
| 245 | ;; imported modules are stored at `module-submodules' in a form | |
| 246 | ;; (<module> <mode>), <mode> is one of :protecting, :extending, | |
| 247 | ;; :using, and :including. | |
| 248 | (add-imported-module module mode submodule alias) | |
| 249 | ;; | |
| 250 | module) | |
| 251 | ||
| 252 | ;; MUTUALLY RECURSIVE CASE. | |
| 253 | ;; imported module refers some constructs of importing module. | |
| 254 | ;; current-module --> variant | |
| 255 | ;; | |
| 256 | (let ((newmod (make-module :name (module-name module))) | |
| 257 | (modname (module-name module)) | |
| 258 | (submod module)) | |
| 259 | (initialize-module newmod) | |
| 260 | (setf (module-parameters newmod) | |
| 261 | (module-parameters module)) | |
| 262 | (setf *current-module* newmod) | |
| 263 | (setf *current-sort-order* (module-sort-order newmod)) | |
| 264 | (setf *current-opinfo-table* (module-opinfo-table newmod)) | |
| 265 | (let ((subname (create-variant-name newmod submod))) | |
| 266 | (setf (module-name submod) subname) | |
| 267 | ;; (add-canon-modexp subname subname) | |
| 268 | ;; (modexp-update-name subname submod) | |
| 269 | ) | |
| 270 | (final-setup submod) | |
| 271 | (add-modexp-defn modname newmod) | |
| 272 | (add-imported-module newmod :protecting submod) | |
| 273 | (incorporate-module newmod :protecting submod) | |
| 274 | (add-imported-module newmod mode submodule) | |
| 275 | (incorporate-module newmod mode submodule) | |
| 276 | (dolist (par (module-parameters newmod)) | |
| 277 | (add-imported-module newmod (cdr par)(cdar par)) | |
| 278 | (incorporate-module newmod (cdr par) (cdar par))) | |
| 279 | (unless *chaos-quiet* (princ ")" *error-output*)) | |
| 280 | newmod))) | |
| 281 | )))) | |
| 153 | (if parameter | |
| 154 | ;; PARAMETERIZED MODULE IMPORTATION. | |
| 155 | ;; We carete a new module with name `(formal-name "::" module-object)' | |
| 156 | ;; where, formal-name is the name of formal parameter name (we get | |
| 157 | ;; this as the argument param), module-object is the object of | |
| 158 | ;; submodule to be imported as parameter theory. | |
| 159 | ;; The `parameters' module will be updated to including this | |
| 160 | ;; importation, each entry is is the form of | |
| 161 | ;; `((formal-name . parameter-module) . mode) | |
| 162 | (let ((true-name (list parameter "::" submodule module)) | |
| 163 | (*include-bool* (if (memq *bool-sort* (module-all-sorts submodule)) | |
| 164 | t | |
| 165 | nil))) | |
| 166 | (let ((param-mod (create-renamed-module-2 submodule true-name module))) | |
| 167 | ;; register it to local environment. | |
| 168 | (add-modexp-local-defn (list parameter (module-name module)) | |
| 169 | param-mod) | |
| 170 | (push (cons (cons parameter param-mod) mode) | |
| 171 | (module-parameters module)) | |
| 172 | (import-module-internal module mode param-mod) | |
| 173 | )) | |
| 174 | ;; | |
| 175 | ;; NON PARAMETERIZED MODULE IMPORTATION. | |
| 176 | ;; | |
| 177 | (if (or (eq :using mode) | |
| 178 | (not (is-directly-using submodule *current-module*))) | |
| 179 | (let* ((subs (module-all-submodules module)) | |
| 180 | (val (assq submodule subs))) | |
| 181 | (when val | |
| 182 | (let ((real-mode (get-real-importing-mode submodule module))) | |
| 183 | (if (and *check-import-mode* | |
| 184 | (not (or (eq real-mode :using) | |
| 185 | (eq (cdr val) :using))) | |
| 186 | (not (eq mode real-mode))) | |
| 187 | (with-output-chaos-error ('import-error) | |
| 188 | (format t "module ~a is already imported into ~a" | |
| 189 | (make-module-print-name submodule) | |
| 190 | (make-module-print-name module)) | |
| 191 | (print-next) | |
| 192 | (format t "with the effective mode : ~a," real-mode) | |
| 193 | (print-next) | |
| 194 | (format t "this conflicts to the new mode : ~a." mode) | |
| 195 | ) | |
| 196 | ;; we omit this importation | |
| 197 | (progn | |
| 198 | (when *on-import-debug* | |
| 199 | (format t "~%module is already imported, skipping..")) | |
| 200 | (return-from import-module-internal t))))) | |
| 201 | (when *check-import-mode* | |
| 202 | ;; other more complex importation check. | |
| 203 | ;; checks confliction among shared submodules. | |
| 204 | (let ((s-subs (mapcar #'car | |
| 205 | (module-all-submodules submodule)))) | |
| 206 | (dolist (ms subs) | |
| 207 | (when (memq (car ms) s-subs) | |
| 208 | (let ((m1 (get-real-importing-mode (car ms) module)) | |
| 209 | (m2 (get-real-importing-mode (car ms) submodule))) | |
| 210 | (unless (eq m1 m2) | |
| 211 | (if (or (memq m1 '(:?extending :extending)) | |
| 212 | (memq m2 '(:?extending :extending))) | |
| 213 | ;; | |
| 214 | nil ; do nothing now | |
| 215 | (when (not (or (eq m1 :using) | |
| 216 | (eq m2 :using))) | |
| 217 | (with-output-chaos-error ('import-error) | |
| 218 | (format t "confliction in importation mode of common submodule ~a" | |
| 219 | (get-module-print-name (car ms))) | |
| 220 | (print-next) | |
| 221 | (format t "module ~a already imports with effective mode ~a," | |
| 222 | (get-module-print-name module) | |
| 223 | m1) | |
| 224 | (print-next) | |
| 225 | (format t "module ~a imports with effective mode ~a." | |
| 226 | (get-module-print-name submodule) | |
| 227 | m2) | |
| 228 | ))))))))) | |
| 229 | ||
| 230 | ;; `incorporate-module' do the real importation. | |
| 231 | (incorporate-module module mode submodule theory-mod) | |
| 232 | ||
| 233 | ;; imported modules are stored at `module-submodules' in a form | |
| 234 | ;; (<module> <mode>), <mode> is one of :protecting, :extending, | |
| 235 | ;; :using, and :including. | |
| 236 | (add-imported-module module mode submodule alias) | |
| 237 | ;; | |
| 238 | module) | |
| 239 | ||
| 240 | ;; MUTUALLY RECURSIVE CASE. | |
| 241 | ;; imported module refers some constructs of importing module. | |
| 242 | ;; current-module --> variant | |
| 243 | ;; | |
| 244 | (let ((newmod (make-module :name (module-name module))) | |
| 245 | (modname (module-name module)) | |
| 246 | (submod module)) | |
| 247 | (initialize-module newmod) | |
| 248 | (setf (module-parameters newmod) | |
| 249 | (module-parameters module)) | |
| 250 | (setf *current-module* newmod) | |
| 251 | (setf *current-sort-order* (module-sort-order newmod)) | |
| 252 | (setf *current-opinfo-table* (module-opinfo-table newmod)) | |
| 253 | (let ((subname (create-variant-name newmod submod))) | |
| 254 | (setf (module-name submod) subname) | |
| 255 | ;; (add-canon-modexp subname subname) | |
| 256 | ;; (modexp-update-name subname submod) | |
| 257 | ) | |
| 258 | (final-setup submod) | |
| 259 | (add-modexp-defn modname newmod) | |
| 260 | (add-imported-module newmod :protecting submod) | |
| 261 | (incorporate-module newmod :protecting submod) | |
| 262 | (add-imported-module newmod mode submodule) | |
| 263 | (incorporate-module newmod mode submodule) | |
| 264 | (dolist (par (module-parameters newmod)) | |
| 265 | (add-imported-module newmod (cdr par)(cdar par)) | |
| 266 | (incorporate-module newmod (cdr par) (cdar par))) | |
| 267 | (unless *chaos-quiet* (princ ")" *error-output*)) | |
| 268 | newmod))))))) | |
| 282 | 269 | |
| 283 | 270 | ;;; INCORPORATE-MODULE : Module Mode SubModule -> Module' |
| 284 | 271 | ;;; Do the importation. |
| 292 | 279 | (defun incorporate-module (module mode submodule &optional theory-mod) |
| 293 | 280 | (if (memq mode '(:protecting :extending :including)) |
| 294 | 281 | (prog1 (incorporate-module-sharing module submodule theory-mod) |
| 295 | (when (eq mode :including) | |
| 296 | (when (and (module-psort-declaration submodule) | |
| 297 | (null (module-psort-declaration module))) | |
| 298 | (setf (module-psort-declaration module) | |
| 299 | (copy-tree (module-psort-declaration submodule)))))) | |
| 282 | (when (eq mode :including) | |
| 283 | (when (and (module-psort-declaration submodule) | |
| 284 | (null (module-psort-declaration module))) | |
| 285 | (setf (module-psort-declaration module) | |
| 286 | (copy-tree (module-psort-declaration submodule)))))) | |
| 300 | 287 | (incorporate-module-copying module submodule nil theory-mod))) |
| 301 | 288 | |
| 302 | 289 | (defun incorporate-module-sharing (module submodule &optional theory-mod) |
| 308 | 295 | ;;----------------------------------------------- |
| 309 | 296 | ;; import sorts |
| 310 | 297 | (dolist (s (reverse (module-all-sorts submodule))) |
| 311 | ;; we imports only sorts user declared. | |
| 312 | (unless (sort-is-for-regularity? s submodule) | |
| 313 | (add-sort-to-module s module))) | |
| 298 | ;; we imports only sorts user declared. | |
| 299 | (unless (sort-is-for-regularity? s submodule) | |
| 300 | (add-sort-to-module s module))) | |
| 314 | 301 | ;; import error-sorts |
| 315 | 302 | (dolist (s (module-error-sorts submodule)) |
| 316 | (pushnew s (module-error-sorts module) :test #'eq)) | |
| 303 | (pushnew s (module-error-sorts module) :test #'eq)) | |
| 317 | 304 | ;; import sort relations |
| 318 | 305 | (let ((so (module-sort-order module))) |
| 319 | (dolist (sl (module-sort-relations submodule)) | |
| 320 | (let ((new-sl (elim-sys-sorts-from-relation sl))) | |
| 321 | (when new-sl | |
| 322 | (adjoin-sort-relation new-sl module) | |
| 323 | (add-relation-to-order new-sl so))))) | |
| 306 | (dolist (sl (module-sort-relations submodule)) | |
| 307 | (let ((new-sl (elim-sys-sorts-from-relation sl))) | |
| 308 | (when new-sl | |
| 309 | (adjoin-sort-relation new-sl module) | |
| 310 | (add-relation-to-order new-sl so))))) | |
| 324 | 311 | ;; at this point, we want |
| 325 | 312 | ;; import operators + axioms. |
| 326 | 313 | (setf (module-methods-with-rwl-axiom module) |
| 327 | (delete-duplicates (append (module-methods-with-rwl-axiom module) | |
| 328 | (module-methods-with-rwl-axiom | |
| 329 | submodule)) | |
| 330 | :test #'eq)) | |
| 314 | (delete-duplicates (append (module-methods-with-rwl-axiom module) | |
| 315 | (module-methods-with-rwl-axiom | |
| 316 | submodule)) | |
| 317 | :test #'eq)) | |
| 331 | 318 | (setf (module-rules-with-rwl-axiom module) |
| 332 | (delete-duplicates (append (module-rules-with-rwl-axiom module) | |
| 333 | (module-rules-with-rwl-axiom submodule)) | |
| 334 | :test #'eq)) | |
| 319 | (delete-duplicates (append (module-rules-with-rwl-axiom module) | |
| 320 | (module-rules-with-rwl-axiom submodule)) | |
| 321 | :test #'eq)) | |
| 335 | 322 | (let ((opinfos (module-all-operators submodule))) |
| 336 | (dolist (opinfo opinfos) | |
| 337 | (transfer-operator module submodule opinfo nil theory-mod)) | |
| 338 | ) | |
| 339 | ;; #|| | |
| 323 | (dolist (opinfo opinfos) | |
| 324 | (transfer-operator module submodule opinfo nil theory-mod))) | |
| 340 | 325 | ;; import error operators which might be reused. |
| 341 | 326 | ;; (dolist (em (module-error-methods submodule)) |
| 342 | 327 | ;; (when (method-is-user-defined-error-method em) |
| 343 | 328 | ;; (pushnew em (module-error-methods module) :test #'eq))) |
| 344 | 329 | (dolist (em (module-error-methods submodule)) |
| 345 | (pushnew em (module-error-methods module) :test #'eq)) | |
| 346 | ;; ||# | |
| 347 | ;; user defined error ops ----- | |
| 348 | #|| | |
| 349 | (when (module-error-op-decl submodule) | |
| 350 | (format t "~&** importing error operator decl.") | |
| 351 | (setf (module-error-op-decl module) | |
| 352 | (nconc (module-error-op-decl module) | |
| 353 | (copy-tree (module-error-op-decl submodule))))) | |
| 354 | ||# | |
| 355 | #|| | |
| 356 | (dolist (edecl (module-error-op-decl submodule)) | |
| 357 | (eval-ast edecl)) | |
| 358 | ||# | |
| 330 | (pushnew em (module-error-methods module) :test #'eq)) | |
| 359 | 331 | ;; import macros |
| 360 | 332 | (dolist (macro (module-macros submodule)) |
| 361 | (add-macro-to-module module macro)) | |
| 333 | (add-macro-to-module module macro)) | |
| 362 | 334 | ;; |
| 363 | 335 | ;; all done, anyway ... |
| 364 | 336 | ))) |
| 365 | 337 | |
| 366 | 338 | ;;; import module copying |
| 367 | 339 | (defun incorporate-module-copying (module submodule |
| 368 | &optional | |
| 369 | copy-parameters | |
| 370 | theory-module | |
| 371 | (context-module *current-module*)) | |
| 340 | &optional | |
| 341 | copy-parameters | |
| 342 | theory-module | |
| 343 | (context-module *current-module*)) | |
| 372 | 344 | (let ((*import-local-vars* nil) |
| 373 | (imported-params nil)) | |
| 345 | (imported-params nil)) | |
| 374 | 346 | (labels ((import-recreate-sort (s) |
| 375 | (%copy-sort s module nil t)) | |
| 376 | (using-recreate-sort-if-need (sort_) | |
| 377 | (if (and (eq (sort-module sort_) submodule) | |
| 378 | (not (member sort_ | |
| 379 | (module-sorts-for-regularity submodule)))) | |
| 380 | (or (cdr (assq sort_ *import-sort-map*)) | |
| 381 | (let ((news (import-recreate-sort sort_))) | |
| 382 | (when *on-import-debug* | |
| 383 | (format t "~%[copy] putting ~a to *import-sort-map*" | |
| 384 | (cons sort_ news))) | |
| 385 | (push (cons sort_ news) *import-sort-map*) | |
| 386 | news)) | |
| 387 | sort_)) | |
| 388 | ||
| 389 | (using-find-sort (_sort) | |
| 390 | (or (cdr (assq _sort *import-sort-map*)) _sort)) | |
| 391 | ||
| 392 | ;; for debug | |
| 393 | #|| | |
| 394 | (!using-find-sort (_sort) | |
| 395 | (or (cdr (assq _sort *import-sort-map*)) | |
| 396 | (progn (break) _sort))) | |
| 397 | ||# | |
| 398 | (using-import-var (var) | |
| 399 | (let ((nm (variable-name var)) | |
| 400 | (sort (using-find-sort (variable-sort var)))) | |
| 401 | (let ((val (find-variable-in module nm))) | |
| 402 | (if (and val (not (sort= sort (variable-sort val)))) | |
| 403 | (with-output-chaos-warning () | |
| 404 | (princ "imported variable discarded due to name conflict") | |
| 405 | (print-next) | |
| 406 | (format t "with the existing variable: ~a" nm)) | |
| 407 | (unless val | |
| 408 | (setq val (make-variable-term sort nm)) | |
| 409 | (when *copy-variables* | |
| 410 | (push (cons nm val) (module-variables module))) | |
| 411 | (push (cons nm val) *import-local-vars*) | |
| 412 | ))))) | |
| 413 | ;; | |
| 414 | (using-find-sort-err (s) | |
| 415 | (let ((sort (cdr (assq s *import-sort-map*)))) | |
| 416 | (cond (sort sort) | |
| 417 | ((err-sort-p s) | |
| 418 | (setq sort | |
| 419 | (find-compatible-err-sort s module | |
| 420 | *import-sort-map*)) | |
| 421 | (if sort | |
| 422 | (progn | |
| 423 | (when *on-import-debug* | |
| 424 | (format t "~%-- adding import sort map: ~a" | |
| 425 | (cons s sort))) | |
| 426 | (push (cons s sort) *import-sort-map*) | |
| 427 | sort) | |
| 428 | (with-output-panic-message () | |
| 429 | (format t "could not find compatible error sort of ~a" | |
| 430 | s)))) | |
| 431 | (t s)))) | |
| 432 | ;; | |
| 433 | (using-recreate-term (term) | |
| 434 | (cond ((term-is-builtin-constant? term) | |
| 435 | (make-bconst-term (using-find-sort-err (term-sort term)) | |
| 436 | (term-builtin-value term))) | |
| 437 | ((term-is-variable? term) | |
| 438 | (let ((var-name (variable-name term)) | |
| 439 | (new-sort (using-find-sort-err (variable-sort term)))) | |
| 440 | (let ((val2 (assq var-name *import-local-vars*))) | |
| 441 | (if (and val2 (sort= new-sort | |
| 442 | (variable-sort (cdr val2)))) | |
| 443 | (cdr val2) | |
| 444 | (let ((new-var (make-variable-term | |
| 445 | new-sort var-name))) | |
| 446 | (push (cons var-name new-var) | |
| 447 | *import-local-vars*) | |
| 448 | new-var))))) | |
| 449 | ((term-is-lisp-form? term) term) | |
| 450 | (t (let ((head (term-head term))) | |
| 451 | (let ((new-head | |
| 452 | (find-method-in | |
| 453 | module | |
| 454 | (method-symbol head) | |
| 455 | (mapcar #'(lambda (x) | |
| 456 | (using-find-sort-err x)) | |
| 457 | (method-arity head)) | |
| 458 | (using-find-sort-err | |
| 459 | (method-coarity head))))) | |
| 460 | (when (null new-head) | |
| 461 | (when *on-import-debug* | |
| 462 | (format t "~&!! recreate-term null new-head~%") | |
| 463 | (with-in-module (module) | |
| 464 | (print-chaos-object head) | |
| 465 | (format t "~% arity = ~a" (method-arity head)) | |
| 466 | (format t "~% coarity = ~a" | |
| 467 | (method-coarity head)))) | |
| 468 | (setq new-head head)) | |
| 469 | (make-applform (method-coarity new-head) | |
| 470 | new-head | |
| 471 | (mapcar #'(lambda (tm) | |
| 472 | (using-recreate-term tm)) | |
| 473 | (term-subterms term)))))))) | |
| 474 | (using-recreate-axiom (axiom) | |
| 475 | (make-rule :lhs (using-recreate-term (axiom-lhs axiom)) | |
| 476 | :rhs (using-recreate-term (axiom-rhs axiom)) | |
| 477 | :condition (if (is-true? (axiom-condition axiom)) | |
| 478 | *bool-true* | |
| 479 | (using-recreate-term (axiom-condition axiom))) | |
| 480 | :labels (axiom-labels axiom) | |
| 481 | :type (axiom-type axiom) | |
| 482 | :behavioural (axiom-is-behavioural axiom) | |
| 483 | :kind (axiom-kind axiom) | |
| 484 | :meta-and-or (axiom-meta-and-or axiom))) | |
| 485 | ;; | |
| 486 | (using-import-sub (s mode) | |
| 487 | (let ((subs (module-all-submodules module))) | |
| 488 | (unless (assq s subs) | |
| 489 | (if (module-is-parameter-theory s) | |
| 490 | (let ((param-mod s) | |
| 491 | (arg-name (car (module-name s)))) | |
| 492 | (push param-mod imported-params) | |
| 493 | (if (and copy-parameters | |
| 494 | (not (eq (fourth (module-name s)) | |
| 495 | context-module))) | |
| 496 | (import-module-internal module | |
| 497 | mode | |
| 498 | param-mod | |
| 499 | arg-name | |
| 500 | module) | |
| 501 | (progn | |
| 502 | (import-module-internal module | |
| 503 | mode | |
| 504 | param-mod | |
| 505 | nil | |
| 506 | (or theory-module | |
| 507 | submodule)) | |
| 508 | (add-modexp-local-defn (list arg-name | |
| 509 | (module-name module)) | |
| 510 | param-mod) | |
| 511 | (push (cons (cons arg-name param-mod) mode) | |
| 512 | (module-parameters module)) | |
| 513 | ))) | |
| 514 | (if (eq mode :using) | |
| 515 | (using-import-subs s) | |
| 516 | (import-module-internal module | |
| 517 | mode | |
| 518 | s | |
| 519 | nil | |
| 520 | (or theory-module submodule))) | |
| 521 | )))) | |
| 522 | (using-import-subs (smod) | |
| 523 | (dolist (s (reverse (module-direct-submodules smod))) | |
| 524 | (using-import-sub (car s) (cdr s)))) | |
| 525 | ) ; end labels | |
| 347 | (%copy-sort s module nil t)) | |
| 348 | (using-recreate-sort-if-need (sort_) | |
| 349 | (if (and (eq (sort-module sort_) submodule) | |
| 350 | (not (member sort_ | |
| 351 | (module-sorts-for-regularity submodule)))) | |
| 352 | (or (cdr (assq sort_ *import-sort-map*)) | |
| 353 | (let ((news (import-recreate-sort sort_))) | |
| 354 | (when *on-import-debug* | |
| 355 | (format t "~%[copy] putting ~a to *import-sort-map*" | |
| 356 | (cons sort_ news))) | |
| 357 | (push (cons sort_ news) *import-sort-map*) | |
| 358 | news)) | |
| 359 | sort_)) | |
| 360 | ||
| 361 | (using-find-sort (_sort) | |
| 362 | (or (cdr (assq _sort *import-sort-map*)) _sort)) | |
| 363 | ||
| 364 | (using-import-var (var) | |
| 365 | (let ((nm (variable-name var)) | |
| 366 | (sort (using-find-sort (variable-sort var)))) | |
| 367 | (let ((val (find-variable-in module nm))) | |
| 368 | (if (and val (not (sort= sort (variable-sort val)))) | |
| 369 | (with-output-chaos-warning () | |
| 370 | (princ "imported variable discarded due to name conflict") | |
| 371 | (print-next) | |
| 372 | (format t "with the existing variable: ~a" nm)) | |
| 373 | (unless val | |
| 374 | (setq val (make-variable-term sort nm)) | |
| 375 | (when *copy-variables* | |
| 376 | (push (cons nm val) (module-variables module))) | |
| 377 | (push (cons nm val) *import-local-vars*)))))) | |
| 378 | ;; | |
| 379 | (using-find-sort-err (s) | |
| 380 | (let ((sort (cdr (assq s *import-sort-map*)))) | |
| 381 | (cond (sort sort) | |
| 382 | ((err-sort-p s) | |
| 383 | (setq sort | |
| 384 | (find-compatible-err-sort s module | |
| 385 | *import-sort-map*)) | |
| 386 | (if sort | |
| 387 | (progn | |
| 388 | (when *on-import-debug* | |
| 389 | (format t "~%-- adding import sort map: ~a" | |
| 390 | (cons s sort))) | |
| 391 | (push (cons s sort) *import-sort-map*) | |
| 392 | sort) | |
| 393 | (with-output-panic-message () | |
| 394 | (format t "could not find compatible error sort of ~a" | |
| 395 | s)))) | |
| 396 | (t s)))) | |
| 397 | ;; | |
| 398 | (using-recreate-term (term) | |
| 399 | (cond ((term-is-builtin-constant? term) | |
| 400 | (make-bconst-term (using-find-sort-err (term-sort term)) | |
| 401 | (term-builtin-value term))) | |
| 402 | ((term-is-variable? term) | |
| 403 | (let ((var-name (variable-name term)) | |
| 404 | (new-sort (using-find-sort-err (variable-sort term)))) | |
| 405 | (let ((val2 (assq var-name *import-local-vars*))) | |
| 406 | (if (and val2 (sort= new-sort | |
| 407 | (variable-sort (cdr val2)))) | |
| 408 | (cdr val2) | |
| 409 | (let ((new-var (make-variable-term | |
| 410 | new-sort var-name))) | |
| 411 | (push (cons var-name new-var) | |
| 412 | *import-local-vars*) | |
| 413 | new-var))))) | |
| 414 | ((term-is-lisp-form? term) term) | |
| 415 | (t (let ((head (term-head term))) | |
| 416 | (let ((new-head | |
| 417 | (find-method-in | |
| 418 | module | |
| 419 | (method-symbol head) | |
| 420 | (mapcar #'(lambda (x) | |
| 421 | (using-find-sort-err x)) | |
| 422 | (method-arity head)) | |
| 423 | (using-find-sort-err | |
| 424 | (method-coarity head))))) | |
| 425 | (when (null new-head) | |
| 426 | (when *on-import-debug* | |
| 427 | (format t "~%!! recreate-term null new-head~%") | |
| 428 | (with-in-module (module) | |
| 429 | (print-chaos-object head) | |
| 430 | (format t "~% arity = ~a" (method-arity head)) | |
| 431 | (format t "~% coarity = ~a" | |
| 432 | (method-coarity head)))) | |
| 433 | (setq new-head head)) | |
| 434 | (make-applform (method-coarity new-head) | |
| 435 | new-head | |
| 436 | (mapcar #'(lambda (tm) | |
| 437 | (using-recreate-term tm)) | |
| 438 | (term-subterms term)))))))) | |
| 439 | (using-recreate-axiom (axiom) | |
| 440 | (make-rule :lhs (using-recreate-term (axiom-lhs axiom)) | |
| 441 | :rhs (using-recreate-term (axiom-rhs axiom)) | |
| 442 | :condition (if (is-true? (axiom-condition axiom)) | |
| 443 | *bool-true* | |
| 444 | (using-recreate-term (axiom-condition axiom))) | |
| 445 | :labels (axiom-labels axiom) | |
| 446 | :type (axiom-type axiom) | |
| 447 | :behavioural (axiom-is-behavioural axiom) | |
| 448 | :kind (axiom-kind axiom) | |
| 449 | :meta-and-or (axiom-meta-and-or axiom))) | |
| 450 | ;; | |
| 451 | (using-import-sub (s mode) | |
| 452 | (let ((subs (module-all-submodules module))) | |
| 453 | (unless (assq s subs) | |
| 454 | (if (module-is-parameter-theory s) | |
| 455 | (let ((param-mod s) | |
| 456 | (arg-name (car (module-name s)))) | |
| 457 | (push param-mod imported-params) | |
| 458 | (if (and copy-parameters | |
| 459 | (not (eq (fourth (module-name s)) | |
| 460 | context-module))) | |
| 461 | (import-module-internal module | |
| 462 | mode | |
| 463 | param-mod | |
| 464 | arg-name | |
| 465 | module) | |
| 466 | (progn | |
| 467 | (import-module-internal module | |
| 468 | mode | |
| 469 | param-mod | |
| 470 | nil | |
| 471 | (or theory-module | |
| 472 | submodule)) | |
| 473 | (add-modexp-local-defn (list arg-name | |
| 474 | (module-name module)) | |
| 475 | param-mod) | |
| 476 | (push (cons (cons arg-name param-mod) mode) | |
| 477 | (module-parameters module)) | |
| 478 | ))) | |
| 479 | (if (eq mode :using) | |
| 480 | (using-import-subs s) | |
| 481 | (import-module-internal module | |
| 482 | mode | |
| 483 | s | |
| 484 | nil | |
| 485 | (or theory-module submodule))))))) | |
| 486 | (using-import-subs (smod) | |
| 487 | (dolist (s (reverse (module-direct-submodules smod))) | |
| 488 | (using-import-sub (car s) (cdr s)))) | |
| 489 | ) ; end labels | |
| 526 | 490 | ;; |
| 527 | 491 | (with-in-module (module) |
| 528 | ;; *NOTE* : the follwing code is executed in the context of given | |
| 529 | ;; `module' = *current-module*. | |
| 530 | ;; | |
| 531 | ;; import submodules of submodule | |
| 532 | ;; | |
| 533 | (using-import-subs submodule) | |
| 534 | ;; | |
| 535 | ;; import sorts of submodule recreating | |
| 536 | ;; | |
| 537 | (dolist (s (reverse (module-sorts submodule))) | |
| 538 | ; sorts of sub-sumodules should already be | |
| 539 | ; imported at this point. | |
| 540 | (let ((new-sort (using-recreate-sort-if-need s))) | |
| 541 | ; thus, `if-need' is redundant though.. | |
| 542 | (when new-sort | |
| 543 | (add-sort-to-module new-sort module)))) | |
| 544 | ;; | |
| 545 | ;; reconstruct sort relations | |
| 546 | ;; | |
| 547 | (let ((so (module-sort-order module))) | |
| 548 | (dolist (rel (module-sort-relations submodule)) | |
| 549 | (let* ((new-rel (elim-sys-sorts-from-relation rel)) | |
| 550 | (xnew-rel (when new-rel | |
| 551 | (make-sort-relation | |
| 552 | (using-find-sort (sort-relation-sort new-rel)) | |
| 553 | (mapcar #'(lambda (x) (using-find-sort x)) | |
| 554 | (_subsorts new-rel)) | |
| 555 | (mapcar #'(lambda (x) (using-find-sort x)) | |
| 556 | (_supersorts new-rel)))))) | |
| 557 | (when xnew-rel | |
| 558 | (adjoin-sort-relation xnew-rel module)) | |
| 559 | (add-relation-to-order xnew-rel so))) | |
| 560 | (generate-err-sorts so)) | |
| 561 | ;; | |
| 562 | ;; import operators(methods) copying | |
| 563 | ;; | |
| 564 | (let ((m-so-far nil)) | |
| 565 | (dolist (opinfo (reverse (module-all-operators submodule))) | |
| 566 | ; again, operators(methods) of | |
| 567 | ; sub-submodules already be imported at | |
| 568 | ; this point. | |
| 569 | ; BUT, operator object is not created | |
| 570 | ; iff strictly overloaded. thus we must | |
| 571 | ; check ALL operators. | |
| 572 | (let ((op-symbol (operator-symbol (opinfo-operator opinfo)))) | |
| 573 | (dolist (meth (opinfo-methods opinfo)) | |
| 574 | (when (eq submodule (method-module meth)) | |
| 575 | (when (or ;; (method-is-user-defined-error-method meth) | |
| 576 | (and (not (method-is-error-method meth)) | |
| 577 | (not (method-is-user-defined-error-method meth)) | |
| 578 | (not (memq meth | |
| 579 | (module-methods-for-regularity | |
| 580 | submodule))))) | |
| 581 | (let* ((new-arity (mapcar #'(lambda (x) | |
| 582 | (using-find-sort-err x)) | |
| 583 | (method-arity meth))) | |
| 584 | (new-coarity (using-find-sort-err | |
| 585 | (method-coarity meth))) | |
| 586 | (new-meth nil)) | |
| 587 | (when *on-import-debug* | |
| 588 | (format t "~%* trying to make new method ~a:" op-symbol) | |
| 589 | (format t "~% arity = ~a" new-arity) | |
| 590 | (format t "~% coarity = ~a" new-coarity)) | |
| 591 | (setq new-meth (recreate-method submodule | |
| 592 | meth | |
| 593 | module | |
| 594 | op-symbol | |
| 595 | new-arity | |
| 596 | new-coarity | |
| 597 | *import-sort-map*)) | |
| 598 | (push (cons meth new-meth) m-so-far) | |
| 599 | (when *on-import-debug* | |
| 600 | (format t "~%* created method ~a: " new-meth) | |
| 601 | (print-chaos-object new-meth)))))))) | |
| 602 | ||
| 603 | ;; check identity in theory | |
| 604 | (dolist (om-nm m-so-far) | |
| 605 | (let ((meth (car om-nm)) | |
| 606 | (new-meth (cdr om-nm))) | |
| 607 | (let ((theory (method-theory meth (module-opinfo-table submodule)))) | |
| 608 | (when (theory-contains-identity theory) | |
| 609 | (let ((zero (theory-zero theory))) | |
| 610 | (setq zero (cons (using-recreate-term (car zero)) | |
| 611 | (cdr zero))) | |
| 612 | (setf (method-theory new-meth) | |
| 613 | (theory-make (theory-info theory) zero)) | |
| 614 | (compute-method-theory-info-for-matching new-meth))))))) | |
| 615 | ;; | |
| 616 | ;; dumn it! | |
| 617 | ;; | |
| 618 | (dolist (e (reverse (module-opattrs submodule))) | |
| 619 | (eval-ast e)) | |
| 620 | ;; | |
| 621 | ;; vertually import variables copying | |
| 622 | ;; | |
| 623 | (dolist (v (nreverse (mapcar #'cdr (module-variables submodule)))) | |
| 624 | (using-import-var v)) | |
| 625 | ;; (setq *import-local-vars* (module-variables module)) | |
| 626 | ;; inherit principal-sort if defined. | |
| 627 | ;;(break) | |
| 628 | (when (and (module-psort-declaration submodule) | |
| 629 | (null (module-psort-declaration module))) | |
| 630 | (setf (module-psort-declaration module) | |
| 631 | (copy-tree (module-psort-declaration submodule)))) | |
| 632 | ;; | |
| 633 | ;; import error operator declarations | |
| 634 | ;; | |
| 635 | #|| | |
| 636 | (when (module-error-op-decl submodule) | |
| 637 | (setf (module-error-op-decl module) | |
| 638 | (nconc (module-error-op-decl module) | |
| 639 | (copy-tree (module-error-op-decl submodule))))) | |
| 640 | ||# | |
| 641 | (dolist (eop (module-error-op-decl submodule)) | |
| 642 | (when *on-import-debug* | |
| 643 | (with-output-msg () | |
| 644 | (format t "* evaluating imported err op decl:") | |
| 645 | (print-next) (princ " ") | |
| 646 | (print-chaos-object eop))) | |
| 647 | (eval-ast eop)) | |
| 648 | ||
| 649 | ;; | |
| 650 | ;; import variable declarations of error sorts | |
| 651 | ;; | |
| 652 | #|| | |
| 653 | (when (module-error-var-decl submodule) | |
| 654 | (setf (module-error-var-decl module) | |
| 655 | (nconc (module-error-var-decl module) | |
| 656 | (copy-tree (module-error-var-decl submodule))))) | |
| 657 | ||# | |
| 658 | ;; | |
| 659 | ;; copy macros | |
| 660 | ;; | |
| 661 | (dolist (macro (module-macros submodule)) | |
| 662 | (let ((new-macro (make-macro :lhs (using-recreate-term | |
| 663 | (macro-lhs macro)) | |
| 664 | :rhs (using-recreate-term | |
| 665 | (macro-rhs macro))))) | |
| 666 | ;; (print macro) | |
| 667 | (add-macro-to-module module new-macro))) | |
| 668 | ||
| 669 | ;;(eval-psort-declaration (module-psort-declaration submodule) | |
| 670 | ;; module) | |
| 671 | ;; | |
| 672 | ;; import equations & rules copying | |
| 673 | ;; | |
| 674 | (prepare-for-parsing module nil t) | |
| 675 | ;; in this stage, error sorts & methods are all available, | |
| 676 | ;; but there can happen reorganizing operators in different ways, | |
| 677 | ;; thus we need still `check-axiom-error-method'. | |
| 678 | (dolist (e (reverse (module-equations submodule))) | |
| 679 | (adjoin-axiom-to-module module | |
| 680 | (check-axiom-error-method | |
| 681 | module | |
| 682 | (using-recreate-axiom e)))) | |
| 683 | ||
| 684 | (dolist (r (reverse (module-rules submodule))) | |
| 685 | (adjoin-axiom-to-module module | |
| 686 | (check-axiom-error-method | |
| 687 | module | |
| 688 | (using-recreate-axiom r)))) | |
| 689 | ;; | |
| 690 | ;; all done, hopefully | |
| 691 | ;; | |
| 692 | )))) | |
| 492 | ;; *NOTE* : the follwing code is executed in the context of given | |
| 493 | ;; `module' = *current-module*. | |
| 494 | ;; | |
| 495 | ;; import submodules of submodule | |
| 496 | ;; | |
| 497 | (using-import-subs submodule) | |
| 498 | ;; | |
| 499 | ;; import sorts of submodule recreating | |
| 500 | ;; | |
| 501 | (dolist (s (reverse (module-sorts submodule))) | |
| 502 | ; sorts of sub-sumodules should already be | |
| 503 | ; imported at this point. | |
| 504 | (let ((new-sort (using-recreate-sort-if-need s))) | |
| 505 | ; thus, `if-need' is redundant though.. | |
| 506 | (when new-sort | |
| 507 | (add-sort-to-module new-sort module)))) | |
| 508 | ;; | |
| 509 | ;; reconstruct sort relations | |
| 510 | ;; | |
| 511 | (let ((so (module-sort-order module))) | |
| 512 | (dolist (rel (module-sort-relations submodule)) | |
| 513 | (let* ((new-rel (elim-sys-sorts-from-relation rel)) | |
| 514 | (xnew-rel (when new-rel | |
| 515 | (make-sort-relation | |
| 516 | (using-find-sort (sort-relation-sort new-rel)) | |
| 517 | (mapcar #'(lambda (x) (using-find-sort x)) | |
| 518 | (_subsorts new-rel)) | |
| 519 | (mapcar #'(lambda (x) (using-find-sort x)) | |
| 520 | (_supersorts new-rel)))))) | |
| 521 | (when xnew-rel | |
| 522 | (adjoin-sort-relation xnew-rel module)) | |
| 523 | (add-relation-to-order xnew-rel so))) | |
| 524 | (generate-err-sorts so)) | |
| 525 | ;; | |
| 526 | ;; import operators(methods) copying | |
| 527 | ;; | |
| 528 | (let ((m-so-far nil)) | |
| 529 | (dolist (opinfo (reverse (module-all-operators submodule))) | |
| 530 | ; again, operators(methods) of | |
| 531 | ; sub-submodules already be imported at | |
| 532 | ; this point. | |
| 533 | ; BUT, operator object is not created | |
| 534 | ; iff strictly overloaded. thus we must | |
| 535 | ; check ALL operators. | |
| 536 | (let ((op-symbol (operator-symbol (opinfo-operator opinfo)))) | |
| 537 | (dolist (meth (opinfo-methods opinfo)) | |
| 538 | (when (eq submodule (method-module meth)) | |
| 539 | (when (or ;; (method-is-user-defined-error-method meth) | |
| 540 | (and (not (method-is-error-method meth)) | |
| 541 | (not (method-is-user-defined-error-method meth)) | |
| 542 | (not (memq meth | |
| 543 | (module-methods-for-regularity | |
| 544 | submodule))))) | |
| 545 | (let* ((new-arity (mapcar #'(lambda (x) | |
| 546 | (using-find-sort-err x)) | |
| 547 | (method-arity meth))) | |
| 548 | (new-coarity (using-find-sort-err | |
| 549 | (method-coarity meth))) | |
| 550 | (new-meth nil)) | |
| 551 | (when *on-import-debug* | |
| 552 | (format t "~%* trying to make new method ~a:" op-symbol) | |
| 553 | (format t "~% arity = ~a" new-arity) | |
| 554 | (format t "~% coarity = ~a" new-coarity)) | |
| 555 | (setq new-meth (recreate-method submodule | |
| 556 | meth | |
| 557 | module | |
| 558 | op-symbol | |
| 559 | new-arity | |
| 560 | new-coarity | |
| 561 | *import-sort-map*)) | |
| 562 | (push (cons meth new-meth) m-so-far) | |
| 563 | (when *on-import-debug* | |
| 564 | (format t "~%* created method ~a: " new-meth) | |
| 565 | (print-chaos-object new-meth)))))))) | |
| 566 | ||
| 567 | ;; check identity in theory | |
| 568 | (dolist (om-nm m-so-far) | |
| 569 | (let ((meth (car om-nm)) | |
| 570 | (new-meth (cdr om-nm))) | |
| 571 | (let ((theory (method-theory meth (module-opinfo-table submodule)))) | |
| 572 | (when (theory-contains-identity theory) | |
| 573 | (let ((zero (theory-zero theory))) | |
| 574 | (setq zero (cons (using-recreate-term (car zero)) | |
| 575 | (cdr zero))) | |
| 576 | (setf (method-theory new-meth) | |
| 577 | (theory-make (theory-info theory) zero)) | |
| 578 | (compute-method-theory-info-for-matching new-meth))))))) | |
| 579 | ;; | |
| 580 | ;; dumn it! | |
| 581 | ;; | |
| 582 | (dolist (e (reverse (module-opattrs submodule))) | |
| 583 | (eval-ast e)) | |
| 584 | ;; | |
| 585 | ;; vertually import variables copying | |
| 586 | ;; | |
| 587 | (dolist (v (nreverse (mapcar #'cdr (module-variables submodule)))) | |
| 588 | (using-import-var v)) | |
| 589 | ;; (setq *import-local-vars* (module-variables module)) | |
| 590 | ;; inherit principal-sort if defined. | |
| 591 | ;;(break) | |
| 592 | (when (and (module-psort-declaration submodule) | |
| 593 | (null (module-psort-declaration module))) | |
| 594 | (setf (module-psort-declaration module) | |
| 595 | (copy-tree (module-psort-declaration submodule)))) | |
| 596 | ;; | |
| 597 | ;; import error operator declarations | |
| 598 | ;; | |
| 599 | (dolist (eop (module-error-op-decl submodule)) | |
| 600 | (when *on-import-debug* | |
| 601 | (with-output-msg () | |
| 602 | (format t "* evaluating imported err op decl:") | |
| 603 | (print-next) (princ " ") | |
| 604 | (print-chaos-object eop))) | |
| 605 | (eval-ast eop)) | |
| 606 | ||
| 607 | ;; | |
| 608 | ;; import variable declarations of error sorts | |
| 609 | ;; nothing todo ... NO TODO | |
| 610 | ||
| 611 | ;; | |
| 612 | ;; copy macros | |
| 613 | ;; | |
| 614 | (dolist (macro (module-macros submodule)) | |
| 615 | (let ((new-macro (make-macro :lhs (using-recreate-term | |
| 616 | (macro-lhs macro)) | |
| 617 | :rhs (using-recreate-term | |
| 618 | (macro-rhs macro))))) | |
| 619 | ;; (print macro) | |
| 620 | (add-macro-to-module module new-macro))) | |
| 621 | ||
| 622 | ;; | |
| 623 | ;; import equations & rules copying | |
| 624 | ;; | |
| 625 | (prepare-for-parsing module nil t) | |
| 626 | ;; in this stage, error sorts & methods are all available, | |
| 627 | ;; but there can happen reorganizing operators in different ways, | |
| 628 | ;; thus we need still `check-axiom-error-method'. | |
| 629 | (dolist (e (reverse (module-equations submodule))) | |
| 630 | (adjoin-axiom-to-module module | |
| 631 | (check-axiom-error-method | |
| 632 | module | |
| 633 | (using-recreate-axiom e)))) | |
| 634 | ||
| 635 | (dolist (r (reverse (module-rules submodule))) | |
| 636 | (adjoin-axiom-to-module module | |
| 637 | (check-axiom-error-method | |
| 638 | module | |
| 639 | (using-recreate-axiom r)))) | |
| 640 | ;; | |
| 641 | ;; all done, hopefully | |
| 642 | ;; | |
| 643 | )))) | |
| 693 | 644 | |
| 694 | 645 | ;;; TRANSFER-OPERATOR : Module Module OpInfo -> Void |
| 695 | 646 | ;;; |
| 696 | 647 | (defun transfer-operator (module from-module opinfo &optional (given-opinfos nil) |
| 697 | theory-mod) | |
| 648 | theory-mod) | |
| 698 | 649 | (let* ((opinfos given-opinfos) |
| 699 | (from-op (opinfo-operator opinfo)) | |
| 700 | (proto-method (car (opinfo-methods opinfo))) | |
| 701 | (a-len (length (method-arity proto-method))) | |
| 702 | (new-op nil) | |
| 703 | (new-opinfo nil)) | |
| 650 | (from-op (opinfo-operator opinfo)) | |
| 651 | (proto-method (car (opinfo-methods opinfo))) | |
| 652 | (a-len (length (method-arity proto-method))) | |
| 653 | (new-op nil) | |
| 654 | (new-opinfo nil)) | |
| 704 | 655 | ;; |
| 705 | 656 | (when *on-import-debug* |
| 706 | 657 | (format t "~&[transfer-operator]: ~a from " (operator-symbol from-op)) |
| 710 | 661 | ;; |
| 711 | 662 | (unless opinfos |
| 712 | 663 | (setq opinfos (find-operators-in-module (operator-symbol from-op) |
| 713 | a-len | |
| 714 | module))) | |
| 664 | a-len | |
| 665 | module))) | |
| 715 | 666 | ;; |
| 716 | 667 | (with-in-module (module) |
| 717 | 668 | (let ((from-opinfo (module-opinfo-table from-module)) |
| 718 | (to-opinfo (module-opinfo-table module)) | |
| 719 | (so (module-sort-order module))) | |
| 720 | ;; find the method group to be inserted | |
| 721 | #|| | |
| 722 | (dolist (method (opinfo-methods opinfo)) | |
| 723 | (when (or (method-is-user-defined-error-method method) | |
| 724 | (and (not (method-is-error-method method)) | |
| 725 | (not (method-is-for-regularity? method from-module)))) | |
| 726 | (setq new-opinfo | |
| 727 | (dolist (x opinfos nil) | |
| 728 | (when (or (null (method-arity method)) | |
| 729 | (is-in-same-connected-component* | |
| 730 | (method-coarity method) | |
| 731 | (method-coarity (or (cadr (opinfo-methods x)) | |
| 732 | (car (opinfo-methods x)))) | |
| 733 | so)) | |
| 734 | (return x)))) | |
| 735 | (return nil))) | |
| 736 | ||# | |
| 737 | (dolist (method (opinfo-methods opinfo)) | |
| 738 | (when (and (not (method-is-error-method method)) | |
| 739 | (not (method-is-for-regularity? method from-module))) | |
| 740 | (setq new-opinfo | |
| 741 | (dolist (x opinfos nil) | |
| 742 | (when (or (null (method-arity method)) | |
| 743 | (is-in-same-connected-component* | |
| 744 | (method-coarity method) | |
| 745 | (method-coarity (or (cadr (opinfo-methods x)) | |
| 746 | (car (opinfo-methods x)))) | |
| 747 | so)) | |
| 748 | (return x)))) | |
| 749 | (return nil))) | |
| 750 | ;; create new operaotr info if could not find. | |
| 751 | (cond (new-opinfo | |
| 752 | (setq new-op (opinfo-operator new-opinfo)) | |
| 753 | ) | |
| 754 | (t | |
| 755 | (when *on-import-debug* | |
| 756 | (format t "~%* creating new opinfo for operator ~s : " | |
| 757 | (opinfo-operator opinfo)) | |
| 758 | (print-chaos-object (opinfo-operator opinfo))) | |
| 759 | ;; | |
| 760 | (setq new-op (opinfo-operator opinfo)) | |
| 761 | (setq new-opinfo | |
| 762 | (make-opinfo :operator new-op)) | |
| 763 | (push new-opinfo (module-all-operators module)) | |
| 764 | (push new-opinfo opinfos))) | |
| 765 | ;; add to symbol table : 2012/07/15 | |
| 766 | (symbol-table-add (module-symbol-table module) (first (operator-name new-op)) new-op) | |
| 767 | ;; | |
| 768 | (dolist (method (reverse (opinfo-methods opinfo))) | |
| 769 | ;; | |
| 770 | (when (or (method-is-user-defined-error-method method) | |
| 771 | (and (not (method-is-error-method method)) | |
| 772 | (not (method-is-for-regularity? method from-module)))) | |
| 773 | (when *on-import-debug* | |
| 774 | (format t "~&-- importing method ~s : " method) | |
| 775 | (print-chaos-object method)) | |
| 776 | ;; | |
| 777 | #|| | |
| 778 | (when (modexp-add-method-to-table new-opinfo method module) | |
| 779 | (when *on-import-debug* | |
| 780 | (format t "~&-- importing method-theory ~s:" | |
| 781 | (method-theory method from-opinfo)) | |
| 782 | (finish-output *error-output*))) | |
| 783 | ||# | |
| 784 | (modexp-add-method-to-table new-opinfo method module) | |
| 785 | (transfer-operator-attributes method module from-module theory-mod) | |
| 786 | ;; import axioms | |
| 787 | (let ((all-rules (module-all-rules module))) | |
| 788 | (dolist (rule (rule-ring-to-list | |
| 789 | (method-rules-with-same-top method from-opinfo))) | |
| 790 | (when (or (not (memq rule all-rules)) | |
| 791 | (eq method (term-head (axiom-lhs rule)))) | |
| 792 | (when *on-import-debug* | |
| 793 | (with-in-module (from-module) | |
| 794 | (format t "~%-- importing axiom ") | |
| 795 | (print-chaos-object rule) | |
| 796 | (format t "~% for method : ") | |
| 797 | (print-chaos-object method))) | |
| 798 | (add-rule-to-method (check-axiom-error-method module rule) | |
| 799 | method to-opinfo) | |
| 800 | (pushnew rule (module-all-rules module) :test #'rule-is-similar?) | |
| 801 | ) | |
| 802 | ) | |
| 803 | ;; | |
| 804 | (dolist (r (reverse (method-rules-with-different-top method | |
| 805 | from-opinfo))) | |
| 806 | (when (or (not (memq r all-rules)) | |
| 807 | (eq method (term-head (axiom-lhs r)))) | |
| 808 | (when *on-import-debug* | |
| 809 | (with-in-module (from-module) | |
| 810 | (format t "~%-- importing axiom ") | |
| 811 | (print-chaos-object r) | |
| 812 | (format t "~% for method : ") | |
| 813 | (print-chaos-object method))) | |
| 814 | (add-rule-to-method (check-axiom-error-method module r) | |
| 815 | method to-opinfo) | |
| 816 | (pushnew r (module-all-rules module) :test #'rule-is-similar?))) | |
| 817 | ))) | |
| 818 | ||
| 819 | ;; | |
| 820 | #|| | |
| 821 | (dolist (method (reverse (opinfo-methods opinfo))) | |
| 822 | (when (and ;; (not (method-is-error-method method)) | |
| 823 | (not (method-is-for-regularity? method from-module))) | |
| 824 | (when *on-import-debug* | |
| 825 | (format t "~&-- importing method ~s : " method) | |
| 826 | (print-chaos-object method)) | |
| 827 | ;; | |
| 828 | ;;#|| | |
| 829 | (when (modexp-add-method-to-table new-opinfo method module) | |
| 830 | (when *on-import-debug* | |
| 831 | (format t "~&-- importing method-theory ~s:" | |
| 832 | (method-theory method from-opinfo)) | |
| 833 | (finish-output *error-output*))) | |
| 834 | ;; ||# | |
| 835 | (modexp-add-method-to-table new-opinfo method module) | |
| 836 | (transfer-operator-attributes method module from-module theory-mod) | |
| 837 | ;; import axioms | |
| 838 | (let ((all-rules (module-all-rules module))) | |
| 839 | (dolist (rule (rule-ring-to-list | |
| 840 | (method-rules-with-same-top method from-opinfo))) | |
| 841 | (when (or (not (memq rule all-rules)) | |
| 842 | (eq method (term-head (axiom-lhs rule)))) | |
| 843 | (when *on-import-debug* | |
| 844 | (with-in-module (from-module) | |
| 845 | (format t "~%-- importing axiom ") | |
| 846 | (print-chaos-object rule) | |
| 847 | (format t "~% for method : ") | |
| 848 | (print-chaos-object method))) | |
| 849 | (add-rule-to-method (check-axiom-error-method module rule) | |
| 850 | method to-opinfo) | |
| 851 | (pushnew rule (module-all-rules module) :test #'rule-is-similar?) | |
| 852 | ) | |
| 853 | ) | |
| 854 | ;; | |
| 855 | (dolist (r (reverse (method-rules-with-different-top method | |
| 856 | from-opinfo))) | |
| 857 | (when (or (not (memq r all-rules)) | |
| 858 | (eq method (term-head (axiom-lhs r)))) | |
| 859 | (when *on-import-debug* | |
| 860 | (with-in-module (from-module) | |
| 861 | (format t "~%-- importing axiom ") | |
| 862 | (print-chaos-object r) | |
| 863 | (format t "~% for method : ") | |
| 864 | (print-chaos-object method))) | |
| 865 | (add-rule-to-method (check-axiom-error-method module r) | |
| 866 | method to-opinfo) | |
| 867 | (pushnew r (module-all-rules module) :test #'rule-is-similar?))) | |
| 868 | ))) | |
| 869 | ||# | |
| 870 | ;; | |
| 871 | (when *on-import-debug* | |
| 872 | (format t "~&* done transfer-operator")) | |
| 873 | )) | |
| 874 | )) | |
| 669 | (to-opinfo (module-opinfo-table module)) | |
| 670 | (so (module-sort-order module))) | |
| 671 | ;; find the method group to be inserted | |
| 672 | (dolist (method (opinfo-methods opinfo)) | |
| 673 | (when (and (not (method-is-error-method method)) | |
| 674 | (not (method-is-for-regularity? method from-module))) | |
| 675 | (setq new-opinfo | |
| 676 | (dolist (x opinfos nil) | |
| 677 | (when (or (null (method-arity method)) | |
| 678 | (is-in-same-connected-component* | |
| 679 | (method-coarity method) | |
| 680 | (method-coarity (or (cadr (opinfo-methods x)) | |
| 681 | (car (opinfo-methods x)))) | |
| 682 | so)) | |
| 683 | (return x)))) | |
| 684 | (return nil))) | |
| 685 | ;; create new operaotr info if could not find. | |
| 686 | (cond (new-opinfo | |
| 687 | (setq new-op (opinfo-operator new-opinfo))) | |
| 688 | (t | |
| 689 | (when *on-import-debug* | |
| 690 | (format t "~%* creating new opinfo for operator ~s : " | |
| 691 | (opinfo-operator opinfo)) | |
| 692 | (print-chaos-object (opinfo-operator opinfo))) | |
| 693 | ;; | |
| 694 | (setq new-op (opinfo-operator opinfo)) | |
| 695 | (setq new-opinfo | |
| 696 | (make-opinfo :operator new-op)) | |
| 697 | (push new-opinfo (module-all-operators module)) | |
| 698 | (push new-opinfo opinfos))) | |
| 699 | ;; add to symbol table : 2012/07/15 | |
| 700 | (symbol-table-add (module-symbol-table module) (first (operator-name new-op)) new-op) | |
| 701 | ;; | |
| 702 | (dolist (method (reverse (opinfo-methods opinfo))) | |
| 703 | ;; | |
| 704 | (when (or (method-is-user-defined-error-method method) | |
| 705 | (and (not (method-is-error-method method)) | |
| 706 | (not (method-is-for-regularity? method from-module)))) | |
| 707 | (when *on-import-debug* | |
| 708 | (format t "~%-- importing method ~s : " method) | |
| 709 | (print-chaos-object method)) | |
| 710 | (modexp-add-method-to-table new-opinfo method module) | |
| 711 | (transfer-operator-attributes method module from-module theory-mod) | |
| 712 | ;; import axioms | |
| 713 | (let ((all-rules (module-all-rules module))) | |
| 714 | (dolist (rule (rule-ring-to-list | |
| 715 | (method-rules-with-same-top method from-opinfo))) | |
| 716 | (when (or (not (memq rule all-rules)) | |
| 717 | (eq method (term-head (axiom-lhs rule)))) | |
| 718 | (when *on-import-debug* | |
| 719 | (with-in-module (from-module) | |
| 720 | (format t "~%-- importing axiom ") | |
| 721 | (print-chaos-object rule) | |
| 722 | (format t "~% for method : ") | |
| 723 | (print-chaos-object method))) | |
| 724 | (add-rule-to-method (check-axiom-error-method module rule) | |
| 725 | method to-opinfo) | |
| 726 | (pushnew rule (module-all-rules module) :test #'rule-is-similar?))) | |
| 727 | ;; | |
| 728 | (dolist (r (reverse (method-rules-with-different-top method | |
| 729 | from-opinfo))) | |
| 730 | (when (or (not (memq r all-rules)) | |
| 731 | (eq method (term-head (axiom-lhs r)))) | |
| 732 | (when *on-import-debug* | |
| 733 | (with-in-module (from-module) | |
| 734 | (format t "~%-- importing axiom ") | |
| 735 | (print-chaos-object r) | |
| 736 | (format t "~% for method : ") | |
| 737 | (print-chaos-object method))) | |
| 738 | (add-rule-to-method (check-axiom-error-method module r) | |
| 739 | method to-opinfo) | |
| 740 | (pushnew r (module-all-rules module) :test #'rule-is-similar?))) | |
| 741 | ))) | |
| 742 | (when *on-import-debug* | |
| 743 | (format t "~%* done transfer-operator")))))) | |
| 875 | 744 | |
| 876 | 745 | (defun modexp-add-method-to-table (opinfo method module) |
| 877 | 746 | (let ((pmeth (find method (opinfo-methods opinfo) |
| 878 | :test #'(lambda (x y) | |
| 879 | (and (sort-list= (method-arity x) | |
| 880 | (method-arity y)) | |
| 881 | (sort= (method-coarity x) | |
| 882 | (method-coarity y)))))) | |
| 883 | (method-info-table (module-opinfo-table module))) | |
| 884 | (if (eq pmeth method) ; (or (eq pmeth method) | |
| 885 | ; ;; dirty kludge! | |
| 886 | ; (and pmeth (method-is-of-same-operator-safe method *rwl-predicate*))) | |
| 887 | nil | |
| 747 | :test #'(lambda (x y) | |
| 748 | (and (sort-list= (method-arity x) | |
| 749 | (method-arity y)) | |
| 750 | (sort= (method-coarity x) | |
| 751 | (method-coarity y)))))) | |
| 752 | (method-info-table (module-opinfo-table module))) | |
| 753 | (if (eq pmeth method) | |
| 754 | nil | |
| 888 | 755 | (progn |
| 889 | (setf (get-method-info method method-info-table) | |
| 890 | (make-method-info method | |
| 891 | module | |
| 892 | (opinfo-operator opinfo))) | |
| 893 | (pushnew method (opinfo-methods opinfo)) | |
| 894 | (setf (opinfo-method-table opinfo) nil) | |
| 895 | (when (method-is-behavioural method) | |
| 896 | (if (sort-is-hidden (method-coarity method)) | |
| 897 | (pushnew method (module-beh-methods module)) | |
| 898 | (pushnew method (module-beh-attributes module)))) | |
| 899 | t)))) | |
| 756 | (setf (get-method-info method method-info-table) | |
| 757 | (make-method-info method | |
| 758 | module | |
| 759 | (opinfo-operator opinfo))) | |
| 760 | (pushnew method (opinfo-methods opinfo)) | |
| 761 | (setf (opinfo-method-table opinfo) nil) | |
| 762 | (when (method-is-behavioural method) | |
| 763 | (if (sort-is-hidden (method-coarity method)) | |
| 764 | (pushnew method (module-beh-methods module)) | |
| 765 | (pushnew method (module-beh-attributes module)))) | |
| 766 | t)))) | |
| 900 | 767 | |
| 901 | 768 | (defun transfer-operator-attributes (method to-module from-module |
| 902 | &optional theory-mod) | |
| 769 | &optional theory-mod) | |
| 903 | 770 | ;; transfer operator theory |
| 904 | 771 | (transfer-operator-theory method to-module from-module theory-mod) |
| 905 | 772 | ;; transfer other attributes |
| 906 | 773 | (transfer-operator-attrs method to-module from-module theory-mod)) |
| 907 | 774 | |
| 908 | 775 | (defun transfer-operator-theory (method to-module from-module |
| 909 | &optional theory-mod) | |
| 776 | &optional theory-mod) | |
| 910 | 777 | (let ((new-theory (modexp-merge-operator-theory method |
| 911 | to-module | |
| 912 | from-module | |
| 913 | theory-mod))) | |
| 778 | to-module | |
| 779 | from-module | |
| 780 | theory-mod))) | |
| 914 | 781 | (when new-theory |
| 915 | 782 | (setf (method-theory method (module-opinfo-table to-module)) |
| 916 | new-theory) | |
| 783 | new-theory) | |
| 917 | 784 | (compute-method-theory-info-for-matching method |
| 918 | (module-opinfo-table to-module)) | |
| 919 | ))) | |
| 785 | (module-opinfo-table to-module))))) | |
| 920 | 786 | |
| 921 | 787 | (defun modexp-merge-operator-theory (method to-module from-module |
| 922 | &optional theory-mod) | |
| 788 | &optional theory-mod) | |
| 923 | 789 | (let* ((to-opinfo (module-opinfo-table to-module)) |
| 924 | (th1 (method-theory method to-opinfo)) | |
| 925 | (from-opinfo (if theory-mod | |
| 926 | (module-opinfo-table theory-mod) | |
| 927 | (module-opinfo-table from-module))) | |
| 928 | (th2 (method-theory method from-opinfo))) | |
| 790 | (th1 (method-theory method to-opinfo)) | |
| 791 | (from-opinfo (if theory-mod | |
| 792 | (module-opinfo-table theory-mod) | |
| 793 | (module-opinfo-table from-module))) | |
| 794 | (th2 (method-theory method from-opinfo))) | |
| 929 | 795 | (merge-operator-theory-in to-module method th1 th2))) |
| 930 | 796 | |
| 931 | 797 | (defun transfer-operator-attrs (meth to-module from-module &optional theory-mod) |
| 932 | 798 | (declare (ignore theory-mod)) |
| 933 | 799 | (let ((coh nil) |
| 934 | (meta-demod nil)) | |
| 800 | (meta-demod nil)) | |
| 935 | 801 | (with-in-module (from-module) |
| 936 | 802 | (setq coh (method-is-coherent meth)) |
| 937 | 803 | (setq meta-demod (method-is-meta-demod meth))) |
| 938 | 804 | (with-in-module (to-module) |
| 939 | 805 | (setf (method-is-coherent meth) coh) |
| 940 | (setf (method-is-meta-demod meth) meta-demod)) | |
| 941 | )) | |
| 806 | (setf (method-is-meta-demod meth) meta-demod)))) | |
| 942 | 807 | |
| 943 | 808 | ;;; ***************************************** |
| 944 | 809 | ;;; AUTOMATIC IMPORATION OF BUILT-IN MODULES.___________________________________ |
| 956 | 821 | (with-in-module (module) |
| 957 | 822 | (eval-import-modexp *import-hard-wired-ast*)))) |
| 958 | 823 | |
| 959 | #|| | |
| 960 | (defun include-BOOL (&optional (module *current-module*)) | |
| 961 | (when *include-BOOL* | |
| 962 | (unless (memq *Bool-sort* | |
| 963 | (module-all-sorts module)) | |
| 964 | (with-in-module (module) | |
| 965 | (eval-import-modexp *import-bool-ast*)))) | |
| 966 | (include-chaos-module) | |
| 967 | ) | |
| 968 | ||# | |
| 969 | ||
| 970 | 824 | (defun include-BOOL (&optional (module *current-module*)) |
| 971 | 825 | (when *include-BOOL* |
| 972 | 826 | (unless (assq *bool-module* |
| 973 | (module-all-submodules module)) | |
| 827 | (module-all-submodules module)) | |
| 974 | 828 | (with-in-module (module) |
| 975 | (eval-import-modexp *import-bool-ast*)))) | |
| 976 | (include-chaos-module) | |
| 977 | ) | |
| 829 | (eval-import-modexp *import-bool-ast*)))) | |
| 830 | (include-chaos-module)) | |
| 978 | 831 | |
| 979 | 832 | (defparameter *import-object-ast* |
| 980 | 833 | (%import* :extending (%modexp* "OBJECT"))) |
| 981 | 834 | |
| 982 | 835 | (defun include-object () |
| 983 | 836 | (unless (memq *class-id-sort* |
| 984 | (module-all-sorts *current-module*)) | |
| 985 | (eval-import-modexp *import-object-ast*) | |
| 986 | )) | |
| 837 | (module-all-sorts *current-module*)) | |
| 838 | (eval-import-modexp *import-object-ast*))) | |
| 987 | 839 | |
| 988 | 840 | (defparameter *import-record-ast* |
| 989 | 841 | (%import* :extending (%modexp* "RECORD-STRUCTURE"))) |
| 990 | 842 | |
| 991 | 843 | (defun include-record () |
| 992 | 844 | (unless (memq *record-id-sort* |
| 993 | (module-all-sorts *current-module*)) | |
| 845 | (module-all-sorts *current-module*)) | |
| 994 | 846 | (eval-import-modexp *import-record-ast*))) |
| 995 | 847 | |
| 996 | 848 | (defparameter *import-rwl-ast* |
| 997 | 849 | (%import* :protecting (%modexp* "RWL"))) |
| 998 | 850 | |
| 999 | (defun include-rwl (&optional (module (or *current-module* *last-module*))) | |
| 851 | (defun include-rwl (&optional (module (get-context-module))) | |
| 1000 | 852 | (when *include-rwl* |
| 1001 | 853 | (unless (module-includes-rwl module) |
| 1002 | 854 | (with-in-module (module) |
| 1003 | (eval-import-modexp *import-rwl-ast*) | |
| 1004 | ))) | |
| 1005 | ) | |
| 855 | (eval-import-modexp *import-rwl-ast*))))) | |
| 1006 | 856 | |
| 1007 | 857 | ;;; |
| 1008 | 858 | ;;; IMPORT-VARIABLES |
| 1011 | 861 | (let ((vs (module-variables from))) |
| 1012 | 862 | (dolist (v vs) |
| 1013 | 863 | (let ((s (find-sort-in to (sort-id (variable-sort v)))) |
| 1014 | (name (variable-name v))) | |
| 1015 | (if s | |
| 1016 | (push (cons name (make-variable-term s name)) | |
| 1017 | (module-variables to)) | |
| 1018 | (with-output-chaos-warning () | |
| 1019 | (format t "importing variable ~a, could not find sort ~a" | |
| 1020 | name | |
| 1021 | (sort-id (variable-sort v))))))) | |
| 1022 | )) | |
| 864 | (name (variable-name v))) | |
| 865 | (if s | |
| 866 | (push (cons name (make-variable-term s name)) | |
| 867 | (module-variables to)) | |
| 868 | (with-output-chaos-warning () | |
| 869 | (format t "importing variable ~a, could not find sort ~a" | |
| 870 | name | |
| 871 | (sort-id (variable-sort v))))))))) | |
| 1023 | 872 | |
| 1024 | 873 | ;;; EOF |
| 0 | 0 | ** |
| 1 | ** Copyright (c) 2000-2014, Toshimi Sawada. All rights reserved. | |
| 1 | ** Copyright (c) 2000-2015, Toshimi Sawada. All rights reserved. | |
| 2 | 2 | ** |
| 3 | 3 | ** Redistribution and use in source and binary forms, with or without |
| 4 | 4 | ** modification, are permitted provided that the following conditions |
| 52 | 52 | var L : MapList |
| 53 | 53 | |
| 54 | 54 | eq sort X -> Y, L, sort X -> Z |
| 55 | = L, sort X -> Z . | |
| 55 | = L, sort X -> Z . | |
| 56 | 56 | eq op X -> Y, L, op X -> Z |
| 57 | = L, op X -> Z . | |
| 57 | = L, op X -> Z . | |
| 58 | 58 | } |
| 59 | 59 | |
| 60 | 60 | } |
| 0 | 0 | ;;;-*- Mode:LISP; Package:CHAOS; Base:10; Syntax:Common-lisp -*- |
| 1 | 1 | ;;; |
| 2 | ;;; Copyright (c) 2000-2014, Toshimi Sawada. All rights reserved. | |
| 2 | ;;; Copyright (c) 2000-2015, Toshimi Sawada. All rights reserved. | |
| 3 | 3 | ;;; |
| 4 | 4 | ;;; Redistribution and use in source and binary forms, with or without |
| 5 | 5 | ;;; modification, are permitted provided that the following conditions |
| 27 | 27 | ;;; |
| 28 | 28 | (in-package :chaos) |
| 29 | 29 | #|============================================================================== |
| 30 | System: CHAOS | |
| 31 | Module: deCafe | |
| 32 | File: modmorph.lisp | |
| 30 | System: CHAOS | |
| 31 | Module: deCafe | |
| 32 | File: modmorph.lisp | |
| 33 | 33 | ==============================================================================|# |
| 34 | 34 | #-:chaos-debug |
| 35 | 35 | (declaim (optimize (speed 3) (safety 0) #-GCL (debug 0))) |
| 59 | 59 | (defun apply-modmorph (name morph mod) |
| 60 | 60 | (let ((newmod (cdr (assq mod (modmorph-module morph))))) |
| 61 | 61 | (if newmod |
| 62 | ;; given mod already mapped, change its name by given one. | |
| 63 | (setf (module-name newmod) name) | |
| 64 | (progn | |
| 65 | ;; construct new module using given name. | |
| 66 | (setq newmod (or *modmorph-new-module* | |
| 67 | (!create-module name))) | |
| 68 | ;; register module map. | |
| 69 | (push (cons mod newmod) (modmorph-module morph)))) | |
| 62 | ;; given mod already mapped, change its name by given one. | |
| 63 | (setf (module-name newmod) name) | |
| 64 | (progn | |
| 65 | ;; construct new module using given name. | |
| 66 | (setq newmod (or *modmorph-new-module* | |
| 67 | (!create-module name))) | |
| 68 | ;; register module map. | |
| 69 | (push (cons mod newmod) (modmorph-module morph)))) | |
| 70 | 70 | ;; apply the morphism |
| 71 | 71 | (with-in-module (newmod) |
| 72 | 72 | (apply-modmorph-internal morph mod newmod)))) |
| 78 | 78 | (defun apply-modmorph* (nm morph mod) |
| 79 | 79 | (let ((newmod (cdr (assq mod (modmorph-module morph))))) |
| 80 | 80 | (if newmod |
| 81 | (setf (module-name newmod) nm) | |
| 82 | (progn | |
| 83 | (setq newmod (create-module nm)) | |
| 84 | (push (cons mod newmod) (modmorph-module morph)))) | |
| 81 | (setf (module-name newmod) nm) | |
| 82 | (progn | |
| 83 | (setq newmod (create-module nm)) | |
| 84 | (push (cons mod newmod) (modmorph-module morph)))) | |
| 85 | 85 | (apply-modmorph-internal morph mod newmod))) |
| 86 | 86 | |
| 87 | 87 | ;;;----------------------------------------------------------------------------- |
| 94 | 94 | |
| 95 | 95 | (defun apply-modmorph-internal (map mod newmod) |
| 96 | 96 | (flet ((inherit-principal-sort (s s-mapped) |
| 97 | (when (and (null (module-principal-sort newmod)) | |
| 98 | (sort= s (module-principal-sort mod))) | |
| 99 | ;; this will be evaluated later on compilation stage. | |
| 100 | (setf (module-psort-declaration newmod) | |
| 101 | (%psort-decl* s-mapped)) | |
| 102 | ;; the following seems redundant, but there are | |
| 103 | ;; some cases the real module compilation is not done | |
| 104 | ;; while evaluating modexprs, and we also want | |
| 105 | ;; psort-declaration for consistency. | |
| 106 | (setf (module-principal-sort newmod) s-mapped) | |
| 107 | )) | |
| 108 | ) | |
| 97 | (when (and (null (module-principal-sort newmod)) | |
| 98 | (sort= s (module-principal-sort mod))) | |
| 99 | ;; this will be evaluated later on compilation stage. | |
| 100 | (setf (module-psort-declaration newmod) | |
| 101 | (%psort-decl* s-mapped)) | |
| 102 | ;; the following seems redundant, but there are | |
| 103 | ;; some cases the real module compilation is not done | |
| 104 | ;; while evaluating modexprs, and we also want | |
| 105 | ;; psort-declaration for consistency. | |
| 106 | (setf (module-principal-sort newmod) s-mapped)))) | |
| 109 | 107 | ;; |
| 110 | (when *chaos-verbose* (princ "[")) ; now we begin. | |
| 108 | (when *chaos-verbose* (princ "[")) ; now we begin. | |
| 111 | 109 | (when *on-modexp-debug* |
| 112 | 110 | (with-output-simple-msg () |
| 113 | (format t "[apply-modmorph] : begin ----------------------------") | |
| 114 | (format t "~&- map = ") | |
| 115 | (print-mapping map) | |
| 116 | (format t "~& - module = ") | |
| 117 | (print-modexp mod) | |
| 118 | (format t "~& - new module = ") | |
| 119 | (print-modexp newmod))) | |
| 111 | (format t "[apply-modmorph] : begin ----------------------------") | |
| 112 | (format t "~&- map = ") | |
| 113 | (print-mapping map) | |
| 114 | (format t "~& - module = ") | |
| 115 | (print-modexp mod) | |
| 116 | (format t "~& - new module = ") | |
| 117 | (print-modexp newmod))) | |
| 120 | 118 | ;; |
| 121 | 119 | (let ((amod (assq mod (modmorph-module map)))) |
| 122 | 120 | ;; newmod is depends on mod, so we set dependency relation. |
| 125 | 123 | |
| 126 | 124 | ;; update module map mod->newmod |
| 127 | 125 | (if amod |
| 128 | (when (null (cdr amod)) (rplacd amod newmod)) | |
| 129 | (push (cons mod newmod) (modmorph-module map))) | |
| 126 | (when (null (cdr amod)) (rplacd amod newmod)) | |
| 127 | (push (cons mod newmod) (modmorph-module map))) | |
| 130 | 128 | |
| 131 | 129 | ;; this makes temporaly generated module for remaing trash away. |
| 132 | 130 | (when (modmorph-is-rename map) |
| 133 | (reduce-rename-dummy map mod newmod) | |
| 134 | (print-in-progress ",")) | |
| 131 | (reduce-rename-dummy map mod newmod) | |
| 132 | (print-in-progress ",")) | |
| 135 | 133 | |
| 136 | 134 | ;; now finished simple preparation, we begin the real work. |
| 137 | 135 | ;; |
| 138 | 136 | (let ((sortmap (modmorph-sort map)) |
| 139 | (opmap (modmorph-op map)) | |
| 140 | (modmap (modmorph-module map)) | |
| 141 | (no-error-sort nil)) | |
| 142 | ||
| 143 | ;; MAP SUBMODULES ----------------------------------------------------- | |
| 144 | ;; the first big job is to incorporate submodules. | |
| 145 | ;; * need to consider sub-module-instantiation | |
| 146 | ;; also apply mapping; want to memoize appropriately; | |
| 147 | ;; in some sense must always apply the mapping to sub-objects | |
| 148 | ;; * idea: if sub-module contains parameter as its sub-module then | |
| 149 | ;; map it (should always be directly there); the other source | |
| 150 | ;; of information is the name of the module; if is instantiated | |
| 151 | ;; then can see if the name contains a use of the parameter | |
| 152 | ||
| 153 | (modmorph-import-submodules mod newmod map mod) | |
| 154 | (print-in-progress ",") | |
| 137 | (opmap (modmorph-op map)) | |
| 138 | (modmap (modmorph-module map)) | |
| 139 | (no-error-sort nil)) | |
| 140 | ||
| 141 | ;; MAP SUBMODULES ----------------------------------------------------- | |
| 142 | ;; the first big job is to incorporate submodules. | |
| 143 | ;; * need to consider sub-module-instantiation | |
| 144 | ;; also apply mapping; want to memoize appropriately; | |
| 145 | ;; in some sense must always apply the mapping to sub-objects | |
| 146 | ;; * idea: if sub-module contains parameter as its sub-module then | |
| 147 | ;; map it (should always be directly there); the other source | |
| 148 | ;; of information is the name of the module; if is instantiated | |
| 149 | ;; then can see if the name contains a use of the parameter | |
| 150 | ||
| 151 | (modmorph-import-submodules mod newmod map mod) | |
| 152 | (print-in-progress ",") | |
| 155 | 153 | |
| 156 | ;; at this point have already got a lot of sorts and operators (etc.) | |
| 157 | ;; from the incorporated modules | |
| 158 | ||
| 159 | ;; after have created sub-modules need to "fix" renaming | |
| 160 | (when (modmorph-is-rename map) (fix-sort-renaming map newmod)) | |
| 161 | (print-in-progress ",") | |
| 154 | ;; at this point have already got a lot of sorts and operators (etc.) | |
| 155 | ;; from the incorporated modules | |
| 156 | ||
| 157 | ;; after have created sub-modules need to "fix" renaming | |
| 158 | (when (modmorph-is-rename map) (fix-sort-renaming map newmod)) | |
| 159 | (print-in-progress ",") | |
| 162 | 160 | |
| 163 | ;; now, maps may have been updated, so re-new the local cache. | |
| 164 | (setq sortmap (modmorph-sort map)) | |
| 165 | (setq opmap (modmorph-op map)) | |
| 166 | (setq modmap (modmorph-module map)) | |
| 167 | ||
| 168 | ;; MAP SORTS, SORT RELATIONS ---------------------------------------- | |
| 169 | ;; | |
| 170 | ;; mapping sorts | |
| 171 | (dolist (x (reverse (module-all-sorts mod))) | |
| 172 | (unless (sort-is-for-regularity? x mod) | |
| 173 | ;; reverse because want to preserve the original order | |
| 174 | (let ((sortmapval (assoc x sortmap))) | |
| 175 | (if sortmapval | |
| 176 | (let ((ims (cdr sortmapval))) | |
| 177 | (inherit-principal-sort x ims) | |
| 178 | (unless (memq ims (module-all-sorts newmod)) | |
| 179 | (add-sort-to-module ims newmod))) ; check sort order | |
| 180 | ;; | |
| 181 | (if (eq mod (sort-module x)) | |
| 182 | (let ((sortim (modmorph-recreate-sort newmod | |
| 183 | modmap | |
| 184 | sortmap | |
| 185 | x))) | |
| 186 | (inherit-principal-sort x sortim) | |
| 187 | (unless (eq x sortim) | |
| 188 | (push (cons x sortim) sortmap) | |
| 189 | (setf (modmorph-sort map) sortmap) | |
| 190 | (setq x sortim)) | |
| 191 | (add-sort-to-module sortim newmod)) | |
| 192 | ;; | |
| 193 | (let ((modv (assq (sort-module x) modmap))) | |
| 194 | (if modv | |
| 195 | (let ((sortim (modmorph-recreate-sort newmod | |
| 196 | modmap | |
| 197 | sortmap | |
| 198 | x))) | |
| 199 | (inherit-principal-sort x sortim) | |
| 200 | (unless (eq x sortim) | |
| 201 | (push (cons x sortim) sortmap) | |
| 202 | (setf (modmorph-sort map) sortmap)) | |
| 203 | ) | |
| 204 | (inherit-principal-sort x x)) | |
| 205 | ))) | |
| 206 | ))) | |
| 207 | ;; | |
| 208 | (if *chaos-verbose* | |
| 209 | (print-in-progress "s") ; done mapping sorts | |
| 210 | (print-in-progress ",")) | |
| 161 | ;; now, maps may have been updated, so re-new the local cache. | |
| 162 | (setq sortmap (modmorph-sort map)) | |
| 163 | (setq opmap (modmorph-op map)) | |
| 164 | (setq modmap (modmorph-module map)) | |
| 165 | ||
| 166 | ;; MAP SORTS, SORT RELATIONS ---------------------------------------- | |
| 167 | ;; | |
| 168 | ;; mapping sorts | |
| 169 | (dolist (x (reverse (module-all-sorts mod))) | |
| 170 | (unless (sort-is-for-regularity? x mod) | |
| 171 | ;; reverse because want to preserve the original order | |
| 172 | (let ((sortmapval (assoc x sortmap))) | |
| 173 | (if sortmapval | |
| 174 | (let ((ims (cdr sortmapval))) | |
| 175 | (inherit-principal-sort x ims) | |
| 176 | (unless (memq ims (module-all-sorts newmod)) | |
| 177 | (add-sort-to-module ims newmod))) ; check sort order | |
| 178 | ;; | |
| 179 | (if (eq mod (sort-module x)) | |
| 180 | (let ((sortim (modmorph-recreate-sort newmod | |
| 181 | modmap | |
| 182 | sortmap | |
| 183 | x))) | |
| 184 | (inherit-principal-sort x sortim) | |
| 185 | (unless (eq x sortim) | |
| 186 | (push (cons x sortim) sortmap) | |
| 187 | (setf (modmorph-sort map) sortmap) | |
| 188 | (setq x sortim)) | |
| 189 | (add-sort-to-module sortim newmod)) | |
| 190 | ;; | |
| 191 | (let ((modv (assq (sort-module x) modmap))) | |
| 192 | (if modv | |
| 193 | (let ((sortim (modmorph-recreate-sort newmod | |
| 194 | modmap | |
| 195 | sortmap | |
| 196 | x))) | |
| 197 | (inherit-principal-sort x sortim) | |
| 198 | (unless (eq x sortim) | |
| 199 | (push (cons x sortim) sortmap) | |
| 200 | (setf (modmorph-sort map) sortmap))) | |
| 201 | (inherit-principal-sort x x)))))))) | |
| 202 | ;; | |
| 203 | (if *chaos-verbose* | |
| 204 | (print-in-progress "s") ; done mapping sorts | |
| 205 | (print-in-progress ",")) | |
| 211 | 206 | |
| 212 | ;; sort-relation | |
| 213 | (let ((self-rel (modmorph-recreate-sort-relations newmod | |
| 214 | mod | |
| 215 | modmap | |
| 216 | sortmap | |
| 217 | (module-sort-relations | |
| 218 | newmod)))) | |
| 219 | (setf (module-sort-relations newmod) | |
| 220 | (modmorph-merge-sort-relations | |
| 221 | (modmorph-recreate-sort-relations newmod mod modmap sortmap | |
| 222 | (module-sort-relations mod)) | |
| 223 | self-rel))) | |
| 224 | (let ((so (module-sort-order newmod))) | |
| 225 | (dolist (sl (module-sort-relations newmod)) | |
| 226 | (add-relation-to-order (copy-sort-relation sl) so)) | |
| 227 | ;; we need error sorts | |
| 228 | (when *on-modexp-debug* | |
| 229 | (with-output-msg () | |
| 230 | (format t " generating error sorts"))) | |
| 231 | (generate-err-sorts so) | |
| 232 | (setq no-error-sort t) | |
| 233 | ) | |
| 234 | ;; | |
| 235 | (if *chaos-verbose* | |
| 236 | (print-in-progress "<") ; done mapping sort relations | |
| 237 | (print-in-progress ",")) | |
| 238 | ||
| 239 | ;; MAP OPERATORS ---------------------------------------------------- | |
| 240 | ;; | |
| 241 | (when (modmorph-is-rename map) | |
| 242 | ;; operators | |
| 243 | ;; after have created sub-modules need to "fix" renaming for | |
| 244 | ;; operators too. | |
| 245 | (when *on-modexp-debug* | |
| 246 | (with-output-msg () | |
| 247 | (format t " fixing operator renaming .."))) | |
| 248 | (fix-method-renaming map newmod)) | |
| 249 | ;; | |
| 250 | (dolist (opinfo (reverse (module-all-operators mod))) | |
| 251 | ;; want to preserve the original order of operators | |
| 252 | (dolist (method (opinfo-methods opinfo)) | |
| 253 | (when (or ;; (method-is-user-defined-error-method method) | |
| 254 | (and (not (method-is-error-method method)) | |
| 255 | (not (memq method | |
| 256 | (module-methods-for-regularity mod))))) | |
| 257 | (unless (assq method opmap) | |
| 258 | (modmorph-recreate-method mod newmod sortmap method)) | |
| 259 | ))) | |
| 260 | ;; | |
| 261 | (if *chaos-verbose* | |
| 262 | (print-in-progress "o") ; done mapping operators | |
| 263 | (print-in-progress ",")) | |
| 264 | ||
| 265 | ;; At this point all operators should exist; term recreation is possible. | |
| 266 | ;; all of the error sorts & error method should be | |
| 267 | ;; generated here. | |
| 268 | (modmorph-prepare-for-parsing newmod map no-error-sort) | |
| 269 | ||
| 270 | ;; MAP AXIOMS ------------------------------------------------------ | |
| 271 | ;; | |
| 272 | ;; equations | |
| 273 | (setf (module-equations newmod) | |
| 274 | (append | |
| 275 | (mapcar #'(lambda (r) | |
| 276 | (when *on-modexp-debug* | |
| 277 | (with-in-module (mod) | |
| 278 | (format t "~&* recreating the axiom :") | |
| 279 | (print-rule r))) | |
| 280 | (modmorph-recreate-axiom newmod sortmap opmap modmap r)) | |
| 281 | (module-equations mod)) | |
| 282 | (module-equations newmod))) | |
| 283 | ;; transitions | |
| 284 | (setf (module-rules newmod) | |
| 285 | (append | |
| 286 | (mapcar #'(lambda (r) | |
| 287 | (modmorph-recreate-axiom newmod sortmap opmap modmap r)) | |
| 288 | (module-rules mod)) | |
| 289 | (module-rules newmod))) | |
| 290 | (if *chaos-verbose* | |
| 291 | (print-in-progress "a") ; done mapping axioms | |
| 292 | (print-in-progress ",")) | |
| 293 | ||
| 294 | ;; THEOREMS --------------------------------------------------------- | |
| 295 | #|| NO YET | |
| 296 | (setf (module-theorems newmod) | |
| 297 | (append | |
| 298 | (mapcar #'(lambda (r) | |
| 299 | (modmorph-recreate-axiom newmod sortmap | |
| 300 | opmap modmap r)) | |
| 301 | (module-theorems mod)) | |
| 302 | (module-theorems newmod))) | |
| 303 | ||# | |
| 207 | ;; sort-relation | |
| 208 | (let ((self-rel (modmorph-recreate-sort-relations newmod | |
| 209 | mod | |
| 210 | modmap | |
| 211 | sortmap | |
| 212 | (module-sort-relations | |
| 213 | newmod)))) | |
| 214 | (setf (module-sort-relations newmod) | |
| 215 | (modmorph-merge-sort-relations | |
| 216 | (modmorph-recreate-sort-relations newmod mod modmap sortmap | |
| 217 | (module-sort-relations mod)) | |
| 218 | self-rel))) | |
| 219 | (let ((so (module-sort-order newmod))) | |
| 220 | (dolist (sl (module-sort-relations newmod)) | |
| 221 | (add-relation-to-order (copy-sort-relation sl) so)) | |
| 222 | ;; we need error sorts | |
| 223 | (when *on-modexp-debug* | |
| 224 | (with-output-msg () | |
| 225 | (format t " generating error sorts"))) | |
| 226 | (generate-err-sorts so) | |
| 227 | (setq no-error-sort t)) | |
| 228 | ;; | |
| 229 | (if *chaos-verbose* | |
| 230 | (print-in-progress "<") ; done mapping sort relations | |
| 231 | (print-in-progress ",")) | |
| 232 | ||
| 233 | ;; MAP OPERATORS ---------------------------------------------------- | |
| 234 | ;; | |
| 235 | (when (modmorph-is-rename map) | |
| 236 | ;; operators | |
| 237 | ;; after have created sub-modules need to "fix" renaming for | |
| 238 | ;; operators too. | |
| 239 | (when *on-modexp-debug* | |
| 240 | (with-output-msg () | |
| 241 | (format t " fixing operator renaming .."))) | |
| 242 | (fix-method-renaming map newmod)) | |
| 243 | ;; | |
| 244 | (dolist (opinfo (reverse (module-all-operators mod))) | |
| 245 | ;; want to preserve the original order of operators | |
| 246 | (dolist (method (opinfo-methods opinfo)) | |
| 247 | (when (or ;; (method-is-user-defined-error-method method) | |
| 248 | (and (not (method-is-error-method method)) | |
| 249 | (not (memq method | |
| 250 | (module-methods-for-regularity mod))))) | |
| 251 | (unless (assq method opmap) | |
| 252 | (modmorph-recreate-method mod newmod sortmap method))))) | |
| 253 | ;; | |
| 254 | (if *chaos-verbose* | |
| 255 | (print-in-progress "o") ; done mapping operators | |
| 256 | (print-in-progress ",")) | |
| 257 | ||
| 258 | ;; At this point all operators should exist; term recreation is possible. | |
| 259 | ;; all of the error sorts & error method should be | |
| 260 | ;; generated here. | |
| 261 | (modmorph-prepare-for-parsing newmod map no-error-sort) | |
| 262 | ||
| 263 | ;; MAP AXIOMS ------------------------------------------------------ | |
| 264 | ;; | |
| 265 | ;; equations | |
| 266 | (setf (module-equations newmod) | |
| 267 | (append | |
| 268 | (mapcar #'(lambda (r) | |
| 269 | (when *on-modexp-debug* | |
| 270 | (with-in-module (mod) | |
| 271 | (format t "~%* recreating the axiom :") | |
| 272 | (print-rule r))) | |
| 273 | (modmorph-recreate-axiom newmod sortmap opmap modmap r)) | |
| 274 | (module-equations mod)) | |
| 275 | (module-equations newmod))) | |
| 276 | ;; transitions | |
| 277 | (setf (module-rules newmod) | |
| 278 | (append | |
| 279 | (mapcar #'(lambda (r) | |
| 280 | (modmorph-recreate-axiom newmod sortmap opmap modmap r)) | |
| 281 | (module-rules mod)) | |
| 282 | (module-rules newmod))) | |
| 283 | (if *chaos-verbose* | |
| 284 | (print-in-progress "a") ; done mapping axioms | |
| 285 | (print-in-progress ",")) | |
| 286 | ||
| 287 | ;; THEOREMS --------------------------------------------------------- | |
| 288 | ;; NO YET | |
| 304 | 289 | |
| 305 | ;; OK we've done, nothing to be done here already. | |
| 306 | ;; | |
| 307 | (when *on-modexp-debug* | |
| 308 | (format t "~&* apply-modmorph: DONE. generated new module ") | |
| 309 | (print-mod-name newmod)) | |
| 310 | (if *chaos-verbose* | |
| 311 | (print-in-progress "]") ; done whole work. | |
| 312 | (print-in-progress ",")) | |
| 313 | newmod ;the final result | |
| 314 | )))) | |
| 290 | ;; OK we've done, nothing to be done here already. | |
| 291 | ;; | |
| 292 | (when *on-modexp-debug* | |
| 293 | (format t "~%* apply-modmorph: DONE. generated new module ") | |
| 294 | (print-mod-name newmod)) | |
| 295 | (if *chaos-verbose* | |
| 296 | (print-in-progress "]") ; done whole work. | |
| 297 | (print-in-progress ",")) | |
| 298 | newmod ;the final result | |
| 299 | )))) | |
| 315 | 300 | |
| 316 | 301 | (defun modmorph-prepare-for-parsing (mod map no-error-sort) |
| 317 | 302 | (declare (ignore no-error-sort)) |
| 325 | 310 | (modmorph-update-theory mod map opinfo)) |
| 326 | 311 | (propagate-attributes mod) |
| 327 | 312 | (update-parse-information mod) |
| 328 | (mark-module-ready-for-parsing mod) | |
| 329 | ) | |
| 313 | (mark-module-ready-for-parsing mod)) | |
| 330 | 314 | |
| 331 | 315 | (defun fix-operator-mapping (mod map) |
| 332 | 316 | (let ((opmap (modmorph-op map)) |
| 333 | (sort-map (modmorph-sort map))) | |
| 317 | (sort-map (modmorph-sort map))) | |
| 334 | 318 | (mapc #'(lambda (x) |
| 335 | (let ((target (cdr x))) | |
| 336 | (cond ((eq (car target) :replacement) | |
| 337 | (replace-error-method mod (caddr target) | |
| 338 | opmap sort-map)) | |
| 339 | ((eq (car target) :simple-error-map) | |
| 340 | (let ((method (cdr target)) | |
| 341 | (arity nil)) | |
| 342 | (dolist (s (method-arity method)) | |
| 343 | (if (err-sort-p s) | |
| 344 | (push (find-compatible-err-sort s | |
| 345 | mod | |
| 346 | sort-map) | |
| 347 | arity) | |
| 348 | (push s arity))) | |
| 349 | (setf (method-arity method) (nreverse arity)) | |
| 350 | (if (err-sort-p (method-coarity method)) | |
| 351 | (setf (method-coarity method) | |
| 352 | (find-compatible-err-sort | |
| 353 | (method-coarity method) | |
| 354 | mod | |
| 355 | sort-map))) | |
| 356 | (setf (car target) :simple-map))) | |
| 357 | (t nil)))) | |
| 358 | opmap))) | |
| 359 | ||
| 360 | #|| | |
| 361 | (defun modmorph-find-error-method (module method opmap &optional sortmap) | |
| 362 | (declare (type module module) | |
| 363 | (type method method) | |
| 364 | (type list opmap sortmap) | |
| 365 | (values (or null method))) | |
| 366 | (or (car (memq method (module-error-methods module))) | |
| 367 | (let* ((alen (length (method-arity method))) | |
| 368 | (opinfos (find-operators-in-module (method-symbol method) | |
| 369 | alen | |
| 370 | module))) | |
| 371 | (declare (type fixnum alen) | |
| 372 | (type list opinfos)) | |
| 373 | ;; | |
| 374 | (unless opinfos | |
| 375 | (let* ((name (method-symbol method)) | |
| 376 | (mapped? (find-if #'(lambda (x) | |
| 377 | (and (equal (method-symbol | |
| 378 | (the method (car x))) | |
| 379 | name) | |
| 380 | (= (the fixnum | |
| 381 | (length (method-arity (car x)))) | |
| 382 | alen))) | |
| 383 | opmap))) | |
| 384 | (when mapped? | |
| 385 | ;; (method :simple-map . method) | |
| 386 | ;; (mehtod :replacement pvars term) | |
| 387 | (setq name (if (memq (second mapped?) | |
| 388 | '(:simple-map :simple-error-map)) | |
| 389 | (method-symbol (the method (cddr mapped?))) | |
| 390 | (method-symbol (term-head (cadddr mapped?))))) | |
| 391 | (setq opinfos (find-operators-in-module name alen module))))) | |
| 392 | ;; | |
| 393 | (let ((opinfo nil) | |
| 394 | (err-method nil)) | |
| 395 | (let* ((ar (mapcar #'(lambda (x) | |
| 396 | (declare (type sort* x)) | |
| 397 | (if (err-sort-p x) | |
| 398 | (find-compatible-err-sort x module sortmap) | |
| 399 | x)) | |
| 400 | (method-arity method))) | |
| 401 | #|| | |
| 402 | (ar-names (mapcar #'(lambda(x) | |
| 403 | (declare (type sort* x)) | |
| 404 | (sort-id x)) | |
| 405 | ar)) | |
| 406 | ||# | |
| 407 | (cr (if (err-sort-p (method-coarity method)) | |
| 408 | (find-compatible-err-sort (method-coarity method) | |
| 409 | module | |
| 410 | sortmap) | |
| 411 | (method-coarity method))) | |
| 412 | #|| | |
| 413 | (cr-name (sort-id cr)) | |
| 414 | ||# | |
| 415 | ) | |
| 416 | (declare (type sort* cr)) | |
| 417 | (block find-method | |
| 418 | (dolist (oi opinfos) | |
| 419 | (declare (type list oi)) | |
| 420 | (dolist (cand (opinfo-methods oi)) | |
| 421 | (declare (type method cand)) | |
| 422 | (when (and (sort-list= ar (method-arity cand)) | |
| 423 | (sort= cr (method-coarity cand))) | |
| 424 | (setq opinfo oi) | |
| 425 | (setq err-method cand) | |
| 426 | (return-from find-method nil)) | |
| 427 | ))) | |
| 428 | ;; | |
| 429 | (unless opinfo | |
| 430 | ;; failed!.... | |
| 431 | ;; this means we need error method which are not generated | |
| 432 | ;; yet. -- really? | |
| 433 | ;; (break) | |
| 434 | (let ((arity (mapcar #'(lambda (x) | |
| 435 | (declare (type sort* x)) | |
| 436 | (if (err-sort-p x) | |
| 437 | (let ((compo | |
| 438 | (err-sort-components x))) | |
| 439 | (mapcar #'(lambda(y) | |
| 440 | (modmorph-assoc-image | |
| 441 | sortmap | |
| 442 | y)) | |
| 443 | compo)) | |
| 444 | (list (modmorph-assoc-image | |
| 445 | sortmap | |
| 446 | x)))) | |
| 447 | ar)) | |
| 448 | (coarity (let ((c cr)) | |
| 449 | (if (err-sort-p c) | |
| 450 | (let ((compo (err-sort-components c))) | |
| 451 | (mapcar #'(lambda (s) | |
| 452 | (modmorph-assoc-image sortmap s)) | |
| 453 | compo)) | |
| 454 | (list (modmorph-assoc-image sortmap c))))) | |
| 455 | (so (module-sort-order module))) | |
| 456 | (declare (type sort-order so)) | |
| 457 | ;; | |
| 458 | ;; (break) | |
| 459 | ;; | |
| 460 | (when (block | |
| 461 | find-opinfo | |
| 462 | (dolist (oi opinfos) | |
| 463 | (declare (type list oi)) | |
| 464 | (let ((mm (opinfo-methods oi))) | |
| 465 | (dolist (m mm) | |
| 466 | (declare (type method m)) | |
| 467 | (block try1 | |
| 468 | (let ((xarity (method-arity m)) | |
| 469 | (xcoarity (method-coarity m))) | |
| 470 | (declare (type list xarity) | |
| 471 | (type sort* xcoarity)) | |
| 472 | (dotimes (pos (length xarity)) | |
| 473 | (declare (type fixnum pos)) | |
| 474 | (unless (some #'(lambda (y) | |
| 475 | (declare (type sort* y)) | |
| 476 | (sort<= (the sort* | |
| 477 | (nth pos xarity)) | |
| 478 | y | |
| 479 | so)) | |
| 480 | (nth pos arity)) | |
| 481 | (return-from try1 nil))) | |
| 482 | (unless (some #'(lambda (y) | |
| 483 | (declare (type sort* y)) | |
| 484 | (sort<= xcoarity y so)) | |
| 485 | coarity) | |
| 486 | (return-from try1 nil)) | |
| 487 | (setq opinfo oi) | |
| 488 | (return-from find-opinfo t)) | |
| 489 | ))))) | |
| 490 | ;; | |
| 491 | (setup-error-operator opinfo module) | |
| 492 | (setq err-method (car (opinfo-methods opinfo))) | |
| 493 | ))) | |
| 494 | ) | |
| 495 | ;; | |
| 496 | (when *on-modexp-debug* | |
| 497 | (format t "~%-- finding error method for : ") | |
| 498 | (print-chaos-object method) | |
| 499 | (format t "~% found : ") | |
| 500 | (print-chaos-object err-method)) | |
| 501 | ;; | |
| 502 | err-method)))) | |
| 503 | ||# | |
| 319 | (let ((target (cdr x))) | |
| 320 | (cond ((eq (car target) :replacement) | |
| 321 | (replace-error-method mod (caddr target) | |
| 322 | opmap sort-map)) | |
| 323 | ((eq (car target) :simple-error-map) | |
| 324 | (let ((method (cdr target)) | |
| 325 | (arity nil)) | |
| 326 | (dolist (s (method-arity method)) | |
| 327 | (if (err-sort-p s) | |
| 328 | (push (find-compatible-err-sort s | |
| 329 | mod | |
| 330 | sort-map) | |
| 331 | arity) | |
| 332 | (push s arity))) | |
| 333 | (setf (method-arity method) (nreverse arity)) | |
| 334 | (if (err-sort-p (method-coarity method)) | |
| 335 | (setf (method-coarity method) | |
| 336 | (find-compatible-err-sort | |
| 337 | (method-coarity method) | |
| 338 | mod | |
| 339 | sort-map))) | |
| 340 | (setf (car target) :simple-map))) | |
| 341 | (t nil)))) | |
| 342 | opmap))) | |
| 504 | 343 | |
| 505 | 344 | (defun modmorph-find-mapped-sorts (module sort-l sortmap) |
| 506 | 345 | (mapcar #'(lambda (x) |
| 507 | (declare (type sort* x)) | |
| 508 | (if (err-sort-p x) | |
| 509 | (find-compatible-err-sort x module sortmap) | |
| 510 | (or (cdr (assq x sortmap)) x))) | |
| 511 | sort-l)) | |
| 346 | (declare (type sort* x)) | |
| 347 | (if (err-sort-p x) | |
| 348 | (find-compatible-err-sort x module sortmap) | |
| 349 | (or (cdr (assq x sortmap)) x))) | |
| 350 | sort-l)) | |
| 512 | 351 | |
| 513 | 352 | ;;; ******* |
| 514 | 353 | (defun modmorph-copy-method-attributes (from to) |
| 515 | 354 | (let (sup-strat |
| 516 | theory | |
| 517 | prec | |
| 518 | memo | |
| 519 | assoc | |
| 520 | constr) | |
| 355 | theory | |
| 356 | prec | |
| 357 | memo | |
| 358 | assoc | |
| 359 | constr) | |
| 521 | 360 | (let ((from-module (method-module from))) |
| 522 | 361 | (with-in-module (from-module) |
| 523 | (setf sup-strat (method-supplied-strategy from) | |
| 524 | theory (method-theory from) | |
| 525 | prec (get-method-precedence from) | |
| 526 | memo (method-has-memo from) | |
| 527 | assoc (method-associativity from) | |
| 528 | constr (method-constructor from)))) | |
| 362 | (setf sup-strat (method-supplied-strategy from) | |
| 363 | theory (method-theory from) | |
| 364 | prec (get-method-precedence from) | |
| 365 | memo (method-has-memo from) | |
| 366 | assoc (method-associativity from) | |
| 367 | constr (method-constructor from)))) | |
| 529 | 368 | (let ((to-module (method-module to))) |
| 530 | 369 | (with-in-module (to-module) |
| 531 | (setf (method-supplied-strategy to) sup-strat | |
| 532 | (method-precedence to) prec | |
| 533 | (method-has-memo to) memo | |
| 534 | (method-associativity to) assoc | |
| 535 | (method-constructor to) constr) | |
| 536 | (set-method-theory to theory) | |
| 537 | )) | |
| 538 | )) | |
| 370 | (setf (method-supplied-strategy to) sup-strat | |
| 371 | (method-precedence to) prec | |
| 372 | (method-has-memo to) memo | |
| 373 | (method-associativity to) assoc | |
| 374 | (method-constructor to) constr) | |
| 375 | (set-method-theory to theory))))) | |
| 539 | 376 | |
| 540 | 377 | |
| 541 | 378 | (defun modmorph-find-user-defined-error-method (method module sortmap) |
| 542 | 379 | (let ((arity (modmorph-find-mapped-sorts module |
| 543 | (method-arity method) | |
| 544 | sortmap)) | |
| 545 | (coarity (car (modmorph-find-mapped-sorts module | |
| 546 | (list (method-coarity method)) | |
| 547 | sortmap)))) | |
| 380 | (method-arity method) | |
| 381 | sortmap)) | |
| 382 | (coarity (car (modmorph-find-mapped-sorts module | |
| 383 | (list (method-coarity method)) | |
| 384 | sortmap)))) | |
| 548 | 385 | |
| 549 | 386 | (multiple-value-bind (op err-method) |
| 550 | (declare-operator-in-module | |
| 551 | (method-symbol method) | |
| 552 | arity | |
| 553 | coarity | |
| 554 | module | |
| 555 | (method-is-constructor? method) ; constructor? | |
| 556 | (method-is-behavioural method) | |
| 557 | nil | |
| 558 | t) ; error method? | |
| 387 | (declare-operator-in-module | |
| 388 | (method-symbol method) | |
| 389 | arity | |
| 390 | coarity | |
| 391 | module | |
| 392 | (method-is-constructor? method) ; constructor? | |
| 393 | (method-is-behavioural method) | |
| 394 | nil | |
| 395 | t) ; error method? | |
| 559 | 396 | (declare (ignore op)) |
| 560 | 397 | (modmorph-copy-method-attributes method err-method) |
| 561 | 398 | err-method))) |
| 562 | 399 | |
| 563 | 400 | (defun modmorph-find-proper-error-method (method opinfos module sortmap) |
| 564 | 401 | (let ((opinfo nil) |
| 565 | (err-method nil)) | |
| 402 | (err-method nil)) | |
| 566 | 403 | (let ((ar (modmorph-find-mapped-sorts module |
| 567 | (method-arity method) | |
| 568 | sortmap)) | |
| 569 | (cr (car (modmorph-find-mapped-sorts module | |
| 570 | (list (method-coarity method)) | |
| 571 | sortmap))) | |
| 572 | ) | |
| 404 | (method-arity method) | |
| 405 | sortmap)) | |
| 406 | (cr (car (modmorph-find-mapped-sorts module | |
| 407 | (list (method-coarity method)) | |
| 408 | sortmap)))) | |
| 573 | 409 | (declare (type sort* cr)) |
| 574 | 410 | (block find-method |
| 575 | (dolist (oi opinfos) | |
| 576 | (declare (type list oi)) | |
| 577 | (dolist (cand (opinfo-methods oi)) | |
| 578 | (declare (type method cand)) | |
| 579 | ;;----- | |
| 580 | (when (and (sort-list= ar (method-arity cand)) | |
| 581 | (sort= cr (method-coarity cand))) | |
| 582 | (setq opinfo oi) | |
| 583 | (setq err-method cand) | |
| 584 | (return-from find-method nil)) | |
| 585 | ))) | |
| 586 | ;; | |
| 411 | (dolist (oi opinfos) | |
| 412 | (declare (type list oi)) | |
| 413 | (dolist (cand (opinfo-methods oi)) | |
| 414 | (declare (type method cand)) | |
| 415 | ;;----- | |
| 416 | (when (and (sort-list= ar (method-arity cand)) | |
| 417 | (sort= cr (method-coarity cand))) | |
| 418 | (setq opinfo oi) | |
| 419 | (setq err-method cand) | |
| 420 | (return-from find-method nil))))) | |
| 421 | ;; | |
| 587 | 422 | (unless opinfo |
| 588 | ;; failed!.... | |
| 589 | ;; this means we need error method | |
| 590 | ;; which are not generated yet. -- really? | |
| 591 | (let ((arity (mapcar #'(lambda (x) | |
| 592 | (declare (type sort* x)) | |
| 593 | (if (err-sort-p x) | |
| 594 | (let ((compo | |
| 595 | (err-sort-components | |
| 596 | x))) | |
| 597 | (mapcar #'(lambda(y) | |
| 598 | (modmorph-assoc-image | |
| 599 | sortmap | |
| 600 | y)) | |
| 601 | compo)) | |
| 602 | (list (modmorph-assoc-image | |
| 603 | sortmap | |
| 604 | x)))) | |
| 605 | ar)) | |
| 606 | (coarity (let ((c cr)) | |
| 607 | (if (err-sort-p c) | |
| 608 | (let ((compo (err-sort-components c))) | |
| 609 | (mapcar #'(lambda (s) | |
| 610 | (modmorph-assoc-image sortmap s)) | |
| 611 | compo)) | |
| 612 | (list (modmorph-assoc-image sortmap c))))) | |
| 613 | (so (module-sort-order module))) | |
| 614 | (declare (type sort-order so)) | |
| 615 | ;; | |
| 616 | (when (block | |
| 617 | find-opinfo | |
| 618 | (dolist (oi opinfos) | |
| 619 | (declare (type list oi)) | |
| 620 | (let ((mm (opinfo-methods oi))) | |
| 621 | (dolist (m mm) | |
| 622 | (declare (type method m)) | |
| 623 | (block try1 | |
| 624 | (let ((xarity (method-arity m)) | |
| 625 | (xcoarity (method-coarity m))) | |
| 626 | (declare (type list xarity) | |
| 627 | (type sort* xcoarity)) | |
| 628 | (dotimes (pos (length xarity)) | |
| 629 | (declare (type fixnum pos)) | |
| 630 | (unless (some #'(lambda (y) | |
| 631 | (declare (type sort* y)) | |
| 632 | (sort<= (the sort* | |
| 633 | (nth pos xarity)) | |
| 634 | y | |
| 635 | so)) | |
| 636 | (nth pos arity)) | |
| 637 | (return-from try1 nil))) | |
| 638 | (unless (some #'(lambda (y) | |
| 639 | (declare (type sort* y)) | |
| 640 | (sort<= xcoarity y so)) | |
| 641 | coarity) | |
| 642 | (return-from try1 nil)) | |
| 643 | (setq opinfo oi) | |
| 644 | (return-from find-opinfo t)) | |
| 645 | ))))) | |
| 646 | ;; | |
| 647 | (setup-error-operator opinfo module) | |
| 648 | (setq err-method (car (opinfo-methods opinfo))) | |
| 649 | ) | |
| 650 | (unless err-method | |
| 651 | ;; this means that the original method should be an | |
| 652 | ;; user defined error-method... | |
| 653 | ;; make sure that really is ... | |
| 654 | (unless (or (some #'(lambda (x) | |
| 655 | (declare (type sort* x)) | |
| 656 | (err-sort-p x)) | |
| 657 | ar) | |
| 658 | (err-sort-p coarity)) | |
| 659 | ;; so bad ... | |
| 660 | #|| | |
| 661 | (with-output-panic-message () | |
| 662 | (format t "well ... could not find proper error method for ") | |
| 663 | (print-chaos-object method)) | |
| 664 | ||# | |
| 665 | (with-output-chaos-warning () | |
| 666 | (format t "well ... could not find proper error method for ") | |
| 667 | (print-chaos-object method)) | |
| 668 | (return-from modmorph-find-proper-error-method method) | |
| 669 | ) | |
| 670 | ;; we declare err-method | |
| 671 | ;; (format t "~&declaring new error method...") | |
| 672 | (multiple-value-bind (o m) | |
| 673 | (declare-operator-in-module | |
| 674 | (method-symbol method) | |
| 675 | arity | |
| 676 | coarity | |
| 677 | module | |
| 678 | (method-is-constructor? method) ; constructor? | |
| 679 | (method-is-behavioural method) | |
| 680 | nil | |
| 681 | t) ; error method? | |
| 682 | (declare (ignore o)) | |
| 683 | (setq err-method m)) | |
| 684 | ) ; end case no err-method | |
| 685 | ) | |
| 686 | ) ; end case no op-info | |
| 687 | ) | |
| 423 | ;; failed!.... | |
| 424 | ;; this means we need error method | |
| 425 | ;; which are not generated yet. -- really? | |
| 426 | (let ((arity (mapcar #'(lambda (x) | |
| 427 | (declare (type sort* x)) | |
| 428 | (if (err-sort-p x) | |
| 429 | (let ((compo | |
| 430 | (err-sort-components | |
| 431 | x))) | |
| 432 | (mapcar #'(lambda(y) | |
| 433 | (modmorph-assoc-image | |
| 434 | sortmap | |
| 435 | y)) | |
| 436 | compo)) | |
| 437 | (list (modmorph-assoc-image | |
| 438 | sortmap | |
| 439 | x)))) | |
| 440 | ar)) | |
| 441 | (coarity (let ((c cr)) | |
| 442 | (if (err-sort-p c) | |
| 443 | (let ((compo (err-sort-components c))) | |
| 444 | (mapcar #'(lambda (s) | |
| 445 | (modmorph-assoc-image sortmap s)) | |
| 446 | compo)) | |
| 447 | (list (modmorph-assoc-image sortmap c))))) | |
| 448 | (so (module-sort-order module))) | |
| 449 | (declare (type sort-order so)) | |
| 450 | ;; | |
| 451 | (when (block | |
| 452 | find-opinfo | |
| 453 | (dolist (oi opinfos) | |
| 454 | (declare (type list oi)) | |
| 455 | (let ((mm (opinfo-methods oi))) | |
| 456 | (dolist (m mm) | |
| 457 | (declare (type method m)) | |
| 458 | (block try1 | |
| 459 | (let ((xarity (method-arity m)) | |
| 460 | (xcoarity (method-coarity m))) | |
| 461 | (declare (type list xarity) | |
| 462 | (type sort* xcoarity)) | |
| 463 | (dotimes (pos (length xarity)) | |
| 464 | (declare (type fixnum pos)) | |
| 465 | (unless (some #'(lambda (y) | |
| 466 | (declare (type sort* y)) | |
| 467 | (sort<= (the sort* | |
| 468 | (nth pos xarity)) | |
| 469 | y | |
| 470 | so)) | |
| 471 | (nth pos arity)) | |
| 472 | (return-from try1 nil))) | |
| 473 | (unless (some #'(lambda (y) | |
| 474 | (declare (type sort* y)) | |
| 475 | (sort<= xcoarity y so)) | |
| 476 | coarity) | |
| 477 | (return-from try1 nil)) | |
| 478 | (setq opinfo oi) | |
| 479 | (return-from find-opinfo t))))))) | |
| 480 | ;; | |
| 481 | (setup-error-operator opinfo module) | |
| 482 | (setq err-method (car (opinfo-methods opinfo)))) | |
| 483 | (unless err-method | |
| 484 | ;; this means that the original method should be an | |
| 485 | ;; user defined error-method... | |
| 486 | ;; make sure that really is ... | |
| 487 | (unless (or (some #'(lambda (x) | |
| 488 | (declare (type sort* x)) | |
| 489 | (err-sort-p x)) | |
| 490 | ar) | |
| 491 | (err-sort-p coarity)) | |
| 492 | (with-output-chaos-warning () | |
| 493 | (format t "well ... could not find proper error method for ") | |
| 494 | (print-chaos-object method)) | |
| 495 | (return-from modmorph-find-proper-error-method method)) | |
| 496 | ;; we declare err-method | |
| 497 | (multiple-value-bind (o m) | |
| 498 | (declare-operator-in-module | |
| 499 | (method-symbol method) | |
| 500 | arity | |
| 501 | coarity | |
| 502 | module | |
| 503 | (method-is-constructor? method) ; constructor? | |
| 504 | (method-is-behavioural method) | |
| 505 | nil | |
| 506 | t) ; error method? | |
| 507 | (declare (ignore o)) | |
| 508 | (setq err-method m))) ; end case no err-method | |
| 509 | ))) | |
| 688 | 510 | ;; |
| 689 | 511 | (when *on-modexp-debug* |
| 690 | 512 | (format t "~%-- finding error method for : ") |
| 697 | 519 | (defun modmorph-find-error-method (module method opmap sortmap) |
| 698 | 520 | (or (car (memq method (module-error-methods module))) |
| 699 | 521 | (let* ((alen (length (method-arity method))) |
| 700 | (opinfos nil) | |
| 701 | (name (method-symbol method)) | |
| 702 | (mapped? (find-if #'(lambda (x) | |
| 703 | (and (method-p (car x)) | |
| 704 | ;; there is a case built-in constant | |
| 705 | ;; is mapped, thus need method-p here. | |
| 706 | ;; Wed Mar 3 17:30:33 JST 1999 | |
| 707 | (equal (method-symbol | |
| 708 | (the method (car x))) | |
| 709 | name) | |
| 710 | (= (the fixnum | |
| 711 | (length (method-arity (car x)))) | |
| 712 | alen))) | |
| 713 | opmap))) | |
| 714 | (declare (type fixnum alen) | |
| 715 | (type list opinfos)) | |
| 716 | ;; | |
| 717 | (if mapped? | |
| 718 | (progn | |
| 719 | ;; (method :simple-map . method) | |
| 720 | ;; (mehtod :replacement pvars term) | |
| 721 | (when *on-modexp-debug* | |
| 722 | (format t "~%-- finding error method: ") | |
| 723 | (format t "~% mapped ~s" mapped?)) | |
| 724 | (setq name (if (memq (second mapped?) | |
| 725 | '(:simple-map :simple-error-map)) | |
| 726 | (method-symbol (the method (cddr mapped?))) | |
| 727 | (method-symbol (term-head (cadddr mapped?))))) | |
| 728 | (setq opinfos (find-operators-in-module name alen module))) | |
| 729 | ;; mot mapped | |
| 730 | (progn | |
| 731 | (setq opinfos (find-operators-in-module (method-symbol method) | |
| 732 | alen | |
| 733 | module)) | |
| 734 | (when *on-modexp-debug* | |
| 735 | (format t "~%-- finding error method: ") | |
| 736 | (format t "~% not mapped, got infos : ") | |
| 737 | (print-chaos-object opinfos)))) | |
| 738 | (cond (opinfos | |
| 739 | (modmorph-find-proper-error-method method | |
| 740 | opinfos | |
| 741 | module | |
| 742 | sortmap)) | |
| 743 | (t ; this means that the err method is | |
| 744 | ; user defined one. | |
| 745 | (modmorph-find-user-defined-error-method method | |
| 746 | module | |
| 747 | sortmap))) | |
| 748 | ))) | |
| 522 | (opinfos nil) | |
| 523 | (name (method-symbol method)) | |
| 524 | (mapped? (find-if #'(lambda (x) | |
| 525 | (and (method-p (car x)) | |
| 526 | ;; there is a case built-in constant | |
| 527 | ;; is mapped, thus need method-p here. | |
| 528 | ;; Wed Mar 3 17:30:33 JST 1999 | |
| 529 | (equal (method-symbol | |
| 530 | (the method (car x))) | |
| 531 | name) | |
| 532 | (= (the fixnum | |
| 533 | (length (method-arity (car x)))) | |
| 534 | alen))) | |
| 535 | opmap))) | |
| 536 | (declare (type fixnum alen) | |
| 537 | (type list opinfos)) | |
| 538 | ;; | |
| 539 | (if mapped? | |
| 540 | (progn | |
| 541 | ;; (method :simple-map . method) | |
| 542 | ;; (mehtod :replacement pvars term) | |
| 543 | (when *on-modexp-debug* | |
| 544 | (format t "~%-- finding error method: ") | |
| 545 | (format t "~% mapped ~s" mapped?)) | |
| 546 | (setq name (if (memq (second mapped?) | |
| 547 | '(:simple-map :simple-error-map)) | |
| 548 | (method-symbol (the method (cddr mapped?))) | |
| 549 | (method-symbol (term-head (cadddr mapped?))))) | |
| 550 | (setq opinfos (find-operators-in-module name alen module))) | |
| 551 | ;; mot mapped | |
| 552 | (progn | |
| 553 | (setq opinfos (find-operators-in-module (method-symbol method) | |
| 554 | alen | |
| 555 | module)) | |
| 556 | (when *on-modexp-debug* | |
| 557 | (format t "~%-- finding error method: ") | |
| 558 | (format t "~% not mapped, got infos : ") | |
| 559 | (print-chaos-object opinfos)))) | |
| 560 | (cond (opinfos | |
| 561 | (modmorph-find-proper-error-method method | |
| 562 | opinfos | |
| 563 | module | |
| 564 | sortmap)) | |
| 565 | (t ; this means that the err method is | |
| 566 | ; user defined one. | |
| 567 | (modmorph-find-user-defined-error-method method | |
| 568 | module | |
| 569 | sortmap)))))) | |
| 749 | 570 | |
| 750 | 571 | |
| 751 | 572 | (defun replace-error-method (mod term op-map sort-map) |
| 752 | 573 | (declare (type module mod) |
| 753 | (type term term) | |
| 754 | (type list op-map sort-map) | |
| 755 | (values t)) | |
| 574 | (type term term) | |
| 575 | (type list op-map sort-map) | |
| 576 | (values t)) | |
| 756 | 577 | (if (term-is-application-form? term) |
| 757 | 578 | (let ((head nil)) |
| 758 | (when (or (method-is-error-method (term-head term)) | |
| 759 | (or (sort= (term-sort term) *universal-sort*) | |
| 760 | (sort= (term-sort term) *huniversal-sort*))) | |
| 761 | (setq head (modmorph-find-error-method mod (term-head term) | |
| 762 | op-map sort-map)) | |
| 763 | (when head | |
| 764 | (change-head-operator term head))) | |
| 765 | (dolist (sub (term-subterms term)) | |
| 766 | (replace-error-method mod sub op-map sort-map))) | |
| 579 | (when (or (method-is-error-method (term-head term)) | |
| 580 | (or (sort= (term-sort term) *universal-sort*) | |
| 581 | (sort= (term-sort term) *huniversal-sort*))) | |
| 582 | (setq head (modmorph-find-error-method mod (term-head term) | |
| 583 | op-map sort-map)) | |
| 584 | (when head | |
| 585 | (change-head-operator term head))) | |
| 586 | (dolist (sub (term-subterms term)) | |
| 587 | (replace-error-method mod sub op-map sort-map))) | |
| 767 | 588 | (if (term-is-variable? term) |
| 768 | (let ((sort (variable-sort term))) | |
| 769 | (when (err-sort-p sort) | |
| 770 | (let ((new (find-compatible-err-sort sort mod sort-map))) | |
| 771 | (if new | |
| 772 | (setf (variable-sort term) new) | |
| 773 | ;; may be error...but | |
| 774 | nil))))))) | |
| 589 | (let ((sort (variable-sort term))) | |
| 590 | (when (err-sort-p sort) | |
| 591 | (let ((new (find-compatible-err-sort sort mod sort-map))) | |
| 592 | (if new | |
| 593 | (setf (variable-sort term) new) | |
| 594 | ;; may be error...but | |
| 595 | nil))))))) | |
| 775 | 596 | |
| 776 | 597 | ;;; ************** |
| 777 | 598 | ;;; MAP SUBMODULES______________________________________________________________ |
| 787 | 608 | ;;; |
| 788 | 609 | (defun modmorph-submodule-is-mapped (modmap mod) |
| 789 | 610 | (some #'(lambda (x) |
| 790 | (or (modmorph-module-is-mapped modmap (car x)) | |
| 791 | (modmorph-submodule-is-mapped modmap (car x)))) | |
| 792 | (module-submodules mod)) | |
| 793 | ) | |
| 611 | (or (modmorph-module-is-mapped modmap (car x)) | |
| 612 | (modmorph-submodule-is-mapped modmap (car x)))) | |
| 613 | (module-submodules mod))) | |
| 794 | 614 | |
| 795 | 615 | ;;;============================================================================= |
| 796 | 616 | ;;; MOD-MORPH-IMPORT-SUBMODULES : MODULE NEW-MODULE MAP |
| 805 | 625 | ;;; |
| 806 | 626 | (defun modmorph-import-submodule (mod newmod map mode submod) |
| 807 | 627 | (let* ((modmap (modmorph-module map)) |
| 808 | (direct-img (assq submod modmap)) ; is it mapped directly? | |
| 809 | (submodule-image nil)) | |
| 628 | (direct-img (assq submod modmap)) ; is it mapped directly? | |
| 629 | (submodule-image nil)) | |
| 810 | 630 | (when *on-modexp-debug* |
| 811 | (format t "~&[modmorph-import-submodule]: ") | |
| 631 | (format t "~%[modmorph-import-submodule]: ") | |
| 812 | 632 | (princ " ") (print-modexp newmod) (princ " <== ") |
| 813 | 633 | (print-modexp submod) |
| 814 | 634 | (format t "~& - img:key= ") (print-chaos-object (car direct-img)) |
| 815 | 635 | (format t "~& - img:val= ") (print-chaos-object (cdr direct-img))) |
| 816 | 636 | ;; |
| 817 | 637 | (setq submodule-image |
| 818 | (if direct-img | |
| 819 | (cond ((or (null (cdr direct-img)) | |
| 820 | (is-dummy-module (cdr direct-img))) | |
| 821 | ;;case of renaming | |
| 822 | (when *on-modexp-debug* | |
| 823 | (format t "~% - case renaming:")) | |
| 824 | (modmorph-map-submodule map mod submod)) | |
| 825 | (t ;associated value is a view in general. | |
| 826 | (target-of-view-arg (cdr direct-img)))) | |
| 827 | (if (modmorph-submodule-is-mapped modmap submod) | |
| 828 | (modmorph-map-submodule map mod submod) | |
| 829 | submod))) | |
| 638 | (if direct-img | |
| 639 | (cond ((or (null (cdr direct-img)) | |
| 640 | (is-dummy-module (cdr direct-img))) | |
| 641 | ;;case of renaming | |
| 642 | (when *on-modexp-debug* | |
| 643 | (format t "~% - case renaming:")) | |
| 644 | (modmorph-map-submodule map mod submod)) | |
| 645 | (t ;associated value is a view in general. | |
| 646 | (target-of-view-arg (cdr direct-img)))) | |
| 647 | (if (modmorph-submodule-is-mapped modmap submod) | |
| 648 | (modmorph-map-submodule map mod submod) | |
| 649 | submod))) | |
| 830 | 650 | (when *on-modexp-debug* |
| 831 | (format t "~& -image ") | |
| 651 | (format t "~% -image ") | |
| 832 | 652 | (print-modexp submod) (princ " --> ") |
| 833 | 653 | (print-modexp submodule-image)) |
| 834 | 654 | ;; |
| 835 | 655 | (if (eq ':using mode) |
| 836 | (modmorph-import-submodules mod newmod map submodule-image) | |
| 837 | #|| | |
| 838 | (if (module-is-parameter-theory submodule-image) | |
| 839 | (let* ((mod-name (module-name submodule-image)) | |
| 840 | (formal-name (first mod-name)) | |
| 841 | (real-sub (third mod-name))) | |
| 842 | (import-module newmod mode real-sub formal-name)) | |
| 843 | (import-module newmod mode submodule-image)) | |
| 844 | ||# | |
| 845 | (import-module newmod mode submodule-image) | |
| 846 | ) | |
| 847 | )) | |
| 656 | (modmorph-import-submodules mod newmod map submodule-image) | |
| 657 | (import-module newmod mode submodule-image)))) | |
| 848 | 658 | |
| 849 | 659 | ;;;----------------------------------------------------------------------------- |
| 850 | 660 | ;;; MODMORPH-MAP-SUBMODULE |
| 872 | 682 | |
| 873 | 683 | (defun modmorph-map-submodule (map mod smod) |
| 874 | 684 | (let ((parameters (get-module-parameters smod))) |
| 875 | (cond (parameters ; was (module-parameters smod) | |
| 876 | (when *on-modexp-debug* | |
| 877 | (format t "~%[modmorph-map-submodule]:") | |
| 878 | (print-modexp smod) | |
| 879 | (format t "~% sub has parameters :") | |
| 880 | (print-chaos-object parameters)) | |
| 881 | ;; submdule has parameters, | |
| 882 | ;; checks some of them is mapped or not. | |
| 883 | (let ((mod-map (modmorph-module map)) | |
| 884 | (own-params (mapcar #'(lambda (x) (parameter-theory-module x)) | |
| 885 | parameters)) | |
| 886 | (args nil)) | |
| 887 | (dolist (mmod mod-map) | |
| 888 | (if (memq (car mmod) own-params) | |
| 889 | (push (%!arg* (car (module-name (car mmod))) | |
| 890 | (cdr mmod)) | |
| 891 | args))) | |
| 892 | (let ((new-name (%instantiation* smod args))) | |
| 893 | ;; * * * | |
| 894 | (apply-modmorph (normalize-modexp new-name) map smod) | |
| 895 | ))) | |
| 896 | ;; | |
| 897 | (t (let ((nm (modmorph-construct-name map | |
| 898 | ;; (module-name smod) | |
| 899 | smod))) | |
| 900 | (let* ((me (normalize-modexp nm)) | |
| 901 | (val (find-modexp-eval me))) | |
| 902 | (when *on-modexp-debug* | |
| 903 | (format t "~&[modmorph-map-submodule]: ") | |
| 904 | (print-modexp smod) | |
| 905 | (princ " ==> ") | |
| 906 | (print-modexp me) | |
| 907 | (format t "~& - mod = ") | |
| 908 | (print-modexp mod) | |
| 909 | (format t "~& - map ") | |
| 910 | (print-mapping map) | |
| 911 | (format t "~& - val = ") | |
| 912 | (print-modexp val)) | |
| 913 | (if val | |
| 914 | (progn | |
| 915 | (let ((pair (assq smod (modmorph-module map))) | |
| 916 | (nmod val)) | |
| 917 | (when *on-modexp-debug* | |
| 918 | (format t "~& - map pair : ") | |
| 919 | (format t "~& key : ")(print-modexp (car pair)) | |
| 920 | (format t "~& val : ")(print-modexp (cdr pair))) | |
| 921 | (if pair | |
| 922 | (rplacd pair val) | |
| 923 | (push (cons smod val) (modmorph-module map))) | |
| 924 | (setf (modmorph-module map) | |
| 925 | (append (modmorph-compute-submodule-mappings | |
| 926 | map mod smod) | |
| 927 | (modmorph-module map))) | |
| 928 | nmod)) | |
| 929 | ;; | |
| 930 | (let ((newmod (apply-modmorph me map smod))) | |
| 931 | ;; (add-canon-modexp me me) | |
| 932 | (add-modexp-eval me newmod) | |
| 933 | (setf (modmorph-module map) | |
| 934 | (cons (cons smod newmod) | |
| 935 | (modmorph-module map))) | |
| 936 | newmod)))))))) | |
| 685 | (cond (parameters ; was (module-parameters smod) | |
| 686 | (when *on-modexp-debug* | |
| 687 | (format t "~%[modmorph-map-submodule]:") | |
| 688 | (print-modexp smod) | |
| 689 | (format t "~% sub has parameters :") | |
| 690 | (print-chaos-object parameters)) | |
| 691 | ;; submdule has parameters, | |
| 692 | ;; checks some of them is mapped or not. | |
| 693 | (let ((mod-map (modmorph-module map)) | |
| 694 | (own-params (mapcar #'(lambda (x) (parameter-theory-module x)) | |
| 695 | parameters)) | |
| 696 | (args nil)) | |
| 697 | (dolist (mmod mod-map) | |
| 698 | (if (memq (car mmod) own-params) | |
| 699 | (push (%!arg* (car (module-name (car mmod))) | |
| 700 | (cdr mmod)) | |
| 701 | args))) | |
| 702 | (let ((new-name (%instantiation* smod args))) | |
| 703 | ;; * * * | |
| 704 | (apply-modmorph (normalize-modexp new-name) map smod)))) | |
| 705 | ;; | |
| 706 | (t (let ((nm (modmorph-construct-name map | |
| 707 | ;; (module-name smod) | |
| 708 | smod))) | |
| 709 | (let* ((me (normalize-modexp nm)) | |
| 710 | (val (find-modexp-eval me))) | |
| 711 | (when *on-modexp-debug* | |
| 712 | (format t "~%[modmorph-map-submodule]: ") | |
| 713 | (print-modexp smod) | |
| 714 | (princ " ==> ") | |
| 715 | (print-modexp me) | |
| 716 | (format t "~& - mod = ") | |
| 717 | (print-modexp mod) | |
| 718 | (format t "~& - map ") | |
| 719 | (print-mapping map) | |
| 720 | (format t "~& - val = ") | |
| 721 | (print-modexp val)) | |
| 722 | (if val | |
| 723 | (progn | |
| 724 | (let ((pair (assq smod (modmorph-module map))) | |
| 725 | (nmod val)) | |
| 726 | (when *on-modexp-debug* | |
| 727 | (format t "~& - map pair : ") | |
| 728 | (format t "~& key : ")(print-modexp (car pair)) | |
| 729 | (format t "~& val : ")(print-modexp (cdr pair))) | |
| 730 | (if pair | |
| 731 | (rplacd pair val) | |
| 732 | (push (cons smod val) (modmorph-module map))) | |
| 733 | (setf (modmorph-module map) | |
| 734 | (append (modmorph-compute-submodule-mappings | |
| 735 | map mod smod) | |
| 736 | (modmorph-module map))) | |
| 737 | nmod)) | |
| 738 | ;; | |
| 739 | (let ((newmod (apply-modmorph me map smod))) | |
| 740 | ;; (add-canon-modexp me me) | |
| 741 | (add-modexp-eval me newmod) | |
| 742 | (setf (modmorph-module map) | |
| 743 | (cons (cons smod newmod) | |
| 744 | (modmorph-module map))) | |
| 745 | newmod)))))))) | |
| 937 | 746 | |
| 938 | 747 | (defvar *modmorph-expanded* nil) |
| 939 | 748 | |
| 940 | 749 | (defun modmorph-construct-name (map smod) |
| 941 | 750 | (cond ((modmorph-is-rename map) |
| 942 | (let ((s-name (module-name smod))) | |
| 943 | ;; smod can be a direct modexp. | |
| 944 | ;; Wed Mar 3 17:35:05 JST 1999 | |
| 945 | (cond ((modexp-is-parameter-theory s-name) | |
| 946 | (normalize-modexp `(,(parameter-theory-arg-name smod) | |
| 947 | "::" | |
| 948 | ,(modmorph-construct-name | |
| 949 | map | |
| 950 | (parameter-module-theory smod)) | |
| 951 | ,(parameter-module-context smod)))) | |
| 952 | (t (normalize-modexp | |
| 953 | (%rename* s-name | |
| 954 | (%rename-map (modmorph-name map))))) | |
| 955 | ))) | |
| 956 | (t (let ((*modmorph-expanded* nil)) | |
| 957 | (let ((val (modmorph-reconstruct-name map | |
| 958 | (if (module-p smod) | |
| 959 | (module-name smod) | |
| 960 | smod)))) | |
| 961 | (if (modexp-is-view val) | |
| 962 | (let ((val2 (target-of-view-arg val))) | |
| 963 | (if (module-p val2) | |
| 964 | (module-name val2) | |
| 965 | val2)) | |
| 966 | val)))))) | |
| 751 | (let ((s-name (module-name smod))) | |
| 752 | ;; smod can be a direct modexp. | |
| 753 | ;; Wed Mar 3 17:35:05 JST 1999 | |
| 754 | (cond ((modexp-is-parameter-theory s-name) | |
| 755 | (normalize-modexp `(,(parameter-theory-arg-name smod) | |
| 756 | "::" | |
| 757 | ,(modmorph-construct-name | |
| 758 | map | |
| 759 | (parameter-module-theory smod)) | |
| 760 | ,(parameter-module-context smod)))) | |
| 761 | (t (normalize-modexp | |
| 762 | (%rename* s-name | |
| 763 | (%rename-map (modmorph-name map)))))))) | |
| 764 | (t (let ((*modmorph-expanded* nil)) | |
| 765 | (let ((val (modmorph-reconstruct-name map | |
| 766 | (if (module-p smod) | |
| 767 | (module-name smod) | |
| 768 | smod)))) | |
| 769 | (if (modexp-is-view val) | |
| 770 | (let ((val2 (target-of-view-arg val))) | |
| 771 | (if (module-p val2) | |
| 772 | (module-name val2) | |
| 773 | val2)) | |
| 774 | val)))))) | |
| 967 | 775 | |
| 968 | 776 | ;;; want result in canonical form |
| 969 | 777 | (defun modmorph-reconstruct-name (map me) |
| 970 | 778 | (when *on-modexp-debug* |
| 971 | (format t "~%[modmorph-reconstruct-name]:") | |
| 972 | #|| | |
| 973 | (format t "~%-- given map ") | |
| 974 | (print-mapping map) | |
| 975 | (format t "~%-- given modexp ") | |
| 976 | (print-chaos-object me) | |
| 977 | ||# | |
| 978 | ) | |
| 779 | (format t "~%[modmorph-reconstruct-name]:")) | |
| 979 | 780 | ;; |
| 980 | 781 | (when (modexp-is-?name? me) |
| 981 | 782 | (when *on-modexp-debug* |
| 982 | (format t "~& given modexp was ?name? ~a" me)) | |
| 783 | (format t "~% given modexp was ?name? ~a" me)) | |
| 983 | 784 | (setq me (?name-name me))) |
| 984 | 785 | (when (and (consp me) (equal (second me) "::")) |
| 985 | 786 | (setq me (third me))) |
| 986 | 787 | (cond ((or (module-p me) (stringp me)) |
| 987 | (when *on-modexp-debug* | |
| 988 | (if (stringp me) | |
| 989 | (format t "~& given modexp is string ~s" me) | |
| 990 | (progn (format t "~& given modexp is module object :") | |
| 991 | (print-chaos-object me)))) | |
| 992 | (let ((modval (eval-modexp me)) ; must be global (not argument). | |
| 993 | (modmap (modmorph-module map))) | |
| 994 | (when *on-modexp-debug* | |
| 995 | (format t "~& evaluated value is : ") | |
| 996 | (print-chaos-object modval)) | |
| 997 | (let ((im (assq modval modmap))) | |
| 998 | (when *on-modexp-debug* | |
| 999 | (if im | |
| 1000 | (format t "~& evaluated modexp is mapped") | |
| 1001 | (format t "~& evaluated modexp is NOT mapped"))) | |
| 1002 | (if im | |
| 1003 | (if (memq modval *modmorph-expanded*) | |
| 1004 | (progn (when *on-modexp-debug* | |
| 1005 | (format t "~& and already expanded.")) | |
| 1006 | modval) | |
| 1007 | (progn | |
| 1008 | (when *on-modexp-debug* | |
| 1009 | (format t "~& but not yet expanded, reconstruct the target.")) | |
| 1010 | (push modval *modmorph-expanded*) | |
| 1011 | (modmorph-reconstruct-name map (cdr im)))) | |
| 1012 | (if (module-p me) | |
| 1013 | (let ((name (module-name me))) | |
| 1014 | (when *on-modexp-debug* | |
| 1015 | (format t "~& modexp was module object.")) | |
| 1016 | (if (modexp-is-simple-name name) | |
| 1017 | me | |
| 1018 | (modmorph-reconstruct-name map (module-name me)))) | |
| 1019 | (progn (when *on-modexp-debug* | |
| 1020 | (format t "~& modexp was string, returns as is.")) | |
| 1021 | me)))))) | |
| 1022 | ;; PLUS | |
| 1023 | ((int-plus-p me) | |
| 1024 | (when *on-modexp-debug* | |
| 1025 | (format t "~& modexp is internal plus.") | |
| 1026 | (pr-int-plus me)) | |
| 1027 | (make-int-plus :args | |
| 1028 | (mapcar #'(lambda (x) (modmorph-reconstruct-name map x)) | |
| 1029 | (int-plus-args me)))) | |
| 1030 | ((%is-plus me) | |
| 1031 | (when *on-modexp-debug* | |
| 1032 | (format t "~& modexp is plus, generate new modexp reconstructing args:") | |
| 1033 | (print-next) | |
| 1034 | (print-modexp me)) | |
| 1035 | (normalize-modexp | |
| 1036 | (%plus* (mapcar #'(lambda (x) (modmorph-reconstruct-name map x)) | |
| 1037 | (%plus-args me))))) | |
| 1038 | ||
| 1039 | ;; RENAME | |
| 1040 | ((int-rename-p me) | |
| 1041 | (when *on-modexp-debug* | |
| 1042 | (format t "~& modexp is iternal rename.") | |
| 1043 | (pr-int-rename me)) | |
| 1044 | (make-int-rename :module (modmorph-reconstruct-name map | |
| 1045 | (int-rename-module me)) | |
| 1046 | :sort-maps (int-rename-sort-maps me) | |
| 1047 | :op-maps (int-rename-op-maps me))) | |
| 1048 | ((%is-rename me) | |
| 1049 | (when *on-modexp-debug* | |
| 1050 | (format t "~& modexp is rename, generate new one reconstructing args.") | |
| 1051 | (print-next) | |
| 1052 | (print-modexp me)) | |
| 1053 | (normalize-modexp | |
| 1054 | (%rename* (modmorph-reconstruct-name map (%rename-module me)) | |
| 1055 | (%rename-map me)))) | |
| 1056 | ||
| 1057 | ;; INSTANTIATION | |
| 1058 | ((int-instantiation-p me) | |
| 1059 | (when *on-modexp-debug* | |
| 1060 | (format t "~& modexp is internal instantiation.") | |
| 1061 | (pr-int-instantiation me)) | |
| 1062 | (let ((modpar (int-instantiation-module me))) | |
| 1063 | (make-int-instantiation | |
| 1064 | :module (modmorph-reconstruct-name map modpar) | |
| 1065 | :args (let ((res nil)) | |
| 1066 | (dolist (arg (int-instantiation-args me) | |
| 1067 | (nreverse res)) | |
| 1068 | (push (modmorph-reconstruct-view-arg | |
| 1069 | (%!arg-name arg) | |
| 1070 | (%!arg-view arg) | |
| 1071 | map | |
| 1072 | modpar) | |
| 1073 | res)))))) | |
| 1074 | ;; | |
| 1075 | ((%is-instantiation me) | |
| 1076 | (when *on-modexp-debug* | |
| 1077 | (format t "~& modexp is instantiation, generate new one....") | |
| 1078 | (print-next) | |
| 1079 | (print-modexp me)) | |
| 1080 | (let* ((modpar (%instantiation-module me)) | |
| 1081 | (modparnm (if (module-p modpar) | |
| 1082 | (module-name modpar) | |
| 1083 | modpar))) | |
| 1084 | (%instantiation* (modmorph-reconstruct-name map modparnm) | |
| 1085 | (let ((res nil)) | |
| 1086 | (dolist (arg (%instantiation-args me)) | |
| 1087 | (push (modmorph-reconstruct-view-arg | |
| 1088 | (%!arg-name arg) ; name | |
| 1089 | (%!arg-view arg) ; view | |
| 1090 | map | |
| 1091 | modpar) | |
| 1092 | res)) | |
| 1093 | (nreverse res))))) | |
| 1094 | ||
| 1095 | ;; VIEW | |
| 1096 | ((view-p me) | |
| 1097 | (when *on-modexp-debug* | |
| 1098 | (format t "~& modexp is view structure, create new one.") | |
| 1099 | (print-next) | |
| 1100 | (print-modexp me)) | |
| 1101 | (let ((view (view-struct* (view-struct-name me)))) | |
| 1102 | (setf (view-struct-src view) (view-struct-src me)) | |
| 1103 | (setf (view-struct-target view) | |
| 1104 | (modmorph-reconstruct-name map (view-struct-target me))) | |
| 1105 | (setf (view-struct-sort-maps view) (view-struct-sort-maps me) | |
| 1106 | (view-struct-op-maps view) (view-struct-op-maps me)) | |
| 1107 | (setf (view-decl-form view) (view-decl-form me)) | |
| 1108 | view)) | |
| 1109 | ;; | |
| 1110 | (t (break "modmorph-reconstruct-name: missing case")) | |
| 1111 | )) | |
| 788 | (when *on-modexp-debug* | |
| 789 | (if (stringp me) | |
| 790 | (format t "~% given modexp is string ~s" me) | |
| 791 | (progn (format t "~% given modexp is module object :") | |
| 792 | (print-chaos-object me)))) | |
| 793 | (let ((modval (eval-modexp me)) ; must be global (not argument). | |
| 794 | (modmap (modmorph-module map))) | |
| 795 | (when *on-modexp-debug* | |
| 796 | (format t "~% evaluated value is : ") | |
| 797 | (print-chaos-object modval)) | |
| 798 | (let ((im (assq modval modmap))) | |
| 799 | (when *on-modexp-debug* | |
| 800 | (if im | |
| 801 | (format t "~% evaluated modexp is mapped") | |
| 802 | (format t "~% evaluated modexp is NOT mapped"))) | |
| 803 | (if im | |
| 804 | (if (memq modval *modmorph-expanded*) | |
| 805 | (progn (when *on-modexp-debug* | |
| 806 | (format t "~% and already expanded.")) | |
| 807 | modval) | |
| 808 | (progn | |
| 809 | (when *on-modexp-debug* | |
| 810 | (format t "~% but not yet expanded, reconstruct the target.")) | |
| 811 | (push modval *modmorph-expanded*) | |
| 812 | (modmorph-reconstruct-name map (cdr im)))) | |
| 813 | (if (module-p me) | |
| 814 | (let ((name (module-name me))) | |
| 815 | (when *on-modexp-debug* | |
| 816 | (format t "~% modexp was module object.")) | |
| 817 | (if (modexp-is-simple-name name) | |
| 818 | me | |
| 819 | (modmorph-reconstruct-name map (module-name me)))) | |
| 820 | (progn (when *on-modexp-debug* | |
| 821 | (format t "~% modexp was string, returns as is.")) | |
| 822 | me)))))) | |
| 823 | ;; PLUS | |
| 824 | ((int-plus-p me) | |
| 825 | (when *on-modexp-debug* | |
| 826 | (format t "~% modexp is internal plus.") | |
| 827 | (pr-int-plus me)) | |
| 828 | (make-int-plus :args | |
| 829 | (mapcar #'(lambda (x) (modmorph-reconstruct-name map x)) | |
| 830 | (int-plus-args me)))) | |
| 831 | ((%is-plus me) | |
| 832 | (when *on-modexp-debug* | |
| 833 | (format t "~% modexp is plus, generate new modexp reconstructing args:") | |
| 834 | (print-next) | |
| 835 | (print-modexp me)) | |
| 836 | (normalize-modexp | |
| 837 | (%plus* (mapcar #'(lambda (x) (modmorph-reconstruct-name map x)) | |
| 838 | (%plus-args me))))) | |
| 839 | ||
| 840 | ;; RENAME | |
| 841 | ((int-rename-p me) | |
| 842 | (when *on-modexp-debug* | |
| 843 | (format t "~% modexp is iternal rename.") | |
| 844 | (pr-int-rename me)) | |
| 845 | (make-int-rename :module (modmorph-reconstruct-name map | |
| 846 | (int-rename-module me)) | |
| 847 | :sort-maps (int-rename-sort-maps me) | |
| 848 | :op-maps (int-rename-op-maps me))) | |
| 849 | ((%is-rename me) | |
| 850 | (when *on-modexp-debug* | |
| 851 | (format t "~% modexp is rename, generate new one reconstructing args.") | |
| 852 | (print-next) | |
| 853 | (print-modexp me)) | |
| 854 | (normalize-modexp | |
| 855 | (%rename* (modmorph-reconstruct-name map (%rename-module me)) | |
| 856 | (%rename-map me)))) | |
| 857 | ||
| 858 | ;; INSTANTIATION | |
| 859 | ((int-instantiation-p me) | |
| 860 | (when *on-modexp-debug* | |
| 861 | (format t "~% modexp is internal instantiation.") | |
| 862 | (pr-int-instantiation me)) | |
| 863 | (let ((modpar (int-instantiation-module me))) | |
| 864 | (make-int-instantiation | |
| 865 | :module (modmorph-reconstruct-name map modpar) | |
| 866 | :args (let ((res nil)) | |
| 867 | (dolist (arg (int-instantiation-args me) | |
| 868 | (nreverse res)) | |
| 869 | (push (modmorph-reconstruct-view-arg | |
| 870 | (%!arg-name arg) | |
| 871 | (%!arg-view arg) | |
| 872 | map | |
| 873 | modpar) | |
| 874 | res)))))) | |
| 875 | ;; | |
| 876 | ((%is-instantiation me) | |
| 877 | (when *on-modexp-debug* | |
| 878 | (format t "~% modexp is instantiation, generate new one....") | |
| 879 | (print-next) | |
| 880 | (print-modexp me)) | |
| 881 | (let* ((modpar (%instantiation-module me)) | |
| 882 | (modparnm (if (module-p modpar) | |
| 883 | (module-name modpar) | |
| 884 | modpar))) | |
| 885 | (%instantiation* (modmorph-reconstruct-name map modparnm) | |
| 886 | (let ((res nil)) | |
| 887 | (dolist (arg (%instantiation-args me)) | |
| 888 | (push (modmorph-reconstruct-view-arg | |
| 889 | (%!arg-name arg) ; name | |
| 890 | (%!arg-view arg) ; view | |
| 891 | map | |
| 892 | modpar) | |
| 893 | res)) | |
| 894 | (nreverse res))))) | |
| 895 | ||
| 896 | ;; VIEW | |
| 897 | ((view-p me) | |
| 898 | (when *on-modexp-debug* | |
| 899 | (format t "~% modexp is view structure, create new one.") | |
| 900 | (print-next) | |
| 901 | (print-modexp me)) | |
| 902 | (let ((view (view-struct* (view-struct-name me)))) | |
| 903 | (setf (view-struct-src view) (view-struct-src me)) | |
| 904 | (setf (view-struct-target view) | |
| 905 | (modmorph-reconstruct-name map (view-struct-target me))) | |
| 906 | (setf (view-struct-sort-maps view) (view-struct-sort-maps me) | |
| 907 | (view-struct-op-maps view) (view-struct-op-maps me)) | |
| 908 | (setf (view-decl-form view) (view-decl-form me)) | |
| 909 | view)) | |
| 910 | ;; | |
| 911 | (t (break "modmorph-reconstruct-name: missing case")))) | |
| 1112 | 912 | |
| 1113 | 913 | (defun target-of-view-arg (vw) |
| 1114 | 914 | (when (modexp-is-?name? vw) |
| 1115 | 915 | (setq vw (?name-name vw))) |
| 1116 | 916 | (cond ((stringp vw) vw) |
| 1117 | ((module-p vw) vw) | |
| 1118 | ((view-p vw) (view-target vw)) | |
| 1119 | ((%is-view vw) (%view-target vw)) | |
| 1120 | (t (break "target-of-view-arg: unknown view argument")) | |
| 1121 | )) | |
| 917 | ((module-p vw) vw) | |
| 918 | ((view-p vw) (view-target vw)) | |
| 919 | ((%is-view vw) (%view-target vw)) | |
| 920 | (t (break "target-of-view-arg: unknown view argument")))) | |
| 1122 | 921 | |
| 1123 | 922 | (eval-when (:execute :compile-toplevel :load-toplevel) |
| 1124 | 923 | (declaim (type fixnum *anon-view-name*)) |
| 1135 | 934 | (print-chaos-object vw) |
| 1136 | 935 | (chaos-error 'panic))) |
| 1137 | 936 | (let* ((tgt (target-of-view-arg vw)) |
| 1138 | (modmap (modmorph-module map)) | |
| 1139 | (val (assq tgt modmap)) | |
| 1140 | (mod (view-src vw))) | |
| 937 | (modmap (modmorph-module map)) | |
| 938 | (val (assq tgt modmap)) | |
| 939 | (mod (view-src vw))) | |
| 1141 | 940 | (when *on-modexp-debug* |
| 1142 | (format t "~&[reconstruct-view-arg]:arg-name=~a " arg-name) | |
| 941 | (format t "~%[reconstruct-view-arg]:arg-name=~a " arg-name) | |
| 1143 | 942 | (print-next) |
| 1144 | 943 | (print-chaos-object vw) |
| 1145 | 944 | (force-output)) |
| 1146 | 945 | (let ((actual (or (cdr val) tgt))) |
| 1147 | 946 | (let ((tmod (if (module-p actual) |
| 1148 | actual | |
| 1149 | (target-of-view-arg actual))) | |
| 1150 | (view (view-struct* (make-anon-view-name)))) | |
| 1151 | (when *on-modexp-debug* | |
| 1152 | (format t "~&- src = ")(print-chaos-object mod) | |
| 1153 | (format t "~&- tgt = ")(print-chaos-object tmod) | |
| 1154 | (unless tmod (break "Oh my God!"))) | |
| 1155 | (setf (view-src view) mod) | |
| 1156 | (setf (view-target view) tmod) | |
| 1157 | (setf (view-sort-maps view) | |
| 1158 | (modmorph-reconstruct-view-sort-mapping | |
| 1159 | tmod | |
| 1160 | map | |
| 1161 | (view-sort-maps vw))) | |
| 1162 | (setf (view-op-maps view) | |
| 1163 | (modmorph-reconstruct-view-op-mapping | |
| 1164 | tmod | |
| 1165 | map | |
| 1166 | (view-op-maps vw))) | |
| 1167 | (when *on-modexp-debug* | |
| 1168 | (format t "~&*result view=") | |
| 1169 | (print-chaos-object view)) | |
| 1170 | (%!arg* arg-name view))) | |
| 1171 | )) | |
| 947 | actual | |
| 948 | (target-of-view-arg actual))) | |
| 949 | (view (view-struct* (make-anon-view-name)))) | |
| 950 | (when *on-modexp-debug* | |
| 951 | (format t "~%- src = ")(print-chaos-object mod) | |
| 952 | (format t "~&- tgt = ")(print-chaos-object tmod) | |
| 953 | (unless tmod (break "Oh my God!"))) | |
| 954 | (setf (view-src view) mod) | |
| 955 | (setf (view-target view) tmod) | |
| 956 | (setf (view-sort-maps view) | |
| 957 | (modmorph-reconstruct-view-sort-mapping | |
| 958 | tmod | |
| 959 | map | |
| 960 | (view-sort-maps vw))) | |
| 961 | (setf (view-op-maps view) | |
| 962 | (modmorph-reconstruct-view-op-mapping | |
| 963 | tmod | |
| 964 | map | |
| 965 | (view-op-maps vw))) | |
| 966 | (when *on-modexp-debug* | |
| 967 | (format t "~%*result view=") | |
| 968 | (print-chaos-object view)) | |
| 969 | (%!arg* arg-name view))))) | |
| 1172 | 970 | |
| 1173 | 971 | (defun modmorph-reconstruct-view-sort-mapping (mod map s-maps) |
| 1174 | 972 | (declare (ignore mod)) |
| 1175 | 973 | (let ((res nil) |
| 1176 | (modmorph-sort-map (modmorph-sort map))) | |
| 974 | (modmorph-sort-map (modmorph-sort map))) | |
| 1177 | 975 | (dolist (s-map s-maps (nreverse res)) |
| 1178 | 976 | (push (cons (car s-map) |
| 1179 | (modmorph-assoc-image modmorph-sort-map | |
| 1180 | (cdr s-map))) | |
| 1181 | res)))) | |
| 977 | (modmorph-assoc-image modmorph-sort-map | |
| 978 | (cdr s-map))) | |
| 979 | res)))) | |
| 1182 | 980 | |
| 1183 | 981 | (defun modmorph-reconstruct-view-op-mapping (mod map o-maps) |
| 1184 | 982 | (let ((res nil) |
| 1185 | (modmorph-op-map (modmorph-op map))) | |
| 983 | (modmorph-op-map (modmorph-op map))) | |
| 1186 | 984 | (dolist (o-map o-maps (nreverse res)) |
| 1187 | 985 | (push (list (car o-map) |
| 1188 | (modmorph-apply-op-map-2 mod | |
| 1189 | map | |
| 1190 | modmorph-op-map | |
| 1191 | (cadr o-map))) | |
| 1192 | res)))) | |
| 986 | (modmorph-apply-op-map-2 mod | |
| 987 | map | |
| 988 | modmorph-op-map | |
| 989 | (cadr o-map))) | |
| 990 | res)))) | |
| 1193 | 991 | |
| 1194 | 992 | ;;; op-mapping ::= (:simple . method) |
| 1195 | 993 | ;;; | (:replacement List[psuedo var] term) |
| 1197 | 995 | (defun apply-op-mapping-2 (module map op-mapping term) |
| 1198 | 996 | (if (eq ':simple-map (car op-mapping)) |
| 1199 | 997 | (make-term-check-op-with-sort-check (cdr op-mapping) |
| 1200 | (term-subterms term) | |
| 1201 | module) | |
| 998 | (term-subterms term) | |
| 999 | module) | |
| 1202 | 1000 | (with-in-module (module) |
| 1203 | (mapping-image-2 map (term-subterms term) (caddr op-mapping))))) | |
| 1001 | (mapping-image-2 map (term-subterms term) (caddr op-mapping))))) | |
| 1204 | 1002 | |
| 1205 | 1003 | (defun modmorph-apply-op-map-2 (module map op_map term) |
| 1206 | 1004 | (let ((val (assoc (term-head term) op_map))) |
| 1207 | 1005 | (if val |
| 1208 | (apply-op-mapping-2 module map (cdr val) term) | |
| 1209 | (let* ((op (term-head term)) | |
| 1210 | (om (method-module op)) | |
| 1211 | (as (assoc om (modmorph-module map)))) | |
| 1212 | (if (and as (cdr as) (not (eq (cdr as) om))) | |
| 1213 | (with-in-module (module) | |
| 1214 | (mapping-image-2 map (term-subterms term) term)) | |
| 1215 | term))))) | |
| 1006 | (apply-op-mapping-2 module map (cdr val) term) | |
| 1007 | (let* ((op (term-head term)) | |
| 1008 | (om (method-module op)) | |
| 1009 | (as (assoc om (modmorph-module map)))) | |
| 1010 | (if (and as (cdr as) (not (eq (cdr as) om))) | |
| 1011 | (with-in-module (module) | |
| 1012 | (mapping-image-2 map (term-subterms term) term)) | |
| 1013 | term))))) | |
| 1216 | 1014 | |
| 1217 | 1015 | |
| 1218 | 1016 | ;;; MODMORPH-COMPUTE-SUBMODULE-MAPPINGS: |
| 1219 | 1017 | ;;; |
| 1220 | 1018 | (defun modmorph-compute-submodule-mappings (map mod smod) |
| 1221 | 1019 | (when *on-modexp-debug* |
| 1222 | (format t "~&[modmorph-compute-submodule-mappings]:") | |
| 1020 | (format t "~%[modmorph-compute-submodule-mappings]:") | |
| 1223 | 1021 | (format t "~& - map = ") (print-mapping map) |
| 1224 | 1022 | (format t "~& - mod = ") (print-modexp mod) |
| 1225 | 1023 | (format t "~& - smod = ") (print-modexp smod)) |
| 1226 | 1024 | (let ((res nil) |
| 1227 | (modmap (modmorph-module map))) | |
| 1025 | (modmap (modmorph-module map))) | |
| 1228 | 1026 | (dolist (smp (module-submodules smod)) |
| 1229 | 1027 | (let ((sm (car smp))) |
| 1230 | (cond ((and (not (eq ':using (cdr smp))) | |
| 1231 | (modmorph-submodule-is-mapped modmap sm)) | |
| 1232 | (when *on-modexp-debug* | |
| 1233 | (format t "~& - sm = ") (print-modexp sm) | |
| 1234 | (format t " is mapped.")) | |
| 1235 | (setq res | |
| 1236 | (cons (cons sm | |
| 1237 | (eval-modexp (modmorph-construct-name | |
| 1238 | map | |
| 1239 | ;; (module-name sm) | |
| 1240 | sm))) | |
| 1241 | (append (modmorph-compute-submodule-mappings map mod sm) | |
| 1242 | res)))) | |
| 1243 | ;; | |
| 1244 | (t (let ((aval (assq sm modmap))) | |
| 1245 | (when *on-modexp-debug* | |
| 1246 | (format t "~& - aval(img) = ") (print-modexp (cdr aval))) | |
| 1247 | (when (and aval | |
| 1248 | (is-dummy-module (cdr aval))) | |
| 1249 | (let ((newm (eval-modexp | |
| 1250 | (modmorph-construct-name map | |
| 1251 | ;; (module-name sm) | |
| 1252 | sm)))) | |
| 1253 | #|| | |
| 1254 | (push (cons (cdr aval) newm) | |
| 1255 | (modmorph-module map)) | |
| 1256 | ||# | |
| 1257 | (rplacd aval newm)))))))) | |
| 1028 | (cond ((and (not (eq ':using (cdr smp))) | |
| 1029 | (modmorph-submodule-is-mapped modmap sm)) | |
| 1030 | (when *on-modexp-debug* | |
| 1031 | (format t "~& - sm = ") (print-modexp sm) | |
| 1032 | (format t " is mapped.")) | |
| 1033 | (setq res | |
| 1034 | (cons (cons sm | |
| 1035 | (eval-modexp (modmorph-construct-name | |
| 1036 | map | |
| 1037 | ;; (module-name sm) | |
| 1038 | sm))) | |
| 1039 | (append (modmorph-compute-submodule-mappings map mod sm) | |
| 1040 | res)))) | |
| 1041 | ;; | |
| 1042 | (t (let ((aval (assq sm modmap))) | |
| 1043 | (when *on-modexp-debug* | |
| 1044 | (format t "~& - aval(img) = ") (print-modexp (cdr aval))) | |
| 1045 | (when (and aval | |
| 1046 | (is-dummy-module (cdr aval))) | |
| 1047 | (let ((newm (eval-modexp | |
| 1048 | (modmorph-construct-name map | |
| 1049 | ;; (module-name sm) | |
| 1050 | sm)))) | |
| 1051 | #|| | |
| 1052 | (push (cons (cdr aval) newm) | |
| 1053 | (modmorph-module map)) | |
| 1054 | ||# | |
| 1055 | (rplacd aval newm)))))))) | |
| 1258 | 1056 | res)) |
| 1259 | 1057 | |
| 1260 | 1058 | ;;; ****************** |
| 1269 | 1067 | |
| 1270 | 1068 | (defun modmorph-recreate-sort (mod modmap sortmap sort) |
| 1271 | 1069 | (let ((sort-name (sort-id sort)) |
| 1272 | (smod (sort-module sort))) | |
| 1070 | (smod (sort-module sort))) | |
| 1273 | 1071 | (let* ((mmod (cdr (assq smod modmap))) |
| 1274 | (themod (if (and mmod (module-p mmod)) mmod mod)) | |
| 1275 | (asort (find sort-name (module-all-sorts mod) | |
| 1276 | :test #'(lambda (n s) | |
| 1277 | (and (equal n (sort-id s)) | |
| 1278 | (eq themod (sort-module s))))))) | |
| 1072 | (themod (if (and mmod (module-p mmod)) mmod mod)) | |
| 1073 | (asort (find sort-name (module-all-sorts mod) | |
| 1074 | :test #'(lambda (n s) | |
| 1075 | (and (equal n (sort-id s)) | |
| 1076 | (eq themod (sort-module s))))))) | |
| 1279 | 1077 | (when *on-modexp-debug* |
| 1280 | (format t "~&[modmorph-recreate-sort]:") | |
| 1281 | (format t "~&-- modmap = ") | |
| 1282 | (dolist (i modmap) | |
| 1283 | (print-next) | |
| 1284 | (print-modexp (car i)) (princ "-->") | |
| 1285 | (print-modexp (cdr i)) (princ " ")) | |
| 1286 | (format t "~&-- mod = ") (print-modexp mod) | |
| 1287 | (format t "~&-- thmod = ") (print-modexp themod) | |
| 1288 | (format t "~&-- sort-name = ~a" (string sort-name)) | |
| 1289 | (format t "~&-- smod = ") (print-modexp smod)) | |
| 1078 | (format t "~%[modmorph-recreate-sort]:") | |
| 1079 | (format t "~&-- modmap = ") | |
| 1080 | (dolist (i modmap) | |
| 1081 | (print-next) | |
| 1082 | (print-modexp (car i)) (princ "-->") | |
| 1083 | (print-modexp (cdr i)) (princ " ")) | |
| 1084 | (format t "~&-- mod = ") (print-modexp mod) | |
| 1085 | (format t "~&-- thmod = ") (print-modexp themod) | |
| 1086 | (format t "~&-- sort-name = ~a" (string sort-name)) | |
| 1087 | (format t "~&-- smod = ") (print-modexp smod)) | |
| 1290 | 1088 | ;; |
| 1291 | 1089 | (if asort |
| 1292 | asort | |
| 1293 | (let ((newsort (!recreate-sort themod sort))) | |
| 1294 | ;; | |
| 1295 | (when *on-modexp-debug* | |
| 1296 | (format t "~%* generated the new one!!!")) | |
| 1297 | (push (cons sort newsort) sortmap) | |
| 1298 | newsort) | |
| 1299 | )))) | |
| 1090 | asort | |
| 1091 | (let ((newsort (!recreate-sort themod sort))) | |
| 1092 | ;; | |
| 1093 | (when *on-modexp-debug* | |
| 1094 | (format t "~%* generated the new one!!!")) | |
| 1095 | (push (cons sort newsort) sortmap) | |
| 1096 | newsort) | |
| 1097 | )))) | |
| 1300 | 1098 | |
| 1301 | 1099 | ;;;----------------------------------------------------------------------------- |
| 1302 | 1100 | ;;; MODMORPH-RECREATE-SORT-RELATIONS |
| 1304 | 1102 | |
| 1305 | 1103 | (defun modmorph-recreate-sort-relations (module oldmod modmap sortmap sort-relations) |
| 1306 | 1104 | (macrolet ((reduce-sort-set (x) |
| 1307 | ` (let (($$res nil)) | |
| 1308 | (dolist (e ,x) (unless (memq e $$res) (push e $$res))) | |
| 1309 | (nreverse $$res)))) | |
| 1105 | ` (let (($$res nil)) | |
| 1106 | (dolist (e ,x) (unless (memq e $$res) (push e $$res))) | |
| 1107 | (nreverse $$res)))) | |
| 1310 | 1108 | (let ((res nil)) |
| 1311 | 1109 | (dolist (rel sort-relations) |
| 1312 | (let ((rel (elim-sys-sorts-from-relation rel))) | |
| 1313 | (when rel (push rel res)))) | |
| 1110 | (let ((rel (elim-sys-sorts-from-relation rel))) | |
| 1111 | (when rel (push rel res)))) | |
| 1314 | 1112 | (mapcar #'(lambda (sl) |
| 1315 | (let ((srt (modmorph-sort-image-create | |
| 1316 | module oldmod modmap sortmap | |
| 1317 | (sort-relation-sort sl))) | |
| 1318 | (subs (reduce-sort-set | |
| 1319 | (modmorph-sorts-image-create module oldmod modmap | |
| 1320 | sortmap (_subsorts | |
| 1321 | sl)))) | |
| 1322 | (sups (reduce-sort-set | |
| 1323 | (modmorph-sorts-image-create module oldmod modmap | |
| 1324 | sortmap (_supersorts | |
| 1325 | sl))))) | |
| 1326 | (make-sort-relation srt subs sups))) | |
| 1327 | res)))) | |
| 1113 | (let ((srt (modmorph-sort-image-create | |
| 1114 | module oldmod modmap sortmap | |
| 1115 | (sort-relation-sort sl))) | |
| 1116 | (subs (reduce-sort-set | |
| 1117 | (modmorph-sorts-image-create module oldmod modmap | |
| 1118 | sortmap (_subsorts | |
| 1119 | sl)))) | |
| 1120 | (sups (reduce-sort-set | |
| 1121 | (modmorph-sorts-image-create module oldmod modmap | |
| 1122 | sortmap (_supersorts | |
| 1123 | sl))))) | |
| 1124 | (make-sort-relation srt subs sups))) | |
| 1125 | res)))) | |
| 1328 | 1126 | |
| 1329 | 1127 | ;; *NOTE* assume all of the system generated sorts are eliminated. |
| 1330 | 1128 | |
| 1332 | 1130 | (dolist (x sl1) |
| 1333 | 1131 | (let ((rel (assq (sort-relation-sort x) sl2))) |
| 1334 | 1132 | (if rel |
| 1335 | (progn | |
| 1336 | (setf (_subsorts rel) (union (_subsorts x) (_subsorts rel) | |
| 1337 | :test #'eq)) | |
| 1338 | (setf (_supersorts rel) (union (_supersorts x) (_supersorts rel) | |
| 1339 | :test #'eq))) | |
| 1340 | (push x sl2)))) | |
| 1133 | (progn | |
| 1134 | (setf (_subsorts rel) (union (_subsorts x) (_subsorts rel) | |
| 1135 | :test #'eq)) | |
| 1136 | (setf (_supersorts rel) (union (_supersorts x) (_supersorts rel) | |
| 1137 | :test #'eq))) | |
| 1138 | (push x sl2)))) | |
| 1341 | 1139 | sl2) |
| 1342 | ||
| 1140 | ||
| 1343 | 1141 | ;;; |
| 1344 | 1142 | ;;; |
| 1345 | 1143 | (defun modmorph-sort-image-create (module oldmod modmap sortmap sort) |
| 1346 | 1144 | (let ((s1 (modmorph-assoc-image sortmap sort))) |
| 1347 | 1145 | (if (not (eq s1 sort)) |
| 1348 | s1 | |
| 1349 | (if (is-dummy-module (sort-module sort)) | |
| 1350 | (let* ((mod (sort-module sort)) | |
| 1351 | (info (get-rename-info mod)) | |
| 1352 | (oldmod (car info)) | |
| 1353 | (modim (cdr (assq oldmod modmap)))) | |
| 1354 | (if modim | |
| 1355 | (let ((val (let ((asrt | |
| 1356 | (modmorph-find-sort-in modim (sort-id sort)))) | |
| 1357 | (if asrt asrt | |
| 1358 | (if (or (eq sort *universal-sort*) | |
| 1359 | (eq sort *huniversal-sort*) | |
| 1360 | (eq sort *bool-sort*) | |
| 1361 | (eq sort *sort-error*)) | |
| 1362 | sort | |
| 1363 | nil))))) | |
| 1364 | (if val | |
| 1365 | val | |
| 1366 | (progn | |
| 1367 | (setf (sort-module sort) modim) | |
| 1368 | (add-sort-to-module sort modim) | |
| 1369 | sort))) | |
| 1370 | sort)) | |
| 1371 | (if (not (eq oldmod (sort-module sort))) | |
| 1372 | sort | |
| 1373 | (let ((newsort (modmorph-recreate-sort module | |
| 1374 | modmap | |
| 1375 | sortmap | |
| 1376 | sort))) | |
| 1377 | (add-sort-to-module newsort module) | |
| 1378 | newsort)))))) | |
| 1146 | s1 | |
| 1147 | (if (is-dummy-module (sort-module sort)) | |
| 1148 | (let* ((mod (sort-module sort)) | |
| 1149 | (info (get-rename-info mod)) | |
| 1150 | (oldmod (car info)) | |
| 1151 | (modim (cdr (assq oldmod modmap)))) | |
| 1152 | (if modim | |
| 1153 | (let ((val (let ((asrt | |
| 1154 | (modmorph-find-sort-in modim (sort-id sort)))) | |
| 1155 | (if asrt asrt | |
| 1156 | (if (or (eq sort *universal-sort*) | |
| 1157 | (eq sort *huniversal-sort*) | |
| 1158 | (eq sort *bool-sort*) | |
| 1159 | (eq sort *sort-error*)) | |
| 1160 | sort | |
| 1161 | nil))))) | |
| 1162 | (if val | |
| 1163 | val | |
| 1164 | (progn | |
| 1165 | (setf (sort-module sort) modim) | |
| 1166 | (add-sort-to-module sort modim) | |
| 1167 | sort))) | |
| 1168 | sort)) | |
| 1169 | (if (not (eq oldmod (sort-module sort))) | |
| 1170 | sort | |
| 1171 | (let ((newsort (modmorph-recreate-sort module | |
| 1172 | modmap | |
| 1173 | sortmap | |
| 1174 | sort))) | |
| 1175 | (add-sort-to-module newsort module) | |
| 1176 | newsort)))))) | |
| 1379 | 1177 | |
| 1380 | 1178 | (defun modmorph-sorts-image-create (module oldmod modmap sortmap sortlist) |
| 1381 | 1179 | (let ((img (mapcar #'(lambda (x) (modmorph-sort-image-create module |
| 1382 | oldmod | |
| 1383 | modmap | |
| 1384 | sortmap | |
| 1385 | x)) | |
| 1386 | sortlist))) | |
| 1180 | oldmod | |
| 1181 | modmap | |
| 1182 | sortmap | |
| 1183 | x)) | |
| 1184 | sortlist))) | |
| 1387 | 1185 | img)) |
| 1388 | 1186 | |
| 1389 | 1187 | ;;; sort should already exist |
| 1391 | 1189 | (defun modmorph-sort-image (module sortmap sort) |
| 1392 | 1190 | (let ((s1 (modmorph-assoc-image sortmap sort))) |
| 1393 | 1191 | (if (or (memq s1 (module-all-sorts module)) |
| 1394 | (memq s1 (module-error-sorts module))) | |
| 1395 | s1 | |
| 1192 | (memq s1 (module-error-sorts module))) | |
| 1193 | s1 | |
| 1396 | 1194 | (let ((val (if (err-sort-p sort) |
| 1397 | (find-compatible-err-sort sort module sortmap) | |
| 1398 | (find-sort-in module (sort-id s1))))) | |
| 1399 | ;; (break) | |
| 1195 | (find-compatible-err-sort sort module sortmap) | |
| 1196 | (find-sort-in module (sort-id s1))))) | |
| 1197 | ;; (break) | |
| 1400 | 1198 | (if val |
| 1401 | val | |
| 1402 | (if (or (eq sort *universal-sort*) | |
| 1403 | (eq sort *huniversal-sort*) | |
| 1404 | (eq sort *bool-sort*) | |
| 1405 | (eq sort *sort-error*)) | |
| 1406 | sort | |
| 1407 | (unless (err-sort-p s1) | |
| 1408 | (with-output-chaos-warning () | |
| 1409 | (format t "image sort ~a not found in module " | |
| 1410 | (string (sort-id s1))) | |
| 1411 | (print-chaos-object module) | |
| 1412 | ;; (break) | |
| 1413 | (return-from modmorph-sort-image nil))) | |
| 1414 | ))) | |
| 1415 | ))) | |
| 1199 | val | |
| 1200 | (if (or (eq sort *universal-sort*) | |
| 1201 | (eq sort *huniversal-sort*) | |
| 1202 | (eq sort *bool-sort*) | |
| 1203 | (eq sort *sort-error*)) | |
| 1204 | sort | |
| 1205 | (unless (err-sort-p s1) | |
| 1206 | (with-output-chaos-warning () | |
| 1207 | (format t "image sort ~a not found in module " | |
| 1208 | (string (sort-id s1))) | |
| 1209 | (print-chaos-object module) | |
| 1210 | ;; (break) | |
| 1211 | (return-from modmorph-sort-image nil))))))))) | |
| 1416 | 1212 | |
| 1417 | 1213 | (defun modmorph-sorts-image (module sortmap sortlist) |
| 1418 | 1214 | (mapcar #'(lambda (x) (modmorph-sort-image module sortmap x)) |
| 1419 | sortlist)) | |
| 1215 | sortlist)) | |
| 1420 | 1216 | |
| 1421 | 1217 | ;;; OPERATORS |
| 1422 | 1218 | |
| 1426 | 1222 | |
| 1427 | 1223 | (defun modmorph-recreate-method (oldmodule module sortmap method) |
| 1428 | 1224 | (when (or (not (method-is-error-method method)) |
| 1429 | (method-is-user-defined-error-method method)) | |
| 1225 | (method-is-user-defined-error-method method)) | |
| 1430 | 1226 | (let ((op-symbol (method-symbol method)) |
| 1431 | (arity (modmorph-sorts-image module | |
| 1432 | sortmap | |
| 1433 | (method-arity method))) | |
| 1434 | (coarity (modmorph-sort-image module | |
| 1435 | sortmap | |
| 1436 | (method-coarity method)))) | |
| 1227 | (arity (modmorph-sorts-image module | |
| 1228 | sortmap | |
| 1229 | (method-arity method))) | |
| 1230 | (coarity (modmorph-sort-image module | |
| 1231 | sortmap | |
| 1232 | (method-coarity method)))) | |
| 1437 | 1233 | (let ((val (find-method-in module op-symbol arity coarity))) |
| 1438 | (when *on-modexp-debug* | |
| 1439 | (when val | |
| 1440 | ;; (break) | |
| 1441 | (format t "~&[modmorph-recreate-method] :") | |
| 1442 | (format t "~&-method image is already in module ") | |
| 1443 | (print-chaos-object method))) | |
| 1444 | (if val | |
| 1445 | (modmorph-recreate-method-aux-2 oldmodule module sortmap val) | |
| 1446 | (modmorph-recreate-method-aux-1 oldmodule | |
| 1447 | module | |
| 1448 | method | |
| 1449 | op-symbol | |
| 1450 | arity | |
| 1451 | coarity | |
| 1452 | sortmap)) | |
| 1453 | )))) | |
| 1234 | (when *on-modexp-debug* | |
| 1235 | (when val | |
| 1236 | ;; (break) | |
| 1237 | (format t "~%[modmorph-recreate-method] :") | |
| 1238 | (format t "~&-method image is already in module ") | |
| 1239 | (print-chaos-object method))) | |
| 1240 | (if val | |
| 1241 | (modmorph-recreate-method-aux-2 oldmodule module sortmap val) | |
| 1242 | (modmorph-recreate-method-aux-1 oldmodule | |
| 1243 | module | |
| 1244 | method | |
| 1245 | op-symbol | |
| 1246 | arity | |
| 1247 | coarity | |
| 1248 | sortmap)))))) | |
| 1454 | 1249 | |
| 1455 | 1250 | (defun modmorph-recreate-method-aux-1 (oldmodule module |
| 1456 | method | |
| 1457 | op-symbol | |
| 1458 | arity | |
| 1459 | coarity | |
| 1460 | sort-map) | |
| 1461 | (recreate-method oldmodule method module op-symbol arity coarity sort-map) | |
| 1462 | ) | |
| 1251 | method | |
| 1252 | op-symbol | |
| 1253 | arity | |
| 1254 | coarity | |
| 1255 | sort-map) | |
| 1256 | (recreate-method oldmodule method module op-symbol arity coarity sort-map)) | |
| 1463 | 1257 | |
| 1464 | 1258 | (defun modmorph-recreate-method-aux-2 (oldmodule module sortmap method) |
| 1465 | 1259 | (declare (ignore sortmap)) |
| 1470 | 1264 | (let ((minfo (module-opinfo-table mod))) |
| 1471 | 1265 | (dolist (method (opinfo-methods opinfo)) |
| 1472 | 1266 | (let ((thy (method-theory method minfo))) |
| 1473 | (when thy | |
| 1474 | (setf (method-theory method minfo) | |
| 1475 | (cond ((theory-contains-identity thy) | |
| 1476 | (let ((zero (theory-zero thy))) | |
| 1477 | (if zero | |
| 1478 | (progn | |
| 1479 | ;; (break) ; | |
| 1480 | (theory-make | |
| 1481 | (theory-info thy) | |
| 1482 | (let ((srtmap (modmorph-sort map)) | |
| 1483 | (opmap (modmorph-op map)) | |
| 1484 | (modmap (modmorph-module map)) | |
| 1485 | (idinf (if (eq '%to-rename | |
| 1486 | (car zero)) | |
| 1487 | (cdr zero) | |
| 1488 | zero))) | |
| 1489 | (cons (modmorph-recreate-term mod | |
| 1490 | srtmap | |
| 1491 | opmap | |
| 1492 | modmap | |
| 1493 | (car idinf)) | |
| 1494 | (cdr idinf))))) | |
| 1495 | thy))) | |
| 1496 | (t thy))) | |
| 1497 | (compute-method-theory-info-for-matching method minfo)) | |
| 1498 | ) ; dolist | |
| 1267 | (when thy | |
| 1268 | (setf (method-theory method minfo) | |
| 1269 | (cond ((theory-contains-identity thy) | |
| 1270 | (let ((zero (theory-zero thy))) | |
| 1271 | (if zero | |
| 1272 | (progn | |
| 1273 | ;; (break) ; | |
| 1274 | (theory-make | |
| 1275 | (theory-info thy) | |
| 1276 | (let ((srtmap (modmorph-sort map)) | |
| 1277 | (opmap (modmorph-op map)) | |
| 1278 | (modmap (modmorph-module map)) | |
| 1279 | (idinf (if (eq '%to-rename | |
| 1280 | (car zero)) | |
| 1281 | (cdr zero) | |
| 1282 | zero))) | |
| 1283 | (cons (modmorph-recreate-term mod | |
| 1284 | srtmap | |
| 1285 | opmap | |
| 1286 | modmap | |
| 1287 | (car idinf)) | |
| 1288 | (cdr idinf))))) | |
| 1289 | thy))) | |
| 1290 | (t thy))) | |
| 1291 | (compute-method-theory-info-for-matching method minfo))) ; dolist | |
| 1499 | 1292 | ))) |
| 1500 | 1293 | |
| 1501 | 1294 | ;;; TERMS |
| 1508 | 1301 | ;;; *VIEW-FROM???? |
| 1509 | 1302 | (defun modmorph-recreate-term (module sortmap opmap modmap term) |
| 1510 | 1303 | (cond ((term-is-an-error term) term) |
| 1511 | ((term-is-builtin-constant? term) | |
| 1512 | (make-bconst-term (modmorph-sort-image module | |
| 1513 | sortmap | |
| 1514 | (term-sort term)) | |
| 1515 | (term-builtin-value term))) | |
| 1516 | ((term-is-lisp-form? term) term) | |
| 1517 | ((term-is-variable? term) | |
| 1518 | (when *on-modexp-debug* | |
| 1519 | (format t "~&[modmorph-recreate-term] finding variable ~a of sort ~a" | |
| 1520 | (variable-name term) | |
| 1521 | (sort-name (variable-sort term)))) | |
| 1522 | ;; the operator should always be found | |
| 1523 | (let ((var-name (variable-name term))) | |
| 1524 | (let ((img-sort (modmorph-sort-image module | |
| 1525 | sortmap | |
| 1526 | (variable-sort term)))) | |
| 1527 | (let ((val2 (find-if #'(lambda (x) | |
| 1528 | (and (equal var-name (variable-name x)) | |
| 1529 | (sort= img-sort (variable-sort x)))) | |
| 1530 | *modmorph-local-vars*))) | |
| 1531 | (if val2 | |
| 1532 | (progn (when *on-modexp-debug* | |
| 1533 | (format t "~& variable found.")) | |
| 1534 | val2) | |
| 1535 | (let ((new-var (make-variable-term img-sort var-name))) | |
| 1536 | (when *on-modexp-debug* | |
| 1537 | (format t "~& variable not found in *modmorph-local-vars*")) | |
| 1538 | (push new-var *modmorph-local-vars*) | |
| 1539 | new-var)))) | |
| 1540 | )) | |
| 1541 | (t (let ((head (term-head term)) | |
| 1542 | (new-head nil)) | |
| 1543 | ;; look in the mapping | |
| 1544 | (when *on-modexp-debug* | |
| 1545 | (format t "~&[modmorph-recreate-term]: looking for image of ") | |
| 1546 | (print-method head)) | |
| 1547 | ;; | |
| 1548 | (let ((val (assoc head opmap))) | |
| 1549 | (if val | |
| 1550 | (progn | |
| 1551 | (when *on-modexp-debug* | |
| 1552 | (format t "~% found the image in map.") | |
| 1553 | (print-chaos-object (cddr val))) | |
| 1554 | (if (eq :replacement (second val)) | |
| 1555 | (progn (setq term (apply-op-mapping module | |
| 1556 | (cdr val) | |
| 1557 | term)) | |
| 1558 | (setq new-head (term-head term))) | |
| 1559 | (setq new-head (cddr val)))) | |
| 1560 | (when *on-modexp-debug* | |
| 1561 | (format t "~& image not found in map.") | |
| 1562 | )) | |
| 1563 | (unless new-head | |
| 1564 | ;; method is not mapped | |
| 1565 | (if (method-is-error-method head) | |
| 1566 | (setq new-head | |
| 1567 | (modmorph-find-error-method module | |
| 1568 | head | |
| 1569 | opmap | |
| 1570 | sortmap)) | |
| 1571 | (let ((aval (assoc (method-module head) modmap))) | |
| 1572 | (setq new-head | |
| 1573 | (if (not aval) | |
| 1574 | head | |
| 1575 | (let ((lookmod | |
| 1576 | (if (module-p (cdr aval)) | |
| 1577 | (cdr aval) | |
| 1578 | (if (view-p (cdr aval)) | |
| 1579 | (view-target (cdr aval)) | |
| 1580 | (cdr aval))))) | |
| 1581 | (find-method-in | |
| 1582 | lookmod | |
| 1583 | (method-symbol head) | |
| 1584 | (modmorph-sorts-image lookmod | |
| 1585 | sortmap | |
| 1586 | (method-arity head)) | |
| 1587 | (modmorph-sort-image lookmod | |
| 1588 | sortmap | |
| 1589 | (method-coarity head))) | |
| 1590 | )))))) | |
| 1591 | ;; | |
| 1592 | (unless new-head | |
| 1593 | (with-output-chaos-error ('no-such-operator) | |
| 1594 | (princ "mapping image of operator: ") | |
| 1595 | (with-in-module ((method-module head)) | |
| 1596 | (print-method-internal head)) | |
| 1597 | (print-next) | |
| 1598 | (princ "of module ") | |
| 1599 | (print-chaos-object (method-module head)) | |
| 1600 | (print-next) | |
| 1601 | (princ "was not found in the module ") | |
| 1602 | (print-chaos-object module) | |
| 1603 | )) | |
| 1604 | ;; | |
| 1605 | (if (term-is-builtin-constant? term) | |
| 1606 | term | |
| 1607 | (make-term-check-op-with-sort-check | |
| 1608 | new-head | |
| 1609 | (mapcar #'(lambda (tm) | |
| 1610 | (modmorph-recreate-term module | |
| 1611 | sortmap | |
| 1612 | opmap | |
| 1613 | modmap | |
| 1614 | tm)) | |
| 1615 | (term-subterms term)) | |
| 1616 | module)) | |
| 1617 | ))))) | |
| 1304 | ((term-is-builtin-constant? term) | |
| 1305 | (make-bconst-term (modmorph-sort-image module | |
| 1306 | sortmap | |
| 1307 | (term-sort term)) | |
| 1308 | (term-builtin-value term))) | |
| 1309 | ((term-is-lisp-form? term) term) | |
| 1310 | ((term-is-variable? term) | |
| 1311 | (when *on-modexp-debug* | |
| 1312 | (format t "~%[modmorph-recreate-term] finding variable ~a of sort ~a" | |
| 1313 | (variable-name term) | |
| 1314 | (sort-name (variable-sort term)))) | |
| 1315 | ;; the operator should always be found | |
| 1316 | (let ((var-name (variable-name term))) | |
| 1317 | (let ((img-sort (modmorph-sort-image module | |
| 1318 | sortmap | |
| 1319 | (variable-sort term)))) | |
| 1320 | (let ((val2 (find-if #'(lambda (x) | |
| 1321 | (and (equal var-name (variable-name x)) | |
| 1322 | (sort= img-sort (variable-sort x)))) | |
| 1323 | *modmorph-local-vars*))) | |
| 1324 | (if val2 | |
| 1325 | (progn (when *on-modexp-debug* | |
| 1326 | (format t "~% variable found.")) | |
| 1327 | val2) | |
| 1328 | (let ((new-var (make-variable-term img-sort var-name))) | |
| 1329 | (when *on-modexp-debug* | |
| 1330 | (format t "~% variable not found in *modmorph-local-vars*")) | |
| 1331 | (push new-var *modmorph-local-vars*) | |
| 1332 | new-var)))))) | |
| 1333 | (t (let ((head (term-head term)) | |
| 1334 | (new-head nil)) | |
| 1335 | ;; look in the mapping | |
| 1336 | (when *on-modexp-debug* | |
| 1337 | (format t "~%[modmorph-recreate-term]: looking for image of ") | |
| 1338 | (print-method head)) | |
| 1339 | ;; | |
| 1340 | (let ((val (assoc head opmap))) | |
| 1341 | (if val | |
| 1342 | (progn | |
| 1343 | (when *on-modexp-debug* | |
| 1344 | (format t "~% found the image in map.") | |
| 1345 | (print-chaos-object (cddr val))) | |
| 1346 | (if (eq :replacement (second val)) | |
| 1347 | (progn (setq term (apply-op-mapping module | |
| 1348 | (cdr val) | |
| 1349 | term)) | |
| 1350 | (setq new-head (term-head term))) | |
| 1351 | (setq new-head (cddr val)))) | |
| 1352 | (when *on-modexp-debug* | |
| 1353 | (format t "~% image not found in map.") | |
| 1354 | )) | |
| 1355 | (unless new-head | |
| 1356 | ;; method is not mapped | |
| 1357 | (if (method-is-error-method head) | |
| 1358 | (setq new-head | |
| 1359 | (modmorph-find-error-method module | |
| 1360 | head | |
| 1361 | opmap | |
| 1362 | sortmap)) | |
| 1363 | (let ((aval (assoc (method-module head) modmap))) | |
| 1364 | (setq new-head | |
| 1365 | (if (not aval) | |
| 1366 | head | |
| 1367 | (let ((lookmod | |
| 1368 | (if (module-p (cdr aval)) | |
| 1369 | (cdr aval) | |
| 1370 | (if (view-p (cdr aval)) | |
| 1371 | (view-target (cdr aval)) | |
| 1372 | (cdr aval))))) | |
| 1373 | (find-method-in | |
| 1374 | lookmod | |
| 1375 | (method-symbol head) | |
| 1376 | (modmorph-sorts-image lookmod | |
| 1377 | sortmap | |
| 1378 | (method-arity head)) | |
| 1379 | (modmorph-sort-image lookmod | |
| 1380 | sortmap | |
| 1381 | (method-coarity head))))))))) | |
| 1382 | ;; | |
| 1383 | (unless new-head | |
| 1384 | (with-output-chaos-error ('no-such-operator) | |
| 1385 | (princ "mapping image of operator: ") | |
| 1386 | (with-in-module ((method-module head)) | |
| 1387 | (print-method-internal head)) | |
| 1388 | (print-next) | |
| 1389 | (princ "of module ") | |
| 1390 | (print-chaos-object (method-module head)) | |
| 1391 | (print-next) | |
| 1392 | (princ "was not found in the module ") | |
| 1393 | (print-chaos-object module) | |
| 1394 | )) | |
| 1395 | ;; | |
| 1396 | (if (term-is-builtin-constant? term) | |
| 1397 | term | |
| 1398 | (make-term-check-op-with-sort-check | |
| 1399 | new-head | |
| 1400 | (mapcar #'(lambda (tm) | |
| 1401 | (modmorph-recreate-term module | |
| 1402 | sortmap | |
| 1403 | opmap | |
| 1404 | modmap | |
| 1405 | tm)) | |
| 1406 | (term-subterms term)) | |
| 1407 | module))))))) | |
| 1618 | 1408 | |
| 1619 | 1409 | ;;; AXIOMS |
| 1620 | 1410 | |
| 1627 | 1417 | (with-in-module (module) |
| 1628 | 1418 | (let ((*modmorph-local-vars* nil)) |
| 1629 | 1419 | (make-rule :lhs (modmorph-recreate-term module |
| 1630 | sortmap | |
| 1631 | opmap | |
| 1632 | modmap | |
| 1633 | (axiom-lhs ax)) | |
| 1634 | :rhs (modmorph-recreate-term module | |
| 1635 | sortmap | |
| 1636 | opmap | |
| 1637 | modmap | |
| 1638 | (axiom-rhs ax)) | |
| 1639 | :condition (if (is-true? (axiom-condition ax)) | |
| 1640 | *bool-true* | |
| 1641 | (modmorph-recreate-term | |
| 1642 | module | |
| 1643 | sortmap | |
| 1644 | opmap | |
| 1645 | modmap | |
| 1646 | (axiom-condition ax))) | |
| 1647 | :labels (axiom-labels ax) | |
| 1648 | :behavioural (axiom-is-behavioural ax) | |
| 1649 | :type (axiom-type ax) | |
| 1650 | :kind (axiom-kind ax) | |
| 1651 | :meta-and-or (axiom-meta-and-or ax))))) | |
| 1420 | sortmap | |
| 1421 | opmap | |
| 1422 | modmap | |
| 1423 | (axiom-lhs ax)) | |
| 1424 | :rhs (modmorph-recreate-term module | |
| 1425 | sortmap | |
| 1426 | opmap | |
| 1427 | modmap | |
| 1428 | (axiom-rhs ax)) | |
| 1429 | :condition (if (is-true? (axiom-condition ax)) | |
| 1430 | *bool-true* | |
| 1431 | (modmorph-recreate-term | |
| 1432 | module | |
| 1433 | sortmap | |
| 1434 | opmap | |
| 1435 | modmap | |
| 1436 | (axiom-condition ax))) | |
| 1437 | :labels (axiom-labels ax) | |
| 1438 | :behavioural (axiom-is-behavioural ax) | |
| 1439 | :type (axiom-type ax) | |
| 1440 | :kind (axiom-kind ax) | |
| 1441 | :meta-and-or (axiom-meta-and-or ax))))) | |
| 1652 | 1442 | |
| 1653 | 1443 | ;;; ******************* |
| 1654 | 1444 | ;;; MISC MODMORPH UTILS_________________________________________________________ |
| 1660 | 1450 | |
| 1661 | 1451 | (defun modmorph-merge (m1 m2 &optional (warn t)) |
| 1662 | 1452 | (let ((nm1 (modmorph-name m1)) |
| 1663 | (nm2 (modmorph-name m2))) | |
| 1453 | (nm2 (modmorph-name m2))) | |
| 1664 | 1454 | (create-modmorph |
| 1665 | 1455 | ;; name will need to be used for memoization |
| 1666 | 1456 | ;; the assumption here is that basic mappings have names like: |
| 1667 | 1457 | ;; (map th vw) |
| 1668 | 1458 | ;; and that other names are create by this routine |
| 1669 | 1459 | (append (if (atom (car nm1)) (list nm1) nm1) |
| 1670 | (if (atom (car nm2)) (list nm2) nm2)) | |
| 1460 | (if (atom (car nm2)) (list nm2) nm2)) | |
| 1671 | 1461 | (modmorph-merge-assoc (modmorph-sort m1) (modmorph-sort m2) warn) |
| 1672 | 1462 | (modmorph-merge-op-assoc (modmorph-op m1) (modmorph-op m2) warn) |
| 1673 | (modmorph-merge-assoc (modmorph-module m1) (modmorph-module m2) warn)) | |
| 1674 | )) | |
| 1463 | (modmorph-merge-assoc (modmorph-module m1) (modmorph-module m2) warn)))) | |
| 1675 | 1464 | |
| 1676 | 1465 | (defun modmorph-merge-assoc (a1 a2 &optional warn) |
| 1677 | 1466 | (let ((res a2)) |
| 1678 | 1467 | (dolist (m a1) |
| 1679 | 1468 | (let ((im (assq (car m) a2))) |
| 1680 | (if (and im | |
| 1681 | (not (eq (car m) (cdr m)))) | |
| 1682 | (progn | |
| 1683 | (unless (eq (cdr im) (cdr m)) | |
| 1684 | (when warn | |
| 1685 | (with-output-chaos-warning () | |
| 1686 | (princ "instantiating module, ") | |
| 1687 | (print-next) | |
| 1688 | (princ "combined view has inconsistent mappings for: ") | |
| 1689 | (let ((*print-indent* (+ *print-indent* 2))) | |
| 1690 | (print-next) | |
| 1691 | (print-chaos-object (car m))) | |
| 1692 | (print-next) | |
| 1693 | (princ "target images are: ") | |
| 1694 | (let ((*print-indent* (+ *print-indent* 2))) | |
| 1695 | (print-next) | |
| 1696 | (print-chaos-object (cdr m)) | |
| 1697 | (print-next) | |
| 1698 | (print-chaos-object (cdr im))) | |
| 1699 | ))) | |
| 1700 | ;; (push (cons (car m) (cdr im)) res) | |
| 1701 | ) | |
| 1702 | (push m res)) | |
| 1703 | )) | |
| 1704 | res | |
| 1705 | )) | |
| 1469 | (if (and im | |
| 1470 | (not (eq (car m) (cdr m)))) | |
| 1471 | (progn | |
| 1472 | (unless (eq (cdr im) (cdr m)) | |
| 1473 | (when warn | |
| 1474 | (with-output-chaos-warning () | |
| 1475 | (princ "instantiating module, ") | |
| 1476 | (print-next) | |
| 1477 | (princ "combined view has inconsistent mappings for: ") | |
| 1478 | (let ((*print-indent* (+ *print-indent* 2))) | |
| 1479 | (print-next) | |
| 1480 | (print-chaos-object (car m))) | |
| 1481 | (print-next) | |
| 1482 | (princ "target images are: ") | |
| 1483 | (let ((*print-indent* (+ *print-indent* 2))) | |
| 1484 | (print-next) | |
| 1485 | (print-chaos-object (cdr m)) | |
| 1486 | (print-next) | |
| 1487 | (print-chaos-object (cdr im))) | |
| 1488 | )))) | |
| 1489 | (push m res)))) | |
| 1490 | res)) | |
| 1706 | 1491 | |
| 1707 | 1492 | (defun modmorph-op-map-is-ident (map) |
| 1708 | 1493 | (if (eq :simple-map (second map)) |
| 1710 | 1495 | (eq (first map) (third map)) |
| 1711 | 1496 | ;; map := (term :replacement vars term) |
| 1712 | 1497 | (eq (first map) |
| 1713 | (term-head (fourth map))))) | |
| 1498 | (term-head (fourth map))))) | |
| 1714 | 1499 | |
| 1715 | 1500 | (defun modmorph-merge-op-assoc (a1 a2 &optional warn) |
| 1716 | 1501 | (let ((res a2)) |
| 1717 | 1502 | (dolist (m a1) |
| 1718 | 1503 | (let ((im (assq (car m) a2))) |
| 1719 | (if (and im | |
| 1720 | (not (modmorph-op-map-is-ident m))) | |
| 1721 | (progn | |
| 1722 | (unless (modmorph-same-op-image (cdr m) (cdr im)) | |
| 1723 | (when warn | |
| 1724 | (with-output-chaos-warning () | |
| 1725 | (princ "instantiating module,") | |
| 1726 | (print-next) | |
| 1727 | (princ "combined view has inconsistent mappings for operator: ") | |
| 1728 | (let ((*print-indent* (+ *print-indent* 2))) | |
| 1729 | (print-next) | |
| 1730 | (print-chaos-object (car m))) | |
| 1731 | (print-next) | |
| 1732 | (princ "images are: ") | |
| 1733 | (let ((*print-indent* (+ *print-indent* 2))) | |
| 1734 | (if (eq (cadr m) :replacement) | |
| 1735 | (progn | |
| 1736 | (print-next) | |
| 1737 | (print-chaos-object (cadddr m)) | |
| 1738 | (print-next) | |
| 1739 | (print-chaos-object (cadddr im))) | |
| 1740 | (progn | |
| 1741 | (print-next) | |
| 1742 | (print-chaos-object (caddr m)) | |
| 1743 | (print-next) | |
| 1744 | (print-chaos-object (caddr m))))) | |
| 1745 | ))) | |
| 1746 | ;; (push (cons (car m) (cdr im)) res) | |
| 1747 | ) | |
| 1748 | (push m res)) | |
| 1749 | )) | |
| 1750 | res | |
| 1751 | )) | |
| 1504 | (if (and im | |
| 1505 | (not (modmorph-op-map-is-ident m))) | |
| 1506 | (progn | |
| 1507 | (unless (modmorph-same-op-image (cdr m) (cdr im)) | |
| 1508 | (when warn | |
| 1509 | (with-output-chaos-warning () | |
| 1510 | (princ "instantiating module,") | |
| 1511 | (print-next) | |
| 1512 | (princ "combined view has inconsistent mappings for operator: ") | |
| 1513 | (let ((*print-indent* (+ *print-indent* 2))) | |
| 1514 | (print-next) | |
| 1515 | (print-chaos-object (car m))) | |
| 1516 | (print-next) | |
| 1517 | (princ "images are: ") | |
| 1518 | (let ((*print-indent* (+ *print-indent* 2))) | |
| 1519 | (if (eq (cadr m) :replacement) | |
| 1520 | (progn | |
| 1521 | (print-next) | |
| 1522 | (print-chaos-object (cadddr m)) | |
| 1523 | (print-next) | |
| 1524 | (print-chaos-object (cadddr im))) | |
| 1525 | (progn | |
| 1526 | (print-next) | |
| 1527 | (print-chaos-object (caddr m)) | |
| 1528 | (print-next) | |
| 1529 | (print-chaos-object (caddr m))))) | |
| 1530 | )))) | |
| 1531 | (push m res)))) | |
| 1532 | res)) | |
| 1752 | 1533 | |
| 1753 | 1534 | ;; im1 & im2 are of the form |
| 1754 | 1535 | ;;; (:simple-map . method) -- or -- |
| 1757 | 1538 | (defun modmorph-same-op-image (im1 im2) |
| 1758 | 1539 | (if (and (consp im1) (eq :simple-map (car im1))) |
| 1759 | 1540 | (or (eq (cdr im1) (cdr im2)) |
| 1760 | (and (equal (method-name (cdr im1)) | |
| 1761 | (method-name (cdr im2))) | |
| 1762 | (sort= (method-coarity (cdr im1)) | |
| 1763 | *sort-id-sort*))) | |
| 1541 | (and (equal (method-name (cdr im1)) | |
| 1542 | (method-name (cdr im2))) | |
| 1543 | (sort= (method-coarity (cdr im1)) | |
| 1544 | *sort-id-sort*))) | |
| 1764 | 1545 | ;; |
| 1765 | 1546 | (if (and (consp im1) (eq :replacement (car im1))) |
| 1766 | (if (sort= (term-sort (caddr im1)) *sort-id-sort*) | |
| 1767 | (and (sort= (term-sort (caddr im2)) *sort-id-sort*) | |
| 1768 | (equal (method-name (term-head (caddr im1))) | |
| 1769 | (method-name (term-head (caddr im2))))) | |
| 1770 | (term-equational-equal (caddr im1) (caddr im2)))))) | |
| 1547 | (if (sort= (term-sort (caddr im1)) *sort-id-sort*) | |
| 1548 | (and (sort= (term-sort (caddr im2)) *sort-id-sort*) | |
| 1549 | (equal (method-name (term-head (caddr im1))) | |
| 1550 | (method-name (term-head (caddr im2))))) | |
| 1551 | (term-equational-equal (caddr im1) (caddr im2)))))) | |
| 1771 | 1552 | |
| 1772 | 1553 | ;;; op modmorph-find-sort-in : Module Sort-Name -> Sort |
| 1773 | 1554 | ;;; |
| 1774 | 1555 | (defun modmorph-find-sort-in (module sort-name) |
| 1775 | 1556 | (or (find sort-name (module-all-sorts module) |
| 1776 | :test #'(lambda (n s) | |
| 1777 | (and (equal n (sort-id s)) | |
| 1778 | (eq module (sort-module s))))) | |
| 1557 | :test #'(lambda (n s) | |
| 1558 | (and (equal n (sort-id s)) | |
| 1559 | (eq module (sort-module s))))) | |
| 1779 | 1560 | nil)) |
| 1780 | 1561 | |
| 1781 | 1562 | ;;; |
| 1782 | 1563 | ;;; |
| 1783 | 1564 | (defun modmorph-find-operator-named-in (module op-symbol) |
| 1784 | 1565 | (let ((res1 (find-if #'(lambda (opinfo) |
| 1785 | (let ((op (opinfo-operator opinfo))) | |
| 1786 | (or (equal op-symbol (operator-symbol op)) | |
| 1787 | (and (eq module (operator-module op)) | |
| 1788 | (if (atom op-symbol) | |
| 1789 | (equal op-symbol (car (operator-symbol op))) | |
| 1790 | (and (null (cdr op-symbol)) | |
| 1791 | (equal (car op-symbol) | |
| 1792 | (car (operator-symbol op))))))))) | |
| 1566 | (let ((op (opinfo-operator opinfo))) | |
| 1567 | (or (equal op-symbol (operator-symbol op)) | |
| 1568 | (and (eq module (operator-module op)) | |
| 1569 | (if (atom op-symbol) | |
| 1570 | (equal op-symbol (car (operator-symbol op))) | |
| 1571 | (and (null (cdr op-symbol)) | |
| 1572 | (equal (car op-symbol) | |
| 1573 | (car (operator-symbol op))))))))) | |
| 1793 | 1574 | (module-all-operators module)))) |
| 1794 | 1575 | (or res1 |
| 1795 | (dolist (srt (module-all-sorts module) nil) | |
| 1796 | (if (sort-is-builtin srt) | |
| 1797 | (let ((res (find-builtin-method-in module srt op-symbol))) | |
| 1798 | (if res (return res))))) | |
| 1799 | ))) | |
| 1576 | (dolist (srt (module-all-sorts module) nil) | |
| 1577 | (if (sort-is-builtin srt) | |
| 1578 | (let ((res (find-builtin-method-in module srt op-symbol))) | |
| 1579 | (if res (return res))))) | |
| 1580 | ))) | |
| 1800 | 1581 | |
| 1801 | 1582 | ;;; APPLY-OP-MAPPING : module op-mapping term -> term |
| 1802 | 1583 | ;;; |
| 1806 | 1587 | (defun apply-op-mapping (module op-mapping term) |
| 1807 | 1588 | (if (eq :simple-map (car op-mapping)) |
| 1808 | 1589 | (make-term-check-op-with-sort-check (cdr op-mapping) |
| 1809 | (term-subterms term)) | |
| 1590 | (term-subterms term)) | |
| 1810 | 1591 | (mapping-image (term-subterms term) (caddr op-mapping) module) |
| 1811 | ;caddr = dst-pattern | |
| 1592 | ;caddr = dst-pattern | |
| 1812 | 1593 | )) |
| 1813 | 1594 | |
| 1814 | 1595 | ;;; APPLY-OP-MAP |
| 1816 | 1597 | (defun apply-op-map (module op-map term) |
| 1817 | 1598 | (let ((val (assoc (term-head term) op-map))) |
| 1818 | 1599 | (if val |
| 1819 | (apply-op-mapping module (cdr val) term) | |
| 1820 | term))) | |
| 1600 | (apply-op-mapping module (cdr val) term) | |
| 1601 | term))) | |
| 1821 | 1602 | |
| 1822 | 1603 | ;;; MAPPING-IMAGE: |
| 1823 | 1604 | ;;; variables occuring in term are assumed to have numbers as names |
| 1826 | 1607 | ;;; |
| 1827 | 1608 | (defvar .mapping-debug. nil) |
| 1828 | 1609 | |
| 1829 | (defun mapping-image (term-list term &optional (module (or *current-module* | |
| 1830 | *last-module*))) | |
| 1610 | (defun mapping-image (term-list term &optional (module (get-context-module))) | |
| 1831 | 1611 | (when .mapping-debug. |
| 1832 | (format t "~&[mapping-image] term = ") | |
| 1612 | (format t "~%[mapping-image] term = ") | |
| 1833 | 1613 | (print-chaos-object term) |
| 1834 | 1614 | (format t "~% term-list = ") |
| 1835 | 1615 | (print-chaos-object term-list)) |
| 1836 | 1616 | (cond ((term-is-variable? term) |
| 1837 | (let ((nm (variable-name term))) | |
| 1838 | (if (integerp nm) (nth nm term-list) | |
| 1839 | (with-output-panic-message () | |
| 1840 | (princ "mapping-image: illegal variable") | |
| 1841 | (print-next) | |
| 1842 | (princ "var: ") (print-chaos-object term) | |
| 1843 | (chaos-error 'panic))))) | |
| 1844 | ((term-is-constant? term) term) | |
| 1845 | (t (make-term-check-op-with-sort-check | |
| 1846 | (term-head term) | |
| 1847 | (mapcar #'(lambda (st) (mapping-image term-list st)) | |
| 1848 | (term-subterms term)) | |
| 1849 | module) | |
| 1850 | ))) | |
| 1617 | (let ((nm (variable-name term))) | |
| 1618 | (if (integerp nm) (nth nm term-list) | |
| 1619 | (with-output-panic-message () | |
| 1620 | (princ "mapping-image: illegal variable") | |
| 1621 | (print-next) | |
| 1622 | (princ "var: ") (print-chaos-object term) | |
| 1623 | (chaos-error 'panic))))) | |
| 1624 | ((term-is-constant? term) term) | |
| 1625 | (t (make-term-check-op-with-sort-check | |
| 1626 | (term-head term) | |
| 1627 | (mapcar #'(lambda (st) (mapping-image term-list st)) | |
| 1628 | (term-subterms term)) | |
| 1629 | module)))) | |
| 1851 | 1630 | |
| 1852 | 1631 | (defun mapping-image-2 (map term_list term) |
| 1853 | 1632 | (cond ((term-is-variable? term) |
| 1854 | (let ((nm (variable-name term))) | |
| 1855 | (if (integerp nm) (nth nm term_list) | |
| 1856 | (with-output-panic-message () | |
| 1857 | (princ "mapping-image2: illegal variable") | |
| 1858 | (print-next) | |
| 1859 | (princ "var: ") (print-chaos-object term) | |
| 1860 | (chaos-error 'panic))))) | |
| 1861 | ((term-is-constant? term) term) | |
| 1862 | (t (let* ((op (term-head term)) | |
| 1863 | (om (method-module op)) | |
| 1864 | (as (or (cdr (assoc om (modmorph-module map))) | |
| 1865 | om))) | |
| 1866 | (when (and (not (eq as om)) | |
| 1867 | (module-p as)) | |
| 1868 | (setq op (find-method-in as ; was (cdr as). | |
| 1869 | (method-symbol op) | |
| 1870 | (modmorph-sorts-image as ; (cdr as) | |
| 1871 | (modmorph-sort map) | |
| 1872 | (method-arity op)) | |
| 1873 | (modmorph-sort-image as ; (cdr as) | |
| 1874 | (modmorph-sort map) | |
| 1875 | (method-coarity op))))) | |
| 1876 | (unless op | |
| 1877 | (with-output-panic-message () | |
| 1878 | (format t "mapping term image, could not find operator image:") | |
| 1879 | (print-method (term-head term)) | |
| 1880 | (chaos-error 'panic))) | |
| 1881 | (make-term-check-op-with-sort-check op | |
| 1882 | (mapcar #'(lambda (st) | |
| 1883 | (mapping-image-2 | |
| 1884 | map term_list | |
| 1885 | st)) | |
| 1886 | (term-subterms term)) | |
| 1887 | (if (module-p as) | |
| 1888 | as | |
| 1889 | om)) | |
| 1890 | )))) | |
| 1633 | (let ((nm (variable-name term))) | |
| 1634 | (if (integerp nm) (nth nm term_list) | |
| 1635 | (with-output-panic-message () | |
| 1636 | (princ "mapping-image2: illegal variable") | |
| 1637 | (print-next) | |
| 1638 | (princ "var: ") (print-chaos-object term) | |
| 1639 | (chaos-error 'panic))))) | |
| 1640 | ((term-is-constant? term) term) | |
| 1641 | (t (let* ((op (term-head term)) | |
| 1642 | (om (method-module op)) | |
| 1643 | (as (or (cdr (assoc om (modmorph-module map))) | |
| 1644 | om))) | |
| 1645 | (when (and (not (eq as om)) | |
| 1646 | (module-p as)) | |
| 1647 | (setq op (find-method-in as ; was (cdr as). | |
| 1648 | (method-symbol op) | |
| 1649 | (modmorph-sorts-image as ; (cdr as) | |
| 1650 | (modmorph-sort map) | |
| 1651 | (method-arity op)) | |
| 1652 | (modmorph-sort-image as ; (cdr as) | |
| 1653 | (modmorph-sort map) | |
| 1654 | (method-coarity op))))) | |
| 1655 | (unless op | |
| 1656 | (with-output-panic-message () | |
| 1657 | (format t "mapping term image, could not find operator image:") | |
| 1658 | (print-method (term-head term)) | |
| 1659 | (chaos-error 'panic))) | |
| 1660 | (make-term-check-op-with-sort-check op | |
| 1661 | (mapcar #'(lambda (st) | |
| 1662 | (mapping-image-2 | |
| 1663 | map term_list | |
| 1664 | st)) | |
| 1665 | (term-subterms term)) | |
| 1666 | (if (module-p as) | |
| 1667 | as | |
| 1668 | om)))))) | |
| 1891 | 1669 | |
| 1892 | 1670 | ;;; |
| 1893 | 1671 | (defun view-get-image-of-axioms (view) |
| 1894 | 1672 | (let* ((source (view-source view)) |
| 1895 | (target (view-target view)) | |
| 1896 | (morph (convert-view-to-modmorph source | |
| 1897 | view))) | |
| 1673 | (target (view-target view)) | |
| 1674 | (morph (convert-view-to-modmorph source | |
| 1675 | view))) | |
| 1898 | 1676 | (modmorph-get-image-of-axioms morph source target))) |
| 1899 | ||
| 1677 | ||
| 1900 | 1678 | (defun modmorph-get-image-of-axioms (morph source target) |
| 1901 | 1679 | (let ((sort-map (modmorph-sort morph)) |
| 1902 | (op-map (modmorph-op morph)) | |
| 1903 | (mod-map (modmorph-module morph)) | |
| 1904 | (all-axioms (get-module-axioms target)) | |
| 1905 | (axs nil)) | |
| 1680 | (op-map (modmorph-op morph)) | |
| 1681 | (mod-map (modmorph-module morph)) | |
| 1682 | (all-axioms (get-module-axioms target)) | |
| 1683 | (axs nil)) | |
| 1906 | 1684 | (dolist (ax (get-module-axioms source)) |
| 1907 | 1685 | (let ((ax-image (modmorph-recreate-axiom target sort-map op-map mod-map ax))) |
| 1908 | (unless (member ax-image all-axioms :test #'rule-is-similar?) | |
| 1909 | (push ax-image axs)))) | |
| 1686 | (unless (member ax-image all-axioms :test #'rule-is-similar?) | |
| 1687 | (push ax-image axs)))) | |
| 1910 | 1688 | (nreverse axs))) |
| 1911 | 1689 | |
| 1912 | 1690 | ;;; EOF |
| 0 | 0 | ;;;-*- Mode:LISP; Package:CHAOS; Base:10; Syntax:Common-lisp -*- |
| 1 | 1 | ;;; |
| 2 | ;;; Copyright (c) 2000-2014, Toshimi Sawada. All rights reserved. | |
| 2 | ;;; Copyright (c) 2000-2015, Toshimi Sawada. All rights reserved. | |
| 3 | 3 | ;;; |
| 4 | 4 | ;;; Redistribution and use in source and binary forms, with or without |
| 5 | 5 | ;;; modification, are permitted provided that the following conditions |
| 27 | 27 | ;;; |
| 28 | 28 | (in-package :chaos) |
| 29 | 29 | #|============================================================================== |
| 30 | System: CHAOS | |
| 31 | Module: deCafe | |
| 32 | File: modmorph.lisp | |
| 30 | System: CHAOS | |
| 31 | Module: deCafe | |
| 32 | File: modmorph.lisp | |
| 33 | 33 | ==============================================================================|# |
| 34 | 34 | #-:chaos-debug |
| 35 | 35 | (declaim (optimize (speed 3) (safety 0) #-GCL (debug 0))) |
| 59 | 59 | (defun apply-modmorph (name morph mod) |
| 60 | 60 | (let ((newmod (cdr (assq mod (modmorph-module morph))))) |
| 61 | 61 | (if newmod |
| 62 | ;; given mod already mapped, change its name by given one. | |
| 63 | (setf (module-name newmod) name) | |
| 64 | (progn | |
| 65 | ;; construct new module using given name. | |
| 66 | (setq newmod (or *modmorph-new-module* | |
| 67 | (!create-module name))) | |
| 68 | ;; register module map. | |
| 69 | (push (cons mod newmod) (modmorph-module morph)))) | |
| 62 | ;; given mod already mapped, change its name by given one. | |
| 63 | (setf (module-name newmod) name) | |
| 64 | (progn | |
| 65 | ;; construct new module using given name. | |
| 66 | (setq newmod (or *modmorph-new-module* | |
| 67 | (!create-module name))) | |
| 68 | ;; register module map. | |
| 69 | (push (cons mod newmod) (modmorph-module morph)))) | |
| 70 | 70 | ;; apply the morphism |
| 71 | 71 | (with-in-module (newmod) |
| 72 | 72 | (apply-modmorph-internal morph mod newmod)))) |
| 78 | 78 | (defun apply-modmorph* (nm morph mod) |
| 79 | 79 | (let ((newmod (cdr (assq mod (modmorph-module morph))))) |
| 80 | 80 | (if newmod |
| 81 | (setf (module-name newmod) nm) | |
| 82 | (progn | |
| 83 | (setq newmod (create-module nm)) | |
| 84 | (push (cons mod newmod) (modmorph-module morph)))) | |
| 81 | (setf (module-name newmod) nm) | |
| 82 | (progn | |
| 83 | (setq newmod (create-module nm)) | |
| 84 | (push (cons mod newmod) (modmorph-module morph)))) | |
| 85 | 85 | (apply-modmorph-internal morph mod newmod))) |
| 86 | 86 | |
| 87 | 87 | ;;;----------------------------------------------------------------------------- |
| 94 | 94 | |
| 95 | 95 | (defun apply-modmorph-internal (map mod newmod) |
| 96 | 96 | (flet ((inherit-principal-sort (s s-mapped) |
| 97 | (when (and (null (module-principal-sort newmod)) | |
| 98 | (sort= s (module-principal-sort mod))) | |
| 99 | ;; this will be evaluated later on compilation stage. | |
| 100 | (setf (module-psort-declaration newmod) | |
| 101 | (%psort-decl* s-mapped)) | |
| 102 | ;; the following seems redundant, but there are | |
| 103 | ;; some cases the real module compilation is not done | |
| 104 | ;; while evaluating modexprs, and we also want | |
| 105 | ;; psort-declaration for consistency. | |
| 106 | (setf (module-principal-sort newmod) s-mapped) | |
| 107 | )) | |
| 108 | ) | |
| 97 | (when (and (null (module-principal-sort newmod)) | |
| 98 | (sort= s (module-principal-sort mod))) | |
| 99 | ;; this will be evaluated later on compilation stage. | |
| 100 | (setf (module-psort-declaration newmod) | |
| 101 | (%psort-decl* s-mapped)) | |
| 102 | ;; the following seems redundant, but there are | |
| 103 | ;; some cases the real module compilation is not done | |
| 104 | ;; while evaluating modexprs, and we also want | |
| 105 | ;; psort-declaration for consistency. | |
| 106 | (setf (module-principal-sort newmod) s-mapped) | |
| 107 | )) | |
| 108 | ) | |
| 109 | 109 | ;; |
| 110 | (when *chaos-verbose* (princ "[")) ; now we begin. | |
| 110 | (when *chaos-verbose* (princ "[")) ; now we begin. | |
| 111 | 111 | (when *on-modexp-debug* |
| 112 | 112 | (with-output-simple-msg () |
| 113 | (format t "[apply-modmorph] : begin ----------------------------") | |
| 114 | (format t "~&- map = ") | |
| 115 | (print-mapping map) | |
| 116 | (format t "~& - module = ") | |
| 117 | (print-modexp mod) | |
| 118 | (format t "~& - new module = ") | |
| 119 | (print-modexp newmod))) | |
| 113 | (format t "[apply-modmorph] : begin ----------------------------") | |
| 114 | (format t "~&- map = ") | |
| 115 | (print-mapping map) | |
| 116 | (format t "~& - module = ") | |
| 117 | (print-modexp mod) | |
| 118 | (format t "~& - new module = ") | |
| 119 | (print-modexp newmod))) | |
| 120 | 120 | ;; |
| 121 | 121 | (let ((amod (assq mod (modmorph-module map)))) |
| 122 | 122 | ;; newmod is depends on mod, so we set dependency relation. |
| 125 | 125 | |
| 126 | 126 | ;; update module map mod->newmod |
| 127 | 127 | (if amod |
| 128 | (when (null (cdr amod)) (rplacd amod newmod)) | |
| 129 | (push (cons mod newmod) (modmorph-module map))) | |
| 128 | (when (null (cdr amod)) (rplacd amod newmod)) | |
| 129 | (push (cons mod newmod) (modmorph-module map))) | |
| 130 | 130 | |
| 131 | 131 | ;; this makes temporaly generated module for remaing trash away. |
| 132 | 132 | (when (modmorph-is-rename map) |
| 133 | (reduce-rename-dummy map mod newmod) | |
| 134 | (print-in-progress ",")) | |
| 133 | (reduce-rename-dummy map mod newmod) | |
| 134 | (print-in-progress ",")) | |
| 135 | 135 | |
| 136 | 136 | ;; now finished simple preparation, we begin the real work. |
| 137 | 137 | ;; |
| 138 | 138 | (let ((sortmap (modmorph-sort map)) |
| 139 | (opmap (modmorph-op map)) | |
| 140 | (modmap (modmorph-module map)) | |
| 141 | (no-error-sort nil)) | |
| 142 | ||
| 143 | ;; MAP SUBMODULES ----------------------------------------------------- | |
| 144 | ;; the first big job is to incorporate submodules. | |
| 145 | ;; * need to consider sub-module-instantiation | |
| 146 | ;; also apply mapping; want to memoize appropriately; | |
| 147 | ;; in some sense must always apply the mapping to sub-objects | |
| 148 | ;; * idea: if sub-module contains parameter as its sub-module then | |
| 149 | ;; map it (should always be directly there); the other source | |
| 150 | ;; of information is the name of the module; if is instantiated | |
| 151 | ;; then can see if the name contains a use of the parameter | |
| 152 | ||
| 153 | (modmorph-import-submodules mod newmod map mod) | |
| 154 | (print-in-progress ",") | |
| 139 | (opmap (modmorph-op map)) | |
| 140 | (modmap (modmorph-module map)) | |
| 141 | (no-error-sort nil)) | |
| 142 | ||
| 143 | ;; MAP SUBMODULES ----------------------------------------------------- | |
| 144 | ;; the first big job is to incorporate submodules. | |
| 145 | ;; * need to consider sub-module-instantiation | |
| 146 | ;; also apply mapping; want to memoize appropriately; | |
| 147 | ;; in some sense must always apply the mapping to sub-objects | |
| 148 | ;; * idea: if sub-module contains parameter as its sub-module then | |
| 149 | ;; map it (should always be directly there); the other source | |
| 150 | ;; of information is the name of the module; if is instantiated | |
| 151 | ;; then can see if the name contains a use of the parameter | |
| 152 | ||
| 153 | (modmorph-import-submodules mod newmod map mod) | |
| 154 | (print-in-progress ",") | |
| 155 | 155 | |
| 156 | ;; at this point have already got a lot of sorts and operators (etc.) | |
| 157 | ;; from the incorporated modules | |
| 158 | ||
| 159 | ;; after have created sub-modules need to "fix" renaming | |
| 160 | (when (modmorph-is-rename map) (fix-sort-renaming map newmod)) | |
| 161 | (print-in-progress ",") | |
| 156 | ;; at this point have already got a lot of sorts and operators (etc.) | |
| 157 | ;; from the incorporated modules | |
| 158 | ||
| 159 | ;; after have created sub-modules need to "fix" renaming | |
| 160 | (when (modmorph-is-rename map) (fix-sort-renaming map newmod)) | |
| 161 | (print-in-progress ",") | |
| 162 | 162 | |
| 163 | ;; now, maps may have been updated, so re-new the local cache. | |
| 164 | (setq sortmap (modmorph-sort map)) | |
| 165 | (setq opmap (modmorph-op map)) | |
| 166 | (setq modmap (modmorph-module map)) | |
| 167 | ||
| 168 | ;; MAP SORTS, SORT RELATIONS ---------------------------------------- | |
| 169 | ;; | |
| 170 | ;; mapping sorts | |
| 171 | (dolist (x (reverse (module-all-sorts mod))) | |
| 172 | (unless (sort-is-for-regularity? x mod) | |
| 173 | ;; reverse because want to preserve the original order | |
| 174 | (let ((sortmapval (assoc x sortmap))) | |
| 175 | (if sortmapval | |
| 176 | (let ((ims (cdr sortmapval))) | |
| 177 | (inherit-principal-sort x ims) | |
| 178 | (unless (memq ims (module-all-sorts newmod)) | |
| 179 | (add-sort-to-module ims newmod))) ; check sort order | |
| 180 | ;; | |
| 181 | (if (eq mod (sort-module x)) | |
| 182 | (let ((sortim (modmorph-recreate-sort newmod | |
| 183 | modmap | |
| 184 | sortmap | |
| 185 | x))) | |
| 186 | (inherit-principal-sort x sortim) | |
| 187 | (unless (eq x sortim) | |
| 188 | (push (cons x sortim) sortmap) | |
| 189 | (setf (modmorph-sort map) sortmap) | |
| 190 | (setq x sortim)) | |
| 191 | (add-sort-to-module sortim newmod)) | |
| 192 | ;; | |
| 193 | (let ((modv (assq (sort-module x) modmap))) | |
| 194 | (if modv | |
| 195 | (let ((sortim (modmorph-recreate-sort newmod | |
| 196 | modmap | |
| 197 | sortmap | |
| 198 | x))) | |
| 199 | (inherit-principal-sort x sortim) | |
| 200 | (unless (eq x sortim) | |
| 201 | (push (cons x sortim) sortmap) | |
| 202 | (setf (modmorph-sort map) sortmap)) | |
| 203 | ) | |
| 204 | (inherit-principal-sort x x)) | |
| 205 | ))) | |
| 206 | ))) | |
| 207 | ;; | |
| 208 | (if *chaos-verbose* | |
| 209 | (print-in-progress "s") ; done mapping sorts | |
| 210 | (print-in-progress ",")) | |
| 163 | ;; now, maps may have been updated, so re-new the local cache. | |
| 164 | (setq sortmap (modmorph-sort map)) | |
| 165 | (setq opmap (modmorph-op map)) | |
| 166 | (setq modmap (modmorph-module map)) | |
| 167 | ||
| 168 | ;; MAP SORTS, SORT RELATIONS ---------------------------------------- | |
| 169 | ;; | |
| 170 | ;; mapping sorts | |
| 171 | (dolist (x (reverse (module-all-sorts mod))) | |
| 172 | (unless (sort-is-for-regularity? x mod) | |
| 173 | ;; reverse because want to preserve the original order | |
| 174 | (let ((sortmapval (assoc x sortmap))) | |
| 175 | (if sortmapval | |
| 176 | (let ((ims (cdr sortmapval))) | |
| 177 | (inherit-principal-sort x ims) | |
| 178 | (unless (memq ims (module-all-sorts newmod)) | |
| 179 | (add-sort-to-module ims newmod))) ; check sort order | |
| 180 | ;; | |
| 181 | (if (eq mod (sort-module x)) | |
| 182 | (let ((sortim (modmorph-recreate-sort newmod | |
| 183 | modmap | |
| 184 | sortmap | |
| 185 | x))) | |
| 186 | (inherit-principal-sort x sortim) | |
| 187 | (unless (eq x sortim) | |
| 188 | (push (cons x sortim) sortmap) | |
| 189 | (setf (modmorph-sort map) sortmap) | |
| 190 | (setq x sortim)) | |
| 191 | (add-sort-to-module sortim newmod)) | |
| 192 | ;; | |
| 193 | (let ((modv (assq (sort-module x) modmap))) | |
| 194 | (if modv | |
| 195 | (let ((sortim (modmorph-recreate-sort newmod | |
| 196 | modmap | |
| 197 | sortmap | |
| 198 | x))) | |
| 199 | (inherit-principal-sort x sortim) | |
| 200 | (unless (eq x sortim) | |
| 201 | (push (cons x sortim) sortmap) | |
| 202 | (setf (modmorph-sort map) sortmap)) | |
| 203 | ) | |
| 204 | (inherit-principal-sort x x)) | |
| 205 | ))) | |
| 206 | ))) | |
| 207 | ;; | |
| 208 | (if *chaos-verbose* | |
| 209 | (print-in-progress "s") ; done mapping sorts | |
| 210 | (print-in-progress ",")) | |
| 211 | 211 | |
| 212 | ;; sort-relation | |
| 213 | (let ((self-rel (modmorph-recreate-sort-relations newmod | |
| 214 | mod | |
| 215 | modmap | |
| 216 | sortmap | |
| 217 | (module-sort-relations | |
| 218 | newmod)))) | |
| 219 | (setf (module-sort-relations newmod) | |
| 220 | (modmorph-merge-sort-relations | |
| 221 | (modmorph-recreate-sort-relations newmod mod modmap sortmap | |
| 222 | (module-sort-relations mod)) | |
| 223 | self-rel))) | |
| 224 | (let ((so (module-sort-order newmod))) | |
| 225 | (dolist (sl (module-sort-relations newmod)) | |
| 226 | (add-relation-to-order (copy-sort-relation sl) so)) | |
| 227 | ;; we need error sorts | |
| 228 | (when *on-modexp-debug* | |
| 229 | (with-output-msg () | |
| 230 | (format t " generating error sorts"))) | |
| 231 | (generate-err-sorts so) | |
| 232 | (setq no-error-sort t) | |
| 233 | ) | |
| 234 | ;; | |
| 235 | (if *chaos-verbose* | |
| 236 | (print-in-progress "<") ; done mapping sort relations | |
| 237 | (print-in-progress ",")) | |
| 238 | ||
| 239 | ;; MAP OPERATORS ---------------------------------------------------- | |
| 240 | ;; | |
| 241 | (when (modmorph-is-rename map) | |
| 242 | ;; operators | |
| 243 | ;; after have created sub-modules need to "fix" renaming for | |
| 244 | ;; operators too. | |
| 245 | (when *on-modexp-debug* | |
| 246 | (with-output-msg () | |
| 247 | (format t " fixing operator renaming .."))) | |
| 248 | (fix-method-renaming map newmod)) | |
| 249 | ;; | |
| 250 | (dolist (opinfo (reverse (module-all-operators mod))) | |
| 251 | ;; want to preserve the original order of operators | |
| 252 | (dolist (method (opinfo-methods opinfo)) | |
| 253 | (when (or ;; (method-is-user-defined-error-method method) | |
| 254 | (and (not (method-is-error-method method)) | |
| 255 | (not (memq method | |
| 256 | (module-methods-for-regularity mod))))) | |
| 257 | (unless (assq method opmap) | |
| 258 | (modmorph-recreate-method mod newmod sortmap method)) | |
| 259 | ))) | |
| 260 | ;; | |
| 261 | (if *chaos-verbose* | |
| 262 | (print-in-progress "o") ; done mapping operators | |
| 263 | (print-in-progress ",")) | |
| 264 | ||
| 265 | ;; At this point all operators should exist; term recreation is possible. | |
| 266 | ;; all of the error sorts & error method should be | |
| 267 | ;; generated here. | |
| 268 | (modmorph-prepare-for-parsing newmod map no-error-sort) | |
| 269 | ||
| 270 | ;; MAP AXIOMS ------------------------------------------------------ | |
| 271 | ;; | |
| 272 | ;; equations | |
| 273 | (setf (module-equations newmod) | |
| 274 | (append | |
| 275 | (mapcar #'(lambda (r) | |
| 276 | (when *on-modexp-debug* | |
| 277 | (with-in-module (mod) | |
| 278 | (format t "~&* recreating the axiom :") | |
| 279 | (print-rule r))) | |
| 280 | (modmorph-recreate-axiom newmod sortmap opmap modmap r)) | |
| 281 | (module-equations mod)) | |
| 282 | (module-equations newmod))) | |
| 283 | ;; transitions | |
| 284 | (setf (module-rules newmod) | |
| 285 | (append | |
| 286 | (mapcar #'(lambda (r) | |
| 287 | (modmorph-recreate-axiom newmod sortmap opmap modmap r)) | |
| 288 | (module-rules mod)) | |
| 289 | (module-rules newmod))) | |
| 290 | (if *chaos-verbose* | |
| 291 | (print-in-progress "a") ; done mapping axioms | |
| 292 | (print-in-progress ",")) | |
| 293 | ||
| 294 | ;; THEOREMS --------------------------------------------------------- | |
| 295 | #|| NO YET | |
| 296 | (setf (module-theorems newmod) | |
| 297 | (append | |
| 298 | (mapcar #'(lambda (r) | |
| 299 | (modmorph-recreate-axiom newmod sortmap | |
| 300 | opmap modmap r)) | |
| 212 | ;; sort-relation | |
| 213 | (let ((self-rel (modmorph-recreate-sort-relations newmod | |
| 214 | mod | |
| 215 | modmap | |
| 216 | sortmap | |
| 217 | (module-sort-relations | |
| 218 | newmod)))) | |
| 219 | (setf (module-sort-relations newmod) | |
| 220 | (modmorph-merge-sort-relations | |
| 221 | (modmorph-recreate-sort-relations newmod mod modmap sortmap | |
| 222 | (module-sort-relations mod)) | |
| 223 | self-rel))) | |
| 224 | (let ((so (module-sort-order newmod))) | |
| 225 | (dolist (sl (module-sort-relations newmod)) | |
| 226 | (add-relation-to-order (copy-sort-relation sl) so)) | |
| 227 | ;; we need error sorts | |
| 228 | (when *on-modexp-debug* | |
| 229 | (with-output-msg () | |
| 230 | (format t " generating error sorts"))) | |
| 231 | (generate-err-sorts so) | |
| 232 | (setq no-error-sort t) | |
| 233 | ) | |
| 234 | ;; | |
| 235 | (if *chaos-verbose* | |
| 236 | (print-in-progress "<") ; done mapping sort relations | |
| 237 | (print-in-progress ",")) | |
| 238 | ||
| 239 | ;; MAP OPERATORS ---------------------------------------------------- | |
| 240 | ;; | |
| 241 | (when (modmorph-is-rename map) | |
| 242 | ;; operators | |
| 243 | ;; after have created sub-modules need to "fix" renaming for | |
| 244 | ;; operators too. | |
| 245 | (when *on-modexp-debug* | |
| 246 | (with-output-msg () | |
| 247 | (format t " fixing operator renaming .."))) | |
| 248 | (fix-method-renaming map newmod)) | |
| 249 | ;; | |
| 250 | (dolist (opinfo (reverse (module-all-operators mod))) | |
| 251 | ;; want to preserve the original order of operators | |
| 252 | (dolist (method (opinfo-methods opinfo)) | |
| 253 | (when (or ;; (method-is-user-defined-error-method method) | |
| 254 | (and (not (method-is-error-method method)) | |
| 255 | (not (memq method | |
| 256 | (module-methods-for-regularity mod))))) | |
| 257 | (unless (assq method opmap) | |
| 258 | (modmorph-recreate-method mod newmod sortmap method)) | |
| 259 | ))) | |
| 260 | ;; | |
| 261 | (if *chaos-verbose* | |
| 262 | (print-in-progress "o") ; done mapping operators | |
| 263 | (print-in-progress ",")) | |
| 264 | ||
| 265 | ;; At this point all operators should exist; term recreation is possible. | |
| 266 | ;; all of the error sorts & error method should be | |
| 267 | ;; generated here. | |
| 268 | (modmorph-prepare-for-parsing newmod map no-error-sort) | |
| 269 | ||
| 270 | ;; MAP AXIOMS ------------------------------------------------------ | |
| 271 | ;; | |
| 272 | ;; equations | |
| 273 | (setf (module-equations newmod) | |
| 274 | (append | |
| 275 | (mapcar #'(lambda (r) | |
| 276 | (when *on-modexp-debug* | |
| 277 | (with-in-module (mod) | |
| 278 | (format t "~%* recreating the axiom :") | |
| 279 | (print-rule r))) | |
| 280 | (modmorph-recreate-axiom newmod sortmap opmap modmap r)) | |
| 281 | (module-equations mod)) | |
| 282 | (module-equations newmod))) | |
| 283 | ;; transitions | |
| 284 | (setf (module-rules newmod) | |
| 285 | (append | |
| 286 | (mapcar #'(lambda (r) | |
| 287 | (modmorph-recreate-axiom newmod sortmap opmap modmap r)) | |
| 288 | (module-rules mod)) | |
| 289 | (module-rules newmod))) | |
| 290 | (if *chaos-verbose* | |
| 291 | (print-in-progress "a") ; done mapping axioms | |
| 292 | (print-in-progress ",")) | |
| 293 | ||
| 294 | ;; THEOREMS --------------------------------------------------------- | |
| 295 | #|| NO YET | |
| 296 | (setf (module-theorems newmod) | |
| 297 | (append | |
| 298 | (mapcar #'(lambda (r) | |
| 299 | (modmorph-recreate-axiom newmod sortmap | |
| 300 | opmap modmap r)) | |
| 301 | 301 | (module-theorems mod)) |
| 302 | (module-theorems newmod))) | |
| 303 | ||# | |
| 302 | (module-theorems newmod))) | |
| 303 | ||# | |
| 304 | 304 | |
| 305 | ;; OK we've done, nothing to be done here already. | |
| 306 | ;; | |
| 307 | (when *on-modexp-debug* | |
| 308 | (format t "~&* apply-modmorph: DONE. generated new module ") | |
| 309 | (print-mod-name newmod)) | |
| 310 | (if *chaos-verbose* | |
| 311 | (print-in-progress "]") ; done whole work. | |
| 312 | (print-in-progress ",")) | |
| 313 | newmod ;the final result | |
| 314 | )))) | |
| 305 | ;; OK we've done, nothing to be done here already. | |
| 306 | ;; | |
| 307 | (when *on-modexp-debug* | |
| 308 | (format t "~%* apply-modmorph: DONE. generated new module ") | |
| 309 | (print-mod-name newmod)) | |
| 310 | (if *chaos-verbose* | |
| 311 | (print-in-progress "]") ; done whole work. | |
| 312 | (print-in-progress ",")) | |
| 313 | newmod ;the final result | |
| 314 | )))) | |
| 315 | 315 | |
| 316 | 316 | (defun modmorph-prepare-for-parsing (mod map no-error-sort) |
| 317 | 317 | (declare (ignore no-error-sort)) |
| 330 | 330 | |
| 331 | 331 | (defun fix-operator-mapping (mod map) |
| 332 | 332 | (let ((opmap (modmorph-op map)) |
| 333 | (sort-map (modmorph-sort map))) | |
| 333 | (sort-map (modmorph-sort map))) | |
| 334 | 334 | (mapc #'(lambda (x) |
| 335 | (let ((target (cdr x))) | |
| 336 | (cond ((eq (car target) :replacement) | |
| 337 | (replace-error-method mod (caddr target) | |
| 338 | opmap sort-map)) | |
| 339 | ((eq (car target) :simple-error-map) | |
| 340 | (let ((method (cdr target)) | |
| 341 | (arity nil)) | |
| 342 | (dolist (s (method-arity method)) | |
| 343 | (if (err-sort-p s) | |
| 344 | (push (find-compatible-err-sort s | |
| 345 | mod | |
| 346 | sort-map) | |
| 347 | arity) | |
| 348 | (push s arity))) | |
| 349 | (setf (method-arity method) (nreverse arity)) | |
| 350 | (if (err-sort-p (method-coarity method)) | |
| 351 | (setf (method-coarity method) | |
| 352 | (find-compatible-err-sort | |
| 353 | (method-coarity method) | |
| 354 | mod | |
| 355 | sort-map))) | |
| 356 | (setf (car target) :simple-map))) | |
| 357 | (t nil)))) | |
| 358 | opmap))) | |
| 335 | (let ((target (cdr x))) | |
| 336 | (cond ((eq (car target) :replacement) | |
| 337 | (replace-error-method mod (caddr target) | |
| 338 | opmap sort-map)) | |
| 339 | ((eq (car target) :simple-error-map) | |
| 340 | (let ((method (cdr target)) | |
| 341 | (arity nil)) | |
| 342 | (dolist (s (method-arity method)) | |
| 343 | (if (err-sort-p s) | |
| 344 | (push (find-compatible-err-sort s | |
| 345 | mod | |
| 346 | sort-map) | |
| 347 | arity) | |
| 348 | (push s arity))) | |
| 349 | (setf (method-arity method) (nreverse arity)) | |
| 350 | (if (err-sort-p (method-coarity method)) | |
| 351 | (setf (method-coarity method) | |
| 352 | (find-compatible-err-sort | |
| 353 | (method-coarity method) | |
| 354 | mod | |
| 355 | sort-map))) | |
| 356 | (setf (car target) :simple-map))) | |
| 357 | (t nil)))) | |
| 358 | opmap))) | |
| 359 | 359 | |
| 360 | 360 | #|| |
| 361 | 361 | (defun modmorph-find-error-method (module method opmap &optional sortmap) |
| 362 | 362 | (declare (type module module) |
| 363 | (type method method) | |
| 364 | (type list opmap sortmap) | |
| 365 | (values (or null method))) | |
| 363 | (type method method) | |
| 364 | (type list opmap sortmap) | |
| 365 | (values (or null method))) | |
| 366 | 366 | (or (car (memq method (module-error-methods module))) |
| 367 | 367 | (let* ((alen (length (method-arity method))) |
| 368 | (opinfos (find-operators-in-module (method-symbol method) | |
| 369 | alen | |
| 370 | module))) | |
| 371 | (declare (type fixnum alen) | |
| 372 | (type list opinfos)) | |
| 373 | ;; | |
| 374 | (unless opinfos | |
| 375 | (let* ((name (method-symbol method)) | |
| 376 | (mapped? (find-if #'(lambda (x) | |
| 377 | (and (equal (method-symbol | |
| 378 | (the method (car x))) | |
| 379 | name) | |
| 380 | (= (the fixnum | |
| 381 | (length (method-arity (car x)))) | |
| 382 | alen))) | |
| 383 | opmap))) | |
| 384 | (when mapped? | |
| 385 | ;; (method :simple-map . method) | |
| 386 | ;; (mehtod :replacement pvars term) | |
| 387 | (setq name (if (memq (second mapped?) | |
| 388 | '(:simple-map :simple-error-map)) | |
| 389 | (method-symbol (the method (cddr mapped?))) | |
| 390 | (method-symbol (term-head (cadddr mapped?))))) | |
| 391 | (setq opinfos (find-operators-in-module name alen module))))) | |
| 392 | ;; | |
| 393 | (let ((opinfo nil) | |
| 394 | (err-method nil)) | |
| 395 | (let* ((ar (mapcar #'(lambda (x) | |
| 396 | (declare (type sort* x)) | |
| 397 | (if (err-sort-p x) | |
| 398 | (find-compatible-err-sort x module sortmap) | |
| 399 | x)) | |
| 400 | (method-arity method))) | |
| 401 | #|| | |
| 402 | (ar-names (mapcar #'(lambda(x) | |
| 403 | (declare (type sort* x)) | |
| 404 | (sort-id x)) | |
| 405 | ar)) | |
| 406 | ||# | |
| 407 | (cr (if (err-sort-p (method-coarity method)) | |
| 408 | (find-compatible-err-sort (method-coarity method) | |
| 409 | module | |
| 410 | sortmap) | |
| 411 | (method-coarity method))) | |
| 412 | #|| | |
| 413 | (cr-name (sort-id cr)) | |
| 414 | ||# | |
| 415 | ) | |
| 416 | (declare (type sort* cr)) | |
| 417 | (block find-method | |
| 418 | (dolist (oi opinfos) | |
| 419 | (declare (type list oi)) | |
| 420 | (dolist (cand (opinfo-methods oi)) | |
| 421 | (declare (type method cand)) | |
| 422 | (when (and (sort-list= ar (method-arity cand)) | |
| 423 | (sort= cr (method-coarity cand))) | |
| 424 | (setq opinfo oi) | |
| 425 | (setq err-method cand) | |
| 426 | (return-from find-method nil)) | |
| 427 | ))) | |
| 428 | ;; | |
| 429 | (unless opinfo | |
| 430 | ;; failed!.... | |
| 431 | ;; this means we need error method which are not generated | |
| 432 | ;; yet. -- really? | |
| 433 | ;; (break) | |
| 434 | (let ((arity (mapcar #'(lambda (x) | |
| 435 | (declare (type sort* x)) | |
| 436 | (if (err-sort-p x) | |
| 437 | (let ((compo | |
| 438 | (err-sort-components x))) | |
| 439 | (mapcar #'(lambda(y) | |
| 440 | (modmorph-assoc-image | |
| 441 | sortmap | |
| 442 | y)) | |
| 443 | compo)) | |
| 444 | (list (modmorph-assoc-image | |
| 445 | sortmap | |
| 446 | x)))) | |
| 447 | ar)) | |
| 448 | (coarity (let ((c cr)) | |
| 449 | (if (err-sort-p c) | |
| 450 | (let ((compo (err-sort-components c))) | |
| 451 | (mapcar #'(lambda (s) | |
| 452 | (modmorph-assoc-image sortmap s)) | |
| 453 | compo)) | |
| 454 | (list (modmorph-assoc-image sortmap c))))) | |
| 455 | (so (module-sort-order module))) | |
| 456 | (declare (type sort-order so)) | |
| 457 | ;; | |
| 458 | ;; (break) | |
| 459 | ;; | |
| 460 | (when (block | |
| 461 | find-opinfo | |
| 462 | (dolist (oi opinfos) | |
| 463 | (declare (type list oi)) | |
| 464 | (let ((mm (opinfo-methods oi))) | |
| 465 | (dolist (m mm) | |
| 466 | (declare (type method m)) | |
| 467 | (block try1 | |
| 468 | (let ((xarity (method-arity m)) | |
| 469 | (xcoarity (method-coarity m))) | |
| 470 | (declare (type list xarity) | |
| 471 | (type sort* xcoarity)) | |
| 472 | (dotimes (pos (length xarity)) | |
| 473 | (declare (type fixnum pos)) | |
| 474 | (unless (some #'(lambda (y) | |
| 475 | (declare (type sort* y)) | |
| 476 | (sort<= (the sort* | |
| 477 | (nth pos xarity)) | |
| 478 | y | |
| 479 | so)) | |
| 480 | (nth pos arity)) | |
| 481 | (return-from try1 nil))) | |
| 482 | (unless (some #'(lambda (y) | |
| 483 | (declare (type sort* y)) | |
| 484 | (sort<= xcoarity y so)) | |
| 485 | coarity) | |
| 486 | (return-from try1 nil)) | |
| 487 | (setq opinfo oi) | |
| 488 | (return-from find-opinfo t)) | |
| 489 | ))))) | |
| 490 | ;; | |
| 491 | (setup-error-operator opinfo module) | |
| 492 | (setq err-method (car (opinfo-methods opinfo))) | |
| 493 | ))) | |
| 494 | ) | |
| 495 | ;; | |
| 496 | (when *on-modexp-debug* | |
| 497 | (format t "~%-- finding error method for : ") | |
| 498 | (print-chaos-object method) | |
| 499 | (format t "~% found : ") | |
| 500 | (print-chaos-object err-method)) | |
| 501 | ;; | |
| 502 | err-method)))) | |
| 368 | (opinfos (find-operators-in-module (method-symbol method) | |
| 369 | alen | |
| 370 | module))) | |
| 371 | (declare (type fixnum alen) | |
| 372 | (type list opinfos)) | |
| 373 | ;; | |
| 374 | (unless opinfos | |
| 375 | (let* ((name (method-symbol method)) | |
| 376 | (mapped? (find-if #'(lambda (x) | |
| 377 | (and (equal (method-symbol | |
| 378 | (the method (car x))) | |
| 379 | name) | |
| 380 | (= (the fixnum | |
| 381 | (length (method-arity (car x)))) | |
| 382 | alen))) | |
| 383 | opmap))) | |
| 384 | (when mapped? | |
| 385 | ;; (method :simple-map . method) | |
| 386 | ;; (mehtod :replacement pvars term) | |
| 387 | (setq name (if (memq (second mapped?) | |
| 388 | '(:simple-map :simple-error-map)) | |
| 389 | (method-symbol (the method (cddr mapped?))) | |
| 390 | (method-symbol (term-head (cadddr mapped?))))) | |
| 391 | (setq opinfos (find-operators-in-module name alen module))))) | |
| 392 | ;; | |
| 393 | (let ((opinfo nil) | |
| 394 | (err-method nil)) | |
| 395 | (let* ((ar (mapcar #'(lambda (x) | |
| 396 | (declare (type sort* x)) | |
| 397 | (if (err-sort-p x) | |
| 398 | (find-compatible-err-sort x module sortmap) | |
| 399 | x)) | |
| 400 | (method-arity method))) | |
| 401 | #|| | |
| 402 | (ar-names (mapcar #'(lambda(x) | |
| 403 | (declare (type sort* x)) | |
| 404 | (sort-id x)) | |
| 405 | ar)) | |
| 406 | ||# | |
| 407 | (cr (if (err-sort-p (method-coarity method)) | |
| 408 | (find-compatible-err-sort (method-coarity method) | |
| 409 | module | |
| 410 | sortmap) | |
| 411 | (method-coarity method))) | |
| 412 | #|| | |
| 413 | (cr-name (sort-id cr)) | |
| 414 | ||# | |
| 415 | ) | |
| 416 | (declare (type sort* cr)) | |
| 417 | (block find-method | |
| 418 | (dolist (oi opinfos) | |
| 419 | (declare (type list oi)) | |
| 420 | (dolist (cand (opinfo-methods oi)) | |
| 421 | (declare (type method cand)) | |
| 422 | (when (and (sort-list= ar (method-arity cand)) | |
| 423 | (sort= cr (method-coarity cand))) | |
| 424 | (setq opinfo oi) | |
| 425 | (setq err-method cand) | |
| 426 | (return-from find-method nil)) | |
| 427 | ))) | |
| 428 | ;; | |
| 429 | (unless opinfo | |
| 430 | ;; failed!.... | |
| 431 | ;; this means we need error method which are not generated | |
| 432 | ;; yet. -- really? | |
| 433 | ;; (break) | |
| 434 | (let ((arity (mapcar #'(lambda (x) | |
| 435 | (declare (type sort* x)) | |
| 436 | (if (err-sort-p x) | |
| 437 | (let ((compo | |
| 438 | (err-sort-components x))) | |
| 439 | (mapcar #'(lambda(y) | |
| 440 | (modmorph-assoc-image | |
| 441 | sortmap | |
| 442 | y)) | |
| 443 | compo)) | |
| 444 | (list (modmorph-assoc-image | |
| 445 | sortmap | |
| 446 | x)))) | |
| 447 | ar)) | |
| 448 | (coarity (let ((c cr)) | |
| 449 | (if (err-sort-p c) | |
| 450 | (let ((compo (err-sort-components c))) | |
| 451 | (mapcar #'(lambda (s) | |
| 452 | (modmorph-assoc-image sortmap s)) | |
| 453 | compo)) | |
| 454 | (list (modmorph-assoc-image sortmap c))))) | |
| 455 | (so (module-sort-order module))) | |
| 456 | (declare (type sort-order so)) | |
| 457 | ;; | |
| 458 | ;; (break) | |
| 459 | ;; | |
| 460 | (when (block | |
| 461 | find-opinfo | |
| 462 | (dolist (oi opinfos) | |
| 463 | (declare (type list oi)) | |
| 464 | (let ((mm (opinfo-methods oi))) | |
| 465 | (dolist (m mm) | |
| 466 | (declare (type method m)) | |
| 467 | (block try1 | |
| 468 | (let ((xarity (method-arity m)) | |
| 469 | (xcoarity (method-coarity m))) | |
| 470 | (declare (type list xarity) | |
| 471 | (type sort* xcoarity)) | |
| 472 | (dotimes (pos (length xarity)) | |
| 473 | (declare (type fixnum pos)) | |
| 474 | (unless (some #'(lambda (y) | |
| 475 | (declare (type sort* y)) | |
| 476 | (sort<= (the sort* | |
| 477 | (nth pos xarity)) | |
| 478 | y | |
| 479 | so)) | |
| 480 | (nth pos arity)) | |
| 481 | (return-from try1 nil))) | |
| 482 | (unless (some #'(lambda (y) | |
| 483 | (declare (type sort* y)) | |
| 484 | (sort<= xcoarity y so)) | |
| 485 | coarity) | |
| 486 | (return-from try1 nil)) | |
| 487 | (setq opinfo oi) | |
| 488 | (return-from find-opinfo t)) | |
| 489 | ))))) | |
| 490 | ;; | |
| 491 | (setup-error-operator opinfo module) | |
| 492 | (setq err-method (car (opinfo-methods opinfo))) | |
| 493 | ))) | |
| 494 | ) | |
| 495 | ;; | |
| 496 | (when *on-modexp-debug* | |
| 497 | (format t "~%-- finding error method for : ") | |
| 498 | (print-chaos-object method) | |
| 499 | (format t "~% found : ") | |
| 500 | (print-chaos-object err-method)) | |
| 501 | ;; | |
| 502 | err-method)))) | |
| 503 | 503 | ||# |
| 504 | 504 | |
| 505 | 505 | (defun modmorph-find-mapped-sorts (module sort-l sortmap) |
| 506 | 506 | (mapcar #'(lambda (x) |
| 507 | (declare (type sort* x)) | |
| 508 | (if (err-sort-p x) | |
| 509 | (find-compatible-err-sort x module sortmap) | |
| 510 | (or (cdr (assq x sortmap)) x))) | |
| 511 | sort-l)) | |
| 507 | (declare (type sort* x)) | |
| 508 | (if (err-sort-p x) | |
| 509 | (find-compatible-err-sort x module sortmap) | |
| 510 | (or (cdr (assq x sortmap)) x))) | |
| 511 | sort-l)) | |
| 512 | 512 | |
| 513 | 513 | ;;; ******* |
| 514 | 514 | (defun modmorph-copy-method-attributes (from to) |
| 515 | 515 | (let (sup-strat |
| 516 | theory | |
| 517 | prec | |
| 518 | memo | |
| 519 | assoc | |
| 520 | constr) | |
| 516 | theory | |
| 517 | prec | |
| 518 | memo | |
| 519 | assoc | |
| 520 | constr) | |
| 521 | 521 | (let ((from-module (method-module from))) |
| 522 | 522 | (with-in-module (from-module) |
| 523 | (setf sup-strat (method-supplied-strategy from) | |
| 524 | theory (method-theory from) | |
| 525 | prec (get-method-precedence from) | |
| 526 | memo (method-has-memo from) | |
| 527 | assoc (method-associativity from) | |
| 528 | constr (method-constructor from)))) | |
| 523 | (setf sup-strat (method-supplied-strategy from) | |
| 524 | theory (method-theory from) | |
| 525 | prec (get-method-precedence from) | |
| 526 | memo (method-has-memo from) | |
| 527 | assoc (method-associativity from) | |
| 528 | constr (method-constructor from)))) | |
| 529 | 529 | (let ((to-module (method-module to))) |
| 530 | 530 | (with-in-module (to-module) |
| 531 | (setf (method-supplied-strategy to) sup-strat | |
| 532 | (method-precedence to) prec | |
| 533 | (method-has-memo to) memo | |
| 534 | (method-associativity to) assoc | |
| 535 | (method-constructor to) constr) | |
| 536 | (set-method-theory to theory) | |
| 537 | )) | |
| 531 | (setf (method-supplied-strategy to) sup-strat | |
| 532 | (method-precedence to) prec | |
| 533 | (method-has-memo to) memo | |
| 534 | (method-associativity to) assoc | |
| 535 | (method-constructor to) constr) | |
| 536 | (set-method-theory to theory) | |
| 537 | )) | |
| 538 | 538 | )) |
| 539 | 539 | |
| 540 | 540 | |
| 541 | 541 | (defun modmorph-find-user-defined-error-method (method module sortmap) |
| 542 | 542 | (let ((arity (modmorph-find-mapped-sorts module |
| 543 | (method-arity method) | |
| 544 | sortmap)) | |
| 545 | (coarity (car (modmorph-find-mapped-sorts module | |
| 546 | (list (method-coarity method)) | |
| 547 | sortmap)))) | |
| 543 | (method-arity method) | |
| 544 | sortmap)) | |
| 545 | (coarity (car (modmorph-find-mapped-sorts module | |
| 546 | (list (method-coarity method)) | |
| 547 | sortmap)))) | |
| 548 | 548 | |
| 549 | 549 | (multiple-value-bind (op err-method) |
| 550 | (declare-operator-in-module | |
| 551 | (method-symbol method) | |
| 552 | arity | |
| 553 | coarity | |
| 554 | module | |
| 555 | (method-is-constructor? method) ; constructor? | |
| 556 | (method-is-behavioural method) | |
| 557 | nil | |
| 558 | t) ; error method? | |
| 550 | (declare-operator-in-module | |
| 551 | (method-symbol method) | |
| 552 | arity | |
| 553 | coarity | |
| 554 | module | |
| 555 | (method-is-constructor? method) ; constructor? | |
| 556 | (method-is-behavioural method) | |
| 557 | nil | |
| 558 | t) ; error method? | |
| 559 | 559 | (declare (ignore op)) |
| 560 | 560 | (modmorph-copy-method-attributes method err-method) |
| 561 | 561 | err-method))) |
| 562 | 562 | |
| 563 | 563 | (defun modmorph-find-proper-error-method (method opinfos module sortmap) |
| 564 | 564 | (let ((opinfo nil) |
| 565 | (err-method nil)) | |
| 565 | (err-method nil)) | |
| 566 | 566 | (let ((ar (modmorph-find-mapped-sorts module |
| 567 | (method-arity method) | |
| 568 | sortmap)) | |
| 569 | (cr (car (modmorph-find-mapped-sorts module | |
| 570 | (list (method-coarity method)) | |
| 571 | sortmap))) | |
| 572 | ) | |
| 567 | (method-arity method) | |
| 568 | sortmap)) | |
| 569 | (cr (car (modmorph-find-mapped-sorts module | |
| 570 | (list (method-coarity method)) | |
| 571 | sortmap))) | |
| 572 | ) | |
| 573 | 573 | (declare (type sort* cr)) |
| 574 | 574 | (block find-method |
| 575 | (dolist (oi opinfos) | |
| 576 | (declare (type list oi)) | |
| 577 | (dolist (cand (opinfo-methods oi)) | |
| 578 | (declare (type method cand)) | |
| 579 | ;;----- | |
| 580 | (when (and (sort-list= ar (method-arity cand)) | |
| 581 | (sort= cr (method-coarity cand))) | |
| 582 | (setq opinfo oi) | |
| 583 | (setq err-method cand) | |
| 584 | (return-from find-method nil)) | |
| 585 | ))) | |
| 586 | ;; | |
| 575 | (dolist (oi opinfos) | |
| 576 | (declare (type list oi)) | |
| 577 | (dolist (cand (opinfo-methods oi)) | |
| 578 | (declare (type method cand)) | |
| 579 | ;;----- | |
| 580 | (when (and (sort-list= ar (method-arity cand)) | |
| 581 | (sort= cr (method-coarity cand))) | |
| 582 | (setq opinfo oi) | |
| 583 | (setq err-method cand) | |
| 584 | (return-from find-method nil)) | |
| 585 | ))) | |
| 586 | ;; | |
| 587 | 587 | (unless opinfo |
| 588 | ;; failed!.... | |
| 589 | ;; this means we need error method | |
| 590 | ;; which are not generated yet. -- really? | |
| 591 | (let ((arity (mapcar #'(lambda (x) | |
| 592 | (declare (type sort* x)) | |
| 593 | (if (err-sort-p x) | |
| 594 | (let ((compo | |
| 595 | (err-sort-components | |
| 596 | x))) | |
| 597 | (mapcar #'(lambda(y) | |
| 598 | (modmorph-assoc-image | |
| 599 | sortmap | |
| 600 | y)) | |
| 601 | compo)) | |
| 602 | (list (modmorph-assoc-image | |
| 603 | sortmap | |
| 604 | x)))) | |
| 605 | ar)) | |
| 606 | (coarity (let ((c cr)) | |
| 607 | (if (err-sort-p c) | |
| 608 | (let ((compo (err-sort-components c))) | |
| 609 | (mapcar #'(lambda (s) | |
| 610 | (modmorph-assoc-image sortmap s)) | |
| 611 | compo)) | |
| 612 | (list (modmorph-assoc-image sortmap c))))) | |
| 613 | (so (module-sort-order module))) | |
| 614 | (declare (type sort-order so)) | |
| 615 | ;; | |
| 616 | (when (block | |
| 617 | find-opinfo | |
| 618 | (dolist (oi opinfos) | |
| 619 | (declare (type list oi)) | |
| 620 | (let ((mm (opinfo-methods oi))) | |
| 621 | (dolist (m mm) | |
| 622 | (declare (type method m)) | |
| 623 | (block try1 | |
| 624 | (let ((xarity (method-arity m)) | |
| 625 | (xcoarity (method-coarity m))) | |
| 626 | (declare (type list xarity) | |
| 627 | (type sort* xcoarity)) | |
| 628 | (dotimes (pos (length xarity)) | |
| 629 | (declare (type fixnum pos)) | |
| 630 | (unless (some #'(lambda (y) | |
| 631 | (declare (type sort* y)) | |
| 632 | (sort<= (the sort* | |
| 633 | (nth pos xarity)) | |
| 634 | y | |
| 635 | so)) | |
| 636 | (nth pos arity)) | |
| 637 | (return-from try1 nil))) | |
| 638 | (unless (some #'(lambda (y) | |
| 639 | (declare (type sort* y)) | |
| 640 | (sort<= xcoarity y so)) | |
| 641 | coarity) | |
| 642 | (return-from try1 nil)) | |
| 643 | (setq opinfo oi) | |
| 644 | (return-from find-opinfo t)) | |
| 645 | ))))) | |
| 646 | ;; | |
| 647 | (setup-error-operator opinfo module) | |
| 648 | (setq err-method (car (opinfo-methods opinfo))) | |
| 649 | ) | |
| 650 | (unless err-method | |
| 651 | ;; this means that the original method should be an | |
| 652 | ;; user defined error-method... | |
| 653 | ;; make sure that really is ... | |
| 654 | (unless (or (some #'(lambda (x) | |
| 655 | (declare (type sort* x)) | |
| 656 | (err-sort-p x)) | |
| 657 | ar) | |
| 658 | (err-sort-p coarity)) | |
| 659 | ;; so bad ... | |
| 660 | (with-output-panic-message () | |
| 661 | (format t "well ... could not find proper error method for ") | |
| 662 | (print-chaos-object method))) | |
| 663 | ;; we declare err-method | |
| 664 | ;; (format t "~&declaring new error method...") | |
| 665 | (multiple-value-bind (o m) | |
| 666 | (declare-operator-in-module | |
| 667 | (method-symbol method) | |
| 668 | arity | |
| 669 | coarity | |
| 670 | module | |
| 671 | (method-is-constructor? method) ; constructor? | |
| 672 | (method-is-behavioural method) | |
| 673 | nil | |
| 674 | t) ; error method? | |
| 675 | (declare (ignore o)) | |
| 676 | (setq err-method m)) | |
| 677 | ) ; end case no err-method | |
| 678 | ) | |
| 679 | ) ; end case no op-info | |
| 588 | ;; failed!.... | |
| 589 | ;; this means we need error method | |
| 590 | ;; which are not generated yet. -- really? | |
| 591 | (let ((arity (mapcar #'(lambda (x) | |
| 592 | (declare (type sort* x)) | |
| 593 | (if (err-sort-p x) | |
| 594 | (let ((compo | |
| 595 | (err-sort-components | |
| 596 | x))) | |
| 597 | (mapcar #'(lambda(y) | |
| 598 | (modmorph-assoc-image | |
| 599 | sortmap | |
| 600 | y)) | |
| 601 | compo)) | |
| 602 | (list (modmorph-assoc-image | |
| 603 | sortmap | |
| 604 | x)))) | |
| 605 | ar)) | |
| 606 | (coarity (let ((c cr)) | |
| 607 | (if (err-sort-p c) | |
| 608 | (let ((compo (err-sort-components c))) | |
| 609 | (mapcar #'(lambda (s) | |
| 610 | (modmorph-assoc-image sortmap s)) | |
| 611 | compo)) | |
| 612 | (list (modmorph-assoc-image sortmap c))))) | |
| 613 | (so (module-sort-order module))) | |
| 614 | (declare (type sort-order so)) | |
| 615 | ;; | |
| 616 | (when (block | |
| 617 | find-opinfo | |
| 618 | (dolist (oi opinfos) | |
| 619 | (declare (type list oi)) | |
| 620 | (let ((mm (opinfo-methods oi))) | |
| 621 | (dolist (m mm) | |
| 622 | (declare (type method m)) | |
| 623 | (block try1 | |
| 624 | (let ((xarity (method-arity m)) | |
| 625 | (xcoarity (method-coarity m))) | |
| 626 | (declare (type list xarity) | |
| 627 | (type sort* xcoarity)) | |
| 628 | (dotimes (pos (length xarity)) | |
| 629 | (declare (type fixnum pos)) | |
| 630 | (unless (some #'(lambda (y) | |
| 631 | (declare (type sort* y)) | |
| 632 | (sort<= (the sort* | |
| 633 | (nth pos xarity)) | |
| 634 | y | |
| 635 | so)) | |
| 636 | (nth pos arity)) | |
| 637 | (return-from try1 nil))) | |
| 638 | (unless (some #'(lambda (y) | |
| 639 | (declare (type sort* y)) | |
| 640 | (sort<= xcoarity y so)) | |
| 641 | coarity) | |
| 642 | (return-from try1 nil)) | |
| 643 | (setq opinfo oi) | |
| 644 | (return-from find-opinfo t)) | |
| 645 | ))))) | |
| 646 | ;; | |
| 647 | (setup-error-operator opinfo module) | |
| 648 | (setq err-method (car (opinfo-methods opinfo))) | |
| 649 | ) | |
| 650 | (unless err-method | |
| 651 | ;; this means that the original method should be an | |
| 652 | ;; user defined error-method... | |
| 653 | ;; make sure that really is ... | |
| 654 | (unless (or (some #'(lambda (x) | |
| 655 | (declare (type sort* x)) | |
| 656 | (err-sort-p x)) | |
| 657 | ar) | |
| 658 | (err-sort-p coarity)) | |
| 659 | ;; so bad ... | |
| 660 | (with-output-panic-message () | |
| 661 | (format t "well ... could not find proper error method for ") | |
| 662 | (print-chaos-object method))) | |
| 663 | ;; we declare err-method | |
| 664 | ;; (format t "~&declaring new error method...") | |
| 665 | (multiple-value-bind (o m) | |
| 666 | (declare-operator-in-module | |
| 667 | (method-symbol method) | |
| 668 | arity | |
| 669 | coarity | |
| 670 | module | |
| 671 | (method-is-constructor? method) ; constructor? | |
| 672 | (method-is-behavioural method) | |
| 673 | nil | |
| 674 | t) ; error method? | |
| 675 | (declare (ignore o)) | |
| 676 | (setq err-method m)) | |
| 677 | ) ; end case no err-method | |
| 678 | ) | |
| 679 | ) ; end case no op-info | |
| 680 | 680 | ) |
| 681 | 681 | ;; |
| 682 | 682 | (when *on-modexp-debug* |
| 690 | 690 | (defun modmorph-find-error-method (module method opmap sortmap) |
| 691 | 691 | (or (car (memq method (module-error-methods module))) |
| 692 | 692 | (let* ((alen (length (method-arity method))) |
| 693 | (opinfos nil) | |
| 694 | (name (method-symbol method)) | |
| 695 | (mapped? (find-if #'(lambda (x) | |
| 696 | (and (method-p (car x)) | |
| 697 | ;; there is a case built-in constant | |
| 698 | ;; is mapped, thus need method-p here. | |
| 699 | ;; Wed Mar 3 17:30:33 JST 1999 | |
| 700 | (equal (method-symbol | |
| 701 | (the method (car x))) | |
| 702 | name) | |
| 703 | (= (the fixnum | |
| 704 | (length (method-arity (car x)))) | |
| 705 | alen))) | |
| 706 | opmap))) | |
| 707 | (declare (type fixnum alen) | |
| 708 | (type list opinfos)) | |
| 709 | ;; | |
| 710 | (if mapped? | |
| 711 | (progn | |
| 712 | ;; (method :simple-map . method) | |
| 713 | ;; (mehtod :replacement pvars term) | |
| 714 | (when *on-modexp-debug* | |
| 715 | (format t "~%-- finding error method: ") | |
| 716 | (format t "~% mapped ~s" mapped?)) | |
| 717 | (setq name (if (memq (second mapped?) | |
| 718 | '(:simple-map :simple-error-map)) | |
| 719 | (method-symbol (the method (cddr mapped?))) | |
| 720 | (method-symbol (term-head (cadddr mapped?))))) | |
| 721 | (setq opinfos (find-operators-in-module name alen module))) | |
| 722 | ;; mot mapped | |
| 723 | (progn | |
| 724 | (setq opinfos (find-operators-in-module (method-symbol method) | |
| 725 | alen | |
| 726 | module)) | |
| 727 | (when *on-modexp-debug* | |
| 728 | (format t "~%-- finding error method: ") | |
| 729 | (format t "~% not mapped, got infos : ") | |
| 730 | (print-chaos-object opinfos)))) | |
| 731 | (cond (opinfos | |
| 732 | (modmorph-find-proper-error-method method | |
| 733 | opinfos | |
| 734 | module | |
| 735 | sortmap)) | |
| 736 | (t ; this means that the err method is | |
| 737 | ; user defined one. | |
| 738 | (modmorph-find-user-defined-error-method method | |
| 739 | module | |
| 740 | sortmap))) | |
| 741 | ))) | |
| 693 | (opinfos nil) | |
| 694 | (name (method-symbol method)) | |
| 695 | (mapped? (find-if #'(lambda (x) | |
| 696 | (and (method-p (car x)) | |
| 697 | ;; there is a case built-in constant | |
| 698 | ;; is mapped, thus need method-p here. | |
| 699 | ;; Wed Mar 3 17:30:33 JST 1999 | |
| 700 | (equal (method-symbol | |
| 701 | (the method (car x))) | |
| 702 | name) | |
| 703 | (= (the fixnum | |
| 704 | (length (method-arity (car x)))) | |
| 705 | alen))) | |
| 706 | opmap))) | |
| 707 | (declare (type fixnum alen) | |
| 708 | (type list opinfos)) | |
| 709 | ;; | |
| 710 | (if mapped? | |
| 711 | (progn | |
| 712 | ;; (method :simple-map . method) | |
| 713 | ;; (mehtod :replacement pvars term) | |
| 714 | (when *on-modexp-debug* | |
| 715 | (format t "~%-- finding error method: ") | |
| 716 | (format t "~% mapped ~s" mapped?)) | |
| 717 | (setq name (if (memq (second mapped?) | |
| 718 | '(:simple-map :simple-error-map)) | |
| 719 | (method-symbol (the method (cddr mapped?))) | |
| 720 | (method-symbol (term-head (cadddr mapped?))))) | |
| 721 | (setq opinfos (find-operators-in-module name alen module))) | |
| 722 | ;; mot mapped | |
| 723 | (progn | |
| 724 | (setq opinfos (find-operators-in-module (method-symbol method) | |
| 725 | alen | |
| 726 | module)) | |
| 727 | (when *on-modexp-debug* | |
| 728 | (format t "~%-- finding error method: ") | |
| 729 | (format t "~% not mapped, got infos : ") | |
| 730 | (print-chaos-object opinfos)))) | |
| 731 | (cond (opinfos | |
| 732 | (modmorph-find-proper-error-method method | |
| 733 | opinfos | |
| 734 | module | |
| 735 | sortmap)) | |
| 736 | (t ; this means that the err method is | |
| 737 | ; user defined one. | |
| 738 | (modmorph-find-user-defined-error-method method | |
| 739 | module | |
| 740 | sortmap))) | |
| 741 | ))) | |
| 742 | 742 | |
| 743 | 743 | |
| 744 | 744 | (defun replace-error-method (mod term op-map sort-map) |
| 745 | 745 | (declare (type module mod) |
| 746 | (type term term) | |
| 747 | (type list op-map sort-map) | |
| 748 | (values t)) | |
| 746 | (type term term) | |
| 747 | (type list op-map sort-map) | |
| 748 | (values t)) | |
| 749 | 749 | (if (term-is-application-form? term) |
| 750 | 750 | (let ((head nil)) |
| 751 | (when (or (method-is-error-method (term-head term)) | |
| 752 | (or (sort= (term-sort term) *universal-sort*) | |
| 753 | (sort= (term-sort term) *huniversal-sort*))) | |
| 754 | (setq head (modmorph-find-error-method mod (term-head term) | |
| 755 | op-map sort-map)) | |
| 756 | (when head | |
| 757 | (change-head-operator term head))) | |
| 758 | (dolist (sub (term-subterms term)) | |
| 759 | (replace-error-method mod sub op-map sort-map))) | |
| 751 | (when (or (method-is-error-method (term-head term)) | |
| 752 | (or (sort= (term-sort term) *universal-sort*) | |
| 753 | (sort= (term-sort term) *huniversal-sort*))) | |
| 754 | (setq head (modmorph-find-error-method mod (term-head term) | |
| 755 | op-map sort-map)) | |
| 756 | (when head | |
| 757 | (change-head-operator term head))) | |
| 758 | (dolist (sub (term-subterms term)) | |
| 759 | (replace-error-method mod sub op-map sort-map))) | |
| 760 | 760 | (if (term-is-variable? term) |
| 761 | (let ((sort (variable-sort term))) | |
| 762 | (when (err-sort-p sort) | |
| 763 | (let ((new (find-compatible-err-sort sort mod sort-map))) | |
| 764 | (if new | |
| 765 | (setf (variable-sort term) new) | |
| 766 | ;; may be error...but | |
| 767 | nil))))))) | |
| 761 | (let ((sort (variable-sort term))) | |
| 762 | (when (err-sort-p sort) | |
| 763 | (let ((new (find-compatible-err-sort sort mod sort-map))) | |
| 764 | (if new | |
| 765 | (setf (variable-sort term) new) | |
| 766 | ;; may be error...but | |
| 767 | nil))))))) | |
| 768 | 768 | |
| 769 | 769 | ;;; ************** |
| 770 | 770 | ;;; MAP SUBMODULES______________________________________________________________ |
| 780 | 780 | ;;; |
| 781 | 781 | (defun modmorph-submodule-is-mapped (modmap mod) |
| 782 | 782 | (some #'(lambda (x) |
| 783 | (or (modmorph-module-is-mapped modmap (car x)) | |
| 784 | (modmorph-submodule-is-mapped modmap (car x)))) | |
| 785 | (module-submodules mod)) | |
| 783 | (or (modmorph-module-is-mapped modmap (car x)) | |
| 784 | (modmorph-submodule-is-mapped modmap (car x)))) | |
| 785 | (module-submodules mod)) | |
| 786 | 786 | ) |
| 787 | 787 | |
| 788 | 788 | ;;;============================================================================= |
| 798 | 798 | ;;; |
| 799 | 799 | (defun modmorph-import-submodule (mod newmod map mode submod) |
| 800 | 800 | (let* ((modmap (modmorph-module map)) |
| 801 | (direct-img (assq submod modmap)) ; is it mapped directly? | |
| 802 | (submodule-image nil)) | |
| 801 | (direct-img (assq submod modmap)) ; is it mapped directly? | |
| 802 | (submodule-image nil)) | |
| 803 | 803 | (when *on-modexp-debug* |
| 804 | (format t "~&[modmorph-import-submodule]: ") | |
| 804 | (format t "~%[modmorph-import-submodule]: ") | |
| 805 | 805 | (princ " ") (print-modexp newmod) (princ " <== ") |
| 806 | 806 | (print-modexp submod) |
| 807 | 807 | (format t "~& - img:key= ") (print-chaos-object (car direct-img)) |
| 808 | 808 | (format t "~& - img:val= ") (print-chaos-object (cdr direct-img))) |
| 809 | 809 | ;; |
| 810 | 810 | (setq submodule-image |
| 811 | (if direct-img | |
| 812 | (cond ((or (null (cdr direct-img)) | |
| 813 | (is-dummy-module (cdr direct-img))) | |
| 814 | ;;case of renaming | |
| 815 | (when *on-modexp-debug* | |
| 816 | (format t "~% - case renaming:")) | |
| 817 | (modmorph-map-submodule map mod submod)) | |
| 818 | (t ;associated value is a view in general. | |
| 819 | (target-of-view-arg (cdr direct-img)))) | |
| 820 | (if (modmorph-submodule-is-mapped modmap submod) | |
| 821 | (modmorph-map-submodule map mod submod) | |
| 822 | submod))) | |
| 811 | (if direct-img | |
| 812 | (cond ((or (null (cdr direct-img)) | |
| 813 | (is-dummy-module (cdr direct-img))) | |
| 814 | ;;case of renaming | |
| 815 | (when *on-modexp-debug* | |
| 816 | (format t "~% - case renaming:")) | |
| 817 | (modmorph-map-submodule map mod submod)) | |
| 818 | (t ;associated value is a view in general. | |
| 819 | (target-of-view-arg (cdr direct-img)))) | |
| 820 | (if (modmorph-submodule-is-mapped modmap submod) | |
| 821 | (modmorph-map-submodule map mod submod) | |
| 822 | submod))) | |
| 823 | 823 | (when *on-modexp-debug* |
| 824 | 824 | (format t "~& -image ") |
| 825 | 825 | (print-modexp submod) (princ " --> ") |
| 826 | 826 | (print-modexp submodule-image)) |
| 827 | 827 | ;; |
| 828 | 828 | (if (eq ':using mode) |
| 829 | (modmorph-import-submodules mod newmod map submodule-image) | |
| 830 | #|| | |
| 831 | (if (module-is-parameter-theory submodule-image) | |
| 832 | (let* ((mod-name (module-name submodule-image)) | |
| 833 | (formal-name (first mod-name)) | |
| 834 | (real-sub (third mod-name))) | |
| 835 | (import-module newmod mode real-sub formal-name)) | |
| 836 | (import-module newmod mode submodule-image)) | |
| 837 | ||# | |
| 838 | (import-module newmod mode submodule-image) | |
| 839 | ) | |
| 829 | (modmorph-import-submodules mod newmod map submodule-image) | |
| 830 | #|| | |
| 831 | (if (module-is-parameter-theory submodule-image) | |
| 832 | (let* ((mod-name (module-name submodule-image)) | |
| 833 | (formal-name (first mod-name)) | |
| 834 | (real-sub (third mod-name))) | |
| 835 | (import-module newmod mode real-sub formal-name)) | |
| 836 | (import-module newmod mode submodule-image)) | |
| 837 | ||# | |
| 838 | (import-module newmod mode submodule-image) | |
| 839 | ) | |
| 840 | 840 | )) |
| 841 | 841 | |
| 842 | 842 | ;;;----------------------------------------------------------------------------- |
| 865 | 865 | |
| 866 | 866 | (defun modmorph-map-submodule (map mod smod) |
| 867 | 867 | (let ((parameters (get-module-parameters smod))) |
| 868 | (cond (parameters ; was (module-parameters smod) | |
| 869 | (when *on-modexp-debug* | |
| 870 | (format t "~%[modmorph-map-submodule]:") | |
| 871 | (print-modexp smod) | |
| 872 | (format t "~% sub has parameters :") | |
| 873 | (print-chaos-object parameters)) | |
| 874 | ;; submdule has parameters, | |
| 875 | ;; checks some of them is mapped or not. | |
| 876 | (let ((mod-map (modmorph-module map)) | |
| 877 | (own-params (mapcar #'(lambda (x) (parameter-theory-module x)) | |
| 878 | parameters)) | |
| 879 | (args nil)) | |
| 880 | (dolist (mmod mod-map) | |
| 881 | (if (memq (car mmod) own-params) | |
| 882 | (push (%!arg* (car (module-name (car mmod))) | |
| 883 | (cdr mmod)) | |
| 884 | args))) | |
| 885 | (let ((new-name (%instantiation* smod args))) | |
| 886 | ;; * * * | |
| 887 | (apply-modmorph (normalize-modexp new-name) map smod) | |
| 888 | ))) | |
| 889 | ;; | |
| 890 | (t (let ((nm (modmorph-construct-name map | |
| 891 | ;; (module-name smod) | |
| 892 | smod))) | |
| 893 | (let* ((me (normalize-modexp nm)) | |
| 894 | (val (find-modexp-eval me))) | |
| 895 | (when *on-modexp-debug* | |
| 896 | (format t "~&[modmorph-map-submodule]: ") | |
| 897 | (print-modexp smod) | |
| 898 | (princ " ==> ") | |
| 899 | (print-modexp me) | |
| 900 | (format t "~& - mod = ") | |
| 901 | (print-modexp mod) | |
| 902 | (format t "~& - map ") | |
| 903 | (print-mapping map) | |
| 904 | (format t "~& - val = ") | |
| 905 | (print-modexp val)) | |
| 906 | (if val | |
| 907 | (progn | |
| 908 | (let ((pair (assq smod (modmorph-module map))) | |
| 909 | (nmod val)) | |
| 910 | (when *on-modexp-debug* | |
| 911 | (format t "~& - map pair : ") | |
| 912 | (format t "~& key : ")(print-modexp (car pair)) | |
| 913 | (format t "~& val : ")(print-modexp (cdr pair))) | |
| 914 | (if pair | |
| 915 | (rplacd pair val) | |
| 916 | (push (cons smod val) (modmorph-module map))) | |
| 917 | (setf (modmorph-module map) | |
| 918 | (append (modmorph-compute-submodule-mappings | |
| 919 | map mod smod) | |
| 920 | (modmorph-module map))) | |
| 921 | nmod)) | |
| 922 | ;; | |
| 923 | (let ((newmod (apply-modmorph me map smod))) | |
| 924 | ;; (add-canon-modexp me me) | |
| 925 | (add-modexp-eval me newmod) | |
| 926 | (setf (modmorph-module map) | |
| 927 | (cons (cons smod newmod) | |
| 928 | (modmorph-module map))) | |
| 929 | newmod)))))))) | |
| 868 | (cond (parameters ; was (module-parameters smod) | |
| 869 | (when *on-modexp-debug* | |
| 870 | (format t "~%[modmorph-map-submodule]:") | |
| 871 | (print-modexp smod) | |
| 872 | (format t "~% sub has parameters :") | |
| 873 | (print-chaos-object parameters)) | |
| 874 | ;; submdule has parameters, | |
| 875 | ;; checks some of them is mapped or not. | |
| 876 | (let ((mod-map (modmorph-module map)) | |
| 877 | (own-params (mapcar #'(lambda (x) (parameter-theory-module x)) | |
| 878 | parameters)) | |
| 879 | (args nil)) | |
| 880 | (dolist (mmod mod-map) | |
| 881 | (if (memq (car mmod) own-params) | |
| 882 | (push (%!arg* (car (module-name (car mmod))) | |
| 883 | (cdr mmod)) | |
| 884 | args))) | |
| 885 | (let ((new-name (%instantiation* smod args))) | |
| 886 | ;; * * * | |
| 887 | (apply-modmorph (normalize-modexp new-name) map smod) | |
| 888 | ))) | |
| 889 | ;; | |
| 890 | (t (let ((nm (modmorph-construct-name map | |
| 891 | ;; (module-name smod) | |
| 892 | smod))) | |
| 893 | (let* ((me (normalize-modexp nm)) | |
| 894 | (val (find-modexp-eval me))) | |
| 895 | (when *on-modexp-debug* | |
| 896 | (format t "~%[modmorph-map-submodule]: ") | |
| 897 | (print-modexp smod) | |
| 898 | (princ " ==> ") | |
| 899 | (print-modexp me) | |
| 900 | (format t "~& - mod = ") | |
| 901 | (print-modexp mod) | |
| 902 | (format t "~& - map ") | |
| 903 | (print-mapping map) | |
| 904 | (format t "~& - val = ") | |
| 905 | (print-modexp val)) | |
| 906 | (if val | |
| 907 | (progn | |
| 908 | (let ((pair (assq smod (modmorph-module map))) | |
| 909 | (nmod val)) | |
| 910 | (when *on-modexp-debug* | |
| 911 | (format t "~& - map pair : ") | |
| 912 | (format t "~& key : ")(print-modexp (car pair)) | |
| 913 | (format t "~& val : ")(print-modexp (cdr pair))) | |
| 914 | (if pair | |
| 915 | (rplacd pair val) | |
| 916 | (push (cons smod val) (modmorph-module map))) | |
| 917 | (setf (modmorph-module map) | |
| 918 | (append (modmorph-compute-submodule-mappings | |
| 919 | map mod smod) | |
| 920 | (modmorph-module map))) | |
| 921 | nmod)) | |
| 922 | ;; | |
| 923 | (let ((newmod (apply-modmorph me map smod))) | |
| 924 | ;; (add-canon-modexp me me) | |
| 925 | (add-modexp-eval me newmod) | |
| 926 | (setf (modmorph-module map) | |
| 927 | (cons (cons smod newmod) | |
| 928 | (modmorph-module map))) | |
| 929 | newmod)))))))) | |
| 930 | 930 | |
| 931 | 931 | (defvar *modmorph-expanded* nil) |
| 932 | 932 | |
| 933 | 933 | (defun modmorph-construct-name (map smod) |
| 934 | 934 | (cond ((modmorph-is-rename map) |
| 935 | (let ((s-name (module-name smod))) | |
| 936 | ;; smod can be a direct modexp. | |
| 937 | ;; Wed Mar 3 17:35:05 JST 1999 | |
| 938 | (cond ((modexp-is-parameter-theory s-name) | |
| 939 | (normalize-modexp `(,(parameter-theory-arg-name smod) | |
| 940 | "::" | |
| 941 | ,(modmorph-construct-name | |
| 942 | map | |
| 943 | (parameter-module-theory smod)) | |
| 944 | ,(parameter-module-context smod)))) | |
| 945 | (t (normalize-modexp | |
| 946 | (%rename* s-name | |
| 947 | (%rename-map (modmorph-name map))))) | |
| 948 | ))) | |
| 949 | (t (let ((*modmorph-expanded* nil)) | |
| 950 | (let ((val (modmorph-reconstruct-name map | |
| 951 | (if (module-p smod) | |
| 952 | (module-name smod) | |
| 953 | smod)))) | |
| 954 | (if (modexp-is-view val) | |
| 955 | (let ((val2 (target-of-view-arg val))) | |
| 956 | (if (module-p val2) | |
| 957 | (module-name val2) | |
| 958 | val2)) | |
| 959 | val)))))) | |
| 935 | (let ((s-name (module-name smod))) | |
| 936 | ;; smod can be a direct modexp. | |
| 937 | ;; Wed Mar 3 17:35:05 JST 1999 | |
| 938 | (cond ((modexp-is-parameter-theory s-name) | |
| 939 | (normalize-modexp `(,(parameter-theory-arg-name smod) | |
| 940 | "::" | |
| 941 | ,(modmorph-construct-name | |
| 942 | map | |
| 943 | (parameter-module-theory smod)) | |
| 944 | ,(parameter-module-context smod)))) | |
| 945 | (t (normalize-modexp | |
| 946 | (%rename* s-name | |
| 947 | (%rename-map (modmorph-name map))))) | |
| 948 | ))) | |
| 949 | (t (let ((*modmorph-expanded* nil)) | |
| 950 | (let ((val (modmorph-reconstruct-name map | |
| 951 | (if (module-p smod) | |
| 952 | (module-name smod) | |
| 953 | smod)))) | |
| 954 | (if (modexp-is-view val) | |
| 955 | (let ((val2 (target-of-view-arg val))) | |
| 956 | (if (module-p val2) | |
| 957 | (module-name val2) | |
| 958 | val2)) | |
| 959 | val)))))) | |
| 960 | 960 | |
| 961 | 961 | ;;; want result in canonical form |
| 962 | 962 | (defun modmorph-reconstruct-name (map me) |
| 972 | 972 | ;; |
| 973 | 973 | (when (modexp-is-?name? me) |
| 974 | 974 | (when *on-modexp-debug* |
| 975 | (format t "~& given modexp was ?name? ~a" me)) | |
| 975 | (format t "~% given modexp was ?name? ~a" me)) | |
| 976 | 976 | (setq me (?name-name me))) |
| 977 | 977 | (when (and (consp me) (equal (second me) "::")) |
| 978 | 978 | (setq me (third me))) |
| 979 | 979 | (cond ((or (module-p me) (stringp me)) |
| 980 | (when *on-modexp-debug* | |
| 981 | (if (stringp me) | |
| 982 | (format t "~& given modexp is string ~s" me) | |
| 983 | (progn (format t "~& given modexp is module object :") | |
| 984 | (print-chaos-object me)))) | |
| 985 | (let ((modval (eval-modexp me)) ; must be global (not argument). | |
| 986 | (modmap (modmorph-module map))) | |
| 987 | (when *on-modexp-debug* | |
| 988 | (format t "~& evaluated value is : ") | |
| 989 | (print-chaos-object modval)) | |
| 990 | (let ((im (assq modval modmap))) | |
| 991 | (when *on-modexp-debug* | |
| 992 | (if im | |
| 993 | (format t "~& evaluated modexp is mapped") | |
| 994 | (format t "~& evaluated modexp is NOT mapped"))) | |
| 995 | (if im | |
| 996 | (if (memq modval *modmorph-expanded*) | |
| 997 | (progn (when *on-modexp-debug* | |
| 998 | (format t "~& and already expanded.")) | |
| 999 | modval) | |
| 1000 | (progn | |
| 1001 | (when *on-modexp-debug* | |
| 1002 | (format t "~& but not yet expanded, reconstruct the target.")) | |
| 1003 | (push modval *modmorph-expanded*) | |
| 1004 | (modmorph-reconstruct-name map (cdr im)))) | |
| 1005 | (if (module-p me) | |
| 1006 | (let ((name (module-name me))) | |
| 1007 | (when *on-modexp-debug* | |
| 1008 | (format t "~& modexp was module object.")) | |
| 1009 | (if (modexp-is-simple-name name) | |
| 1010 | me | |
| 1011 | (modmorph-reconstruct-name map (module-name me)))) | |
| 1012 | (progn (when *on-modexp-debug* | |
| 1013 | (format t "~& modexp was string, returns as is.")) | |
| 1014 | me)))))) | |
| 1015 | ;; PLUS | |
| 1016 | ((int-plus-p me) | |
| 1017 | (when *on-modexp-debug* | |
| 1018 | (format t "~& modexp is internal plus.") | |
| 1019 | (pr-int-plus me)) | |
| 1020 | (make-int-plus :args | |
| 1021 | (mapcar #'(lambda (x) (modmorph-reconstruct-name map x)) | |
| 1022 | (int-plus-args me)))) | |
| 1023 | ((%is-plus me) | |
| 1024 | (when *on-modexp-debug* | |
| 1025 | (format t "~& modexp is plus, generate new modexp reconstructing args:") | |
| 1026 | (print-next) | |
| 1027 | (print-modexp me)) | |
| 1028 | (normalize-modexp | |
| 1029 | (%plus* (mapcar #'(lambda (x) (modmorph-reconstruct-name map x)) | |
| 1030 | (%plus-args me))))) | |
| 1031 | ||
| 1032 | ;; RENAME | |
| 1033 | ((int-rename-p me) | |
| 1034 | (when *on-modexp-debug* | |
| 1035 | (format t "~& modexp is iternal rename.") | |
| 1036 | (pr-int-rename me)) | |
| 1037 | (make-int-rename :module (modmorph-reconstruct-name map | |
| 1038 | (int-rename-module me)) | |
| 1039 | :sort-maps (int-rename-sort-maps me) | |
| 1040 | :op-maps (int-rename-op-maps me))) | |
| 1041 | ((%is-rename me) | |
| 1042 | (when *on-modexp-debug* | |
| 1043 | (format t "~& modexp is rename, generate new one reconstructing args.") | |
| 1044 | (print-next) | |
| 1045 | (print-modexp me)) | |
| 1046 | (normalize-modexp | |
| 1047 | (%rename* (modmorph-reconstruct-name map (%rename-module me)) | |
| 1048 | (%rename-map me)))) | |
| 1049 | ||
| 1050 | ;; INSTANTIATION | |
| 1051 | ((int-instantiation-p me) | |
| 1052 | (when *on-modexp-debug* | |
| 1053 | (format t "~& modexp is internal instantiation.") | |
| 1054 | (pr-int-instantiation me)) | |
| 1055 | (let ((modpar (int-instantiation-module me))) | |
| 1056 | (make-int-instantiation | |
| 1057 | :module (modmorph-reconstruct-name map modpar) | |
| 1058 | :args (let ((res nil)) | |
| 1059 | (dolist (arg (int-instantiation-args me) | |
| 1060 | (nreverse res)) | |
| 1061 | (push (modmorph-reconstruct-view-arg | |
| 1062 | (%!arg-name arg) | |
| 1063 | (%!arg-view arg) | |
| 1064 | map | |
| 1065 | modpar) | |
| 1066 | res)))))) | |
| 1067 | ;; | |
| 1068 | ((%is-instantiation me) | |
| 1069 | (when *on-modexp-debug* | |
| 1070 | (format t "~& modexp is instantiation, generate new one....") | |
| 1071 | (print-next) | |
| 1072 | (print-modexp me)) | |
| 1073 | (let* ((modpar (%instantiation-module me)) | |
| 1074 | (modparnm (if (module-p modpar) | |
| 1075 | (module-name modpar) | |
| 1076 | modpar))) | |
| 1077 | (%instantiation* (modmorph-reconstruct-name map modparnm) | |
| 1078 | (let ((res nil)) | |
| 1079 | (dolist (arg (%instantiation-args me)) | |
| 1080 | (push (modmorph-reconstruct-view-arg | |
| 1081 | (%!arg-name arg) ; name | |
| 1082 | (%!arg-view arg) ; view | |
| 1083 | map | |
| 1084 | modpar) | |
| 1085 | res)) | |
| 1086 | (nreverse res))))) | |
| 1087 | ||
| 1088 | ;; VIEW | |
| 1089 | ((view-p me) | |
| 1090 | (when *on-modexp-debug* | |
| 1091 | (format t "~& modexp is view structure, create new one.") | |
| 1092 | (print-next) | |
| 1093 | (print-modexp me)) | |
| 1094 | (let ((view (view-struct* (view-struct-name me)))) | |
| 1095 | (setf (view-struct-src view) (view-struct-src me)) | |
| 1096 | (setf (view-struct-target view) | |
| 1097 | (modmorph-reconstruct-name map (view-struct-target me))) | |
| 1098 | (setf (view-struct-sort-maps view) (view-struct-sort-maps me) | |
| 1099 | (view-struct-op-maps view) (view-struct-op-maps me)) | |
| 1100 | (setf (view-decl-form view) (view-decl-form me)) | |
| 1101 | view)) | |
| 1102 | ;; | |
| 1103 | (t (break "modmorph-reconstruct-name: missing case")) | |
| 1104 | )) | |
| 980 | (when *on-modexp-debug* | |
| 981 | (if (stringp me) | |
| 982 | (format t "~% given modexp is string ~s" me) | |
| 983 | (progn (format t "~% given modexp is module object :") | |
| 984 | (print-chaos-object me)))) | |
| 985 | (let ((modval (eval-modexp me)) ; must be global (not argument). | |
| 986 | (modmap (modmorph-module map))) | |
| 987 | (when *on-modexp-debug* | |
| 988 | (format t "~% evaluated value is : ") | |
| 989 | (print-chaos-object modval)) | |
| 990 | (let ((im (assq modval modmap))) | |
| 991 | (when *on-modexp-debug* | |
| 992 | (if im | |
| 993 | (format t "~& evaluated modexp is mapped") | |
| 994 | (format t "~& evaluated modexp is NOT mapped"))) | |
| 995 | (if im | |
| 996 | (if (memq modval *modmorph-expanded*) | |
| 997 | (progn (when *on-modexp-debug* | |
| 998 | (format t "~% and already expanded.")) | |
| 999 | modval) | |
| 1000 | (progn | |
| 1001 | (when *on-modexp-debug* | |
| 1002 | (format t "~% but not yet expanded, reconstruct the target.")) | |
| 1003 | (push modval *modmorph-expanded*) | |
| 1004 | (modmorph-reconstruct-name map (cdr im)))) | |
| 1005 | (if (module-p me) | |
| 1006 | (let ((name (module-name me))) | |
| 1007 | (when *on-modexp-debug* | |
| 1008 | (format t "~% modexp was module object.")) | |
| 1009 | (if (modexp-is-simple-name name) | |
| 1010 | me | |
| 1011 | (modmorph-reconstruct-name map (module-name me)))) | |
| 1012 | (progn (when *on-modexp-debug* | |
| 1013 | (format t "~% modexp was string, returns as is.")) | |
| 1014 | me)))))) | |
| 1015 | ;; PLUS | |
| 1016 | ((int-plus-p me) | |
| 1017 | (when *on-modexp-debug* | |
| 1018 | (format t "~% modexp is internal plus.") | |
| 1019 | (pr-int-plus me)) | |
| 1020 | (make-int-plus :args | |
| 1021 | (mapcar #'(lambda (x) (modmorph-reconstruct-name map x)) | |
| 1022 | (int-plus-args me)))) | |
| 1023 | ((%is-plus me) | |
| 1024 | (when *on-modexp-debug* | |
| 1025 | (format t "~% modexp is plus, generate new modexp reconstructing args:") | |
| 1026 | (print-next) | |
| 1027 | (print-modexp me)) | |
| 1028 | (normalize-modexp | |
| 1029 | (%plus* (mapcar #'(lambda (x) (modmorph-reconstruct-name map x)) | |
| 1030 | (%plus-args me))))) | |
| 1031 | ||
| 1032 | ;; RENAME | |
| 1033 | ((int-rename-p me) | |
| 1034 | (when *on-modexp-debug* | |
| 1035 | (format t "~% modexp is iternal rename.") | |
| 1036 | (pr-int-rename me)) | |
| 1037 | (make-int-rename :module (modmorph-reconstruct-name map | |
| 1038 | (int-rename-module me)) | |
| 1039 | :sort-maps (int-rename-sort-maps me) | |
| 1040 | :op-maps (int-rename-op-maps me))) | |
| 1041 | ((%is-rename me) | |
| 1042 | (when *on-modexp-debug* | |
| 1043 | (format t "~% modexp is rename, generate new one reconstructing args.") | |
| 1044 | (print-next) | |
| 1045 | (print-modexp me)) | |
| 1046 | (normalize-modexp | |
| 1047 | (%rename* (modmorph-reconstruct-name map (%rename-module me)) | |
| 1048 | (%rename-map me)))) | |
| 1049 | ||
| 1050 | ;; INSTANTIATION | |
| 1051 | ((int-instantiation-p me) | |
| 1052 | (when *on-modexp-debug* | |
| 1053 | (format t "~% modexp is internal instantiation.") | |
| 1054 | (pr-int-instantiation me)) | |
| 1055 | (let ((modpar (int-instantiation-module me))) | |
| 1056 | (make-int-instantiation | |
| 1057 | :module (modmorph-reconstruct-name map modpar) | |
| 1058 | :args (let ((res nil)) | |
| 1059 | (dolist (arg (int-instantiation-args me) | |
| 1060 | (nreverse res)) | |
| 1061 | (push (modmorph-reconstruct-view-arg | |
| 1062 | (%!arg-name arg) | |
| 1063 | (%!arg-view arg) | |
| 1064 | map | |
| 1065 | modpar) | |
| 1066 | res)))))) | |
| 1067 | ;; | |
| 1068 | ((%is-instantiation me) | |
| 1069 | (when *on-modexp-debug* | |
| 1070 | (format t "~% modexp is instantiation, generate new one....") | |
| 1071 | (print-next) | |
| 1072 | (print-modexp me)) | |
| 1073 | (let* ((modpar (%instantiation-module me)) | |
| 1074 | (modparnm (if (module-p modpar) | |
| 1075 | (module-name modpar) | |
| 1076 | modpar))) | |
| 1077 | (%instantiation* (modmorph-reconstruct-name map modparnm) | |
| 1078 | (let ((res nil)) | |
| 1079 | (dolist (arg (%instantiation-args me)) | |
| 1080 | (push (modmorph-reconstruct-view-arg | |
| 1081 | (%!arg-name arg) ; name | |
| 1082 | (%!arg-view arg) ; view | |
| 1083 | map | |
| 1084 | modpar) | |
| 1085 | res)) | |
| 1086 | (nreverse res))))) | |
| 1087 | ||
| 1088 | ;; VIEW | |
| 1089 | ((view-p me) | |
| 1090 | (when *on-modexp-debug* | |
| 1091 | (format t "~% modexp is view structure, create new one.") | |
| 1092 | (print-next) | |
| 1093 | (print-modexp me)) | |
| 1094 | (let ((view (view-struct* (view-struct-name me)))) | |
| 1095 | (setf (view-struct-src view) (view-struct-src me)) | |
| 1096 | (setf (view-struct-target view) | |
| 1097 | (modmorph-reconstruct-name map (view-struct-target me))) | |
| 1098 | (setf (view-struct-sort-maps view) (view-struct-sort-maps me) | |
| 1099 | (view-struct-op-maps view) (view-struct-op-maps me)) | |
| 1100 | (setf (view-decl-form view) (view-decl-form me)) | |
| 1101 | view)) | |
| 1102 | ;; | |
| 1103 | (t (break "modmorph-reconstruct-name: missing case")) | |
| 1104 | )) | |
| 1105 | 1105 | |
| 1106 | 1106 | (defun target-of-view-arg (vw) |
| 1107 | 1107 | (when (modexp-is-?name? vw) |
| 1108 | 1108 | (setq vw (?name-name vw))) |
| 1109 | 1109 | (cond ((stringp vw) vw) |
| 1110 | ((module-p vw) vw) | |
| 1111 | ((view-p vw) (view-target vw)) | |
| 1112 | ((%is-view vw) (%view-target vw)) | |
| 1113 | (t (break "target-of-view-arg: unknown view argument")) | |
| 1114 | )) | |
| 1110 | ((module-p vw) vw) | |
| 1111 | ((view-p vw) (view-target vw)) | |
| 1112 | ((%is-view vw) (%view-target vw)) | |
| 1113 | (t (break "target-of-view-arg: unknown view argument")) | |
| 1114 | )) | |
| 1115 | 1115 | |
| 1116 | 1116 | (eval-when (:execute :compile-toplevel :load-toplevel) |
| 1117 | 1117 | (declaim (type fixnum *anon-view-name*)) |
| 1128 | 1128 | (print-chaos-object vw) |
| 1129 | 1129 | (chaos-error 'panic))) |
| 1130 | 1130 | (let* ((tgt (target-of-view-arg vw)) |
| 1131 | (modmap (modmorph-module map)) | |
| 1132 | (val (assq tgt modmap)) | |
| 1133 | (mod (view-src vw))) | |
| 1131 | (modmap (modmorph-module map)) | |
| 1132 | (val (assq tgt modmap)) | |
| 1133 | (mod (view-src vw))) | |
| 1134 | 1134 | (when *on-modexp-debug* |
| 1135 | (format t "~&[reconstruct-view-arg]:arg-name=~a " arg-name) | |
| 1135 | (format t "~%[reconstruct-view-arg]:arg-name=~a " arg-name) | |
| 1136 | 1136 | (print-next) |
| 1137 | 1137 | (print-chaos-object vw) |
| 1138 | 1138 | (force-output)) |
| 1139 | 1139 | (let ((actual (or (cdr val) tgt))) |
| 1140 | 1140 | (let ((tmod (if (module-p actual) |
| 1141 | actual | |
| 1142 | (target-of-view-arg actual))) | |
| 1143 | (view (view-struct* (make-anon-view-name)))) | |
| 1144 | (when *on-modexp-debug* | |
| 1145 | (format t "~&- src = ")(print-chaos-object mod) | |
| 1146 | (format t "~&- tgt = ")(print-chaos-object tmod) | |
| 1147 | (unless tmod (break "Oh my God!"))) | |
| 1148 | (setf (view-src view) mod) | |
| 1149 | (setf (view-target view) tmod) | |
| 1150 | (setf (view-sort-maps view) | |
| 1151 | (modmorph-reconstruct-view-sort-mapping | |
| 1152 | tmod | |
| 1153 | map | |
| 1154 | (view-sort-maps vw))) | |
| 1155 | (setf (view-op-maps view) | |
| 1156 | (modmorph-reconstruct-view-op-mapping | |
| 1157 | tmod | |
| 1158 | map | |
| 1159 | (view-op-maps vw))) | |
| 1160 | (when *on-modexp-debug* | |
| 1161 | (format t "~&*result view=") | |
| 1162 | (print-chaos-object view)) | |
| 1163 | (%!arg* arg-name view))) | |
| 1141 | actual | |
| 1142 | (target-of-view-arg actual))) | |
| 1143 | (view (view-struct* (make-anon-view-name)))) | |
| 1144 | (when *on-modexp-debug* | |
| 1145 | (format t "~%- src = ")(print-chaos-object mod) | |
| 1146 | (format t "~&- tgt = ")(print-chaos-object tmod) | |
| 1147 | (unless tmod (break "Oh my God!"))) | |
| 1148 | (setf (view-src view) mod) | |
| 1149 | (setf (view-target view) tmod) | |
| 1150 | (setf (view-sort-maps view) | |
| 1151 | (modmorph-reconstruct-view-sort-mapping | |
| 1152 | tmod | |
| 1153 | map | |
| 1154 | (view-sort-maps vw))) | |
| 1155 | (setf (view-op-maps view) | |
| 1156 | (modmorph-reconstruct-view-op-mapping | |
| 1157 | tmod | |
| 1158 | map | |
| 1159 | (view-op-maps vw))) | |
| 1160 | (when *on-modexp-debug* | |
| 1161 | (format t "~%*result view=") | |
| 1162 | (print-chaos-object view)) | |
| 1163 | (%!arg* arg-name view))) | |
| 1164 | 1164 | )) |
| 1165 | 1165 | |
| 1166 | 1166 | (defun modmorph-reconstruct-view-sort-mapping (mod map s-maps) |
| 1167 | 1167 | (declare (ignore mod)) |
| 1168 | 1168 | (let ((res nil) |
| 1169 | (modmorph-sort-map (modmorph-sort map))) | |
| 1169 | (modmorph-sort-map (modmorph-sort map))) | |
| 1170 | 1170 | (dolist (s-map s-maps (nreverse res)) |
| 1171 | 1171 | (push (cons (car s-map) |
| 1172 | (modmorph-assoc-image modmorph-sort-map | |
| 1173 | (cdr s-map))) | |
| 1174 | res)))) | |
| 1172 | (modmorph-assoc-image modmorph-sort-map | |
| 1173 | (cdr s-map))) | |
| 1174 | res)))) | |
| 1175 | 1175 | |
| 1176 | 1176 | (defun modmorph-reconstruct-view-op-mapping (mod map o-maps) |
| 1177 | 1177 | (let ((res nil) |
| 1178 | (modmorph-op-map (modmorph-op map))) | |
| 1178 | (modmorph-op-map (modmorph-op map))) | |
| 1179 | 1179 | (dolist (o-map o-maps (nreverse res)) |
| 1180 | 1180 | (push (list (car o-map) |
| 1181 | (modmorph-apply-op-map-2 mod | |
| 1182 | map | |
| 1183 | modmorph-op-map | |
| 1184 | (cadr o-map))) | |
| 1185 | res)))) | |
| 1181 | (modmorph-apply-op-map-2 mod | |
| 1182 | map | |
| 1183 | modmorph-op-map | |
| 1184 | (cadr o-map))) | |
| 1185 | res)))) | |
| 1186 | 1186 | |
| 1187 | 1187 | ;;; op-mapping ::= (:simple . method) |
| 1188 | 1188 | ;;; | (:replacement List[psuedo var] term) |
| 1190 | 1190 | (defun apply-op-mapping-2 (module map op-mapping term) |
| 1191 | 1191 | (if (eq ':simple-map (car op-mapping)) |
| 1192 | 1192 | (make-term-check-op-with-sort-check (cdr op-mapping) |
| 1193 | (term-subterms term) | |
| 1194 | module) | |
| 1193 | (term-subterms term) | |
| 1194 | module) | |
| 1195 | 1195 | (with-in-module (module) |
| 1196 | (mapping-image-2 map (term-subterms term) (caddr op-mapping))))) | |
| 1196 | (mapping-image-2 map (term-subterms term) (caddr op-mapping))))) | |
| 1197 | 1197 | |
| 1198 | 1198 | (defun modmorph-apply-op-map-2 (module map op_map term) |
| 1199 | 1199 | (let ((val (assoc (term-head term) op_map))) |
| 1200 | 1200 | (if val |
| 1201 | (apply-op-mapping-2 module map (cdr val) term) | |
| 1202 | (let* ((op (term-head term)) | |
| 1203 | (om (method-module op)) | |
| 1204 | (as (assoc om (modmorph-module map)))) | |
| 1205 | (if (and as (cdr as) (not (eq (cdr as) om))) | |
| 1206 | (with-in-module (module) | |
| 1207 | (mapping-image-2 map (term-subterms term) term)) | |
| 1208 | term))))) | |
| 1201 | (apply-op-mapping-2 module map (cdr val) term) | |
| 1202 | (let* ((op (term-head term)) | |
| 1203 | (om (method-module op)) | |
| 1204 | (as (assoc om (modmorph-module map)))) | |
| 1205 | (if (and as (cdr as) (not (eq (cdr as) om))) | |
| 1206 | (with-in-module (module) | |
| 1207 | (mapping-image-2 map (term-subterms term) term)) | |
| 1208 | term))))) | |
| 1209 | 1209 | |
| 1210 | 1210 | |
| 1211 | 1211 | ;;; MODMORPH-COMPUTE-SUBMODULE-MAPPINGS: |
| 1212 | 1212 | ;;; |
| 1213 | 1213 | (defun modmorph-compute-submodule-mappings (map mod smod) |
| 1214 | 1214 | (when *on-modexp-debug* |
| 1215 | (format t "~&[modmorph-compute-submodule-mappings]:") | |
| 1215 | (format t "~%[modmorph-compute-submodule-mappings]:") | |
| 1216 | 1216 | (format t "~& - map = ") (print-mapping map) |
| 1217 | 1217 | (format t "~& - mod = ") (print-modexp mod) |
| 1218 | 1218 | (format t "~& - smod = ") (print-modexp smod)) |
| 1219 | 1219 | (let ((res nil) |
| 1220 | (modmap (modmorph-module map))) | |
| 1220 | (modmap (modmorph-module map))) | |
| 1221 | 1221 | (dolist (smp (module-submodules smod)) |
| 1222 | 1222 | (let ((sm (car smp))) |
| 1223 | (cond ((and (not (eq ':using (cdr smp))) | |
| 1224 | (modmorph-submodule-is-mapped modmap sm)) | |
| 1225 | (when *on-modexp-debug* | |
| 1226 | (format t "~& - sm = ") (print-modexp sm) | |
| 1227 | (format t " is mapped.")) | |
| 1228 | (setq res | |
| 1229 | (cons (cons sm | |
| 1230 | (eval-modexp (modmorph-construct-name | |
| 1231 | map | |
| 1232 | ;; (module-name sm) | |
| 1233 | sm))) | |
| 1234 | (append (modmorph-compute-submodule-mappings map mod sm) | |
| 1235 | res)))) | |
| 1236 | ;; | |
| 1237 | (t (let ((aval (assq sm modmap))) | |
| 1238 | (when *on-modexp-debug* | |
| 1239 | (format t "~& - aval(img) = ") (print-modexp (cdr aval))) | |
| 1240 | (when (and aval | |
| 1241 | (is-dummy-module (cdr aval))) | |
| 1242 | (let ((newm (eval-modexp | |
| 1243 | (modmorph-construct-name map | |
| 1244 | ;; (module-name sm) | |
| 1245 | sm)))) | |
| 1246 | #|| | |
| 1247 | (push (cons (cdr aval) newm) | |
| 1248 | (modmorph-module map)) | |
| 1249 | ||# | |
| 1250 | (rplacd aval newm)))))))) | |
| 1223 | (cond ((and (not (eq ':using (cdr smp))) | |
| 1224 | (modmorph-submodule-is-mapped modmap sm)) | |
| 1225 | (when *on-modexp-debug* | |
| 1226 | (format t "~% - sm = ") (print-modexp sm) | |
| 1227 | (format t " is mapped.")) | |
| 1228 | (setq res | |
| 1229 | (cons (cons sm | |
| 1230 | (eval-modexp (modmorph-construct-name | |
| 1231 | map | |
| 1232 | ;; (module-name sm) | |
| 1233 | sm))) | |
| 1234 | (append (modmorph-compute-submodule-mappings map mod sm) | |
| 1235 | res)))) | |
| 1236 | ;; | |
| 1237 | (t (let ((aval (assq sm modmap))) | |
| 1238 | (when *on-modexp-debug* | |
| 1239 | (format t "~& - aval(img) = ") (print-modexp (cdr aval))) | |
| 1240 | (when (and aval | |
| 1241 | (is-dummy-module (cdr aval))) | |
| 1242 | (let ((newm (eval-modexp | |
| 1243 | (modmorph-construct-name map | |
| 1244 | ;; (module-name sm) | |
| 1245 | sm)))) | |
| 1246 | #|| | |
| 1247 | (push (cons (cdr aval) newm) | |
| 1248 | (modmorph-module map)) | |
| 1249 | ||# | |
| 1250 | (rplacd aval newm)))))))) | |
| 1251 | 1251 | res)) |
| 1252 | 1252 | |
| 1253 | 1253 | ;;; ****************** |
| 1262 | 1262 | |
| 1263 | 1263 | (defun modmorph-recreate-sort (mod modmap sortmap sort) |
| 1264 | 1264 | (let ((sort-name (sort-id sort)) |
| 1265 | (smod (sort-module sort))) | |
| 1265 | (smod (sort-module sort))) | |
| 1266 | 1266 | (let* ((mmod (cdr (assq smod modmap))) |
| 1267 | (themod (if (and mmod (module-p mmod)) mmod mod)) | |
| 1268 | (asort (find sort-name (module-all-sorts mod) | |
| 1269 | :test #'(lambda (n s) | |
| 1270 | (and (equal n (sort-id s)) | |
| 1271 | (eq themod (sort-module s))))))) | |
| 1267 | (themod (if (and mmod (module-p mmod)) mmod mod)) | |
| 1268 | (asort (find sort-name (module-all-sorts mod) | |
| 1269 | :test #'(lambda (n s) | |
| 1270 | (and (equal n (sort-id s)) | |
| 1271 | (eq themod (sort-module s))))))) | |
| 1272 | 1272 | (when *on-modexp-debug* |
| 1273 | (format t "~&[modmorph-recreate-sort]:") | |
| 1274 | (format t "~&-- modmap = ") | |
| 1275 | (dolist (i modmap) | |
| 1276 | (print-next) | |
| 1277 | (print-modexp (car i)) (princ "-->") | |
| 1278 | (print-modexp (cdr i)) (princ " ")) | |
| 1279 | (format t "~&-- mod = ") (print-modexp mod) | |
| 1280 | (format t "~&-- thmod = ") (print-modexp themod) | |
| 1281 | (format t "~&-- sort-name = ~a" (string sort-name)) | |
| 1282 | (format t "~&-- smod = ") (print-modexp smod)) | |
| 1273 | (format t "~%[modmorph-recreate-sort]:") | |
| 1274 | (format t "~&-- modmap = ") | |
| 1275 | (dolist (i modmap) | |
| 1276 | (print-next) | |
| 1277 | (print-modexp (car i)) (princ "-->") | |
| 1278 | (print-modexp (cdr i)) (princ " ")) | |
| 1279 | (format t "~&-- mod = ") (print-modexp mod) | |
| 1280 | (format t "~&-- thmod = ") (print-modexp themod) | |
| 1281 | (format t "~&-- sort-name = ~a" (string sort-name)) | |
| 1282 | (format t "~&-- smod = ") (print-modexp smod)) | |
| 1283 | 1283 | ;; |
| 1284 | 1284 | (if asort |
| 1285 | asort | |
| 1286 | (let ((newsort (!recreate-sort themod sort))) | |
| 1287 | ;; | |
| 1288 | (when *on-modexp-debug* | |
| 1289 | (format t "~%* generated the new one!!!")) | |
| 1290 | (push (cons sort newsort) sortmap) | |
| 1291 | newsort) | |
| 1292 | )))) | |
| 1285 | asort | |
| 1286 | (let ((newsort (!recreate-sort themod sort))) | |
| 1287 | ;; | |
| 1288 | (when *on-modexp-debug* | |
| 1289 | (format t "~%* generated the new one!!!")) | |
| 1290 | (push (cons sort newsort) sortmap) | |
| 1291 | newsort) | |
| 1292 | )))) | |
| 1293 | 1293 | |
| 1294 | 1294 | ;;;----------------------------------------------------------------------------- |
| 1295 | 1295 | ;;; MODMORPH-RECREATE-SORT-RELATIONS |
| 1297 | 1297 | |
| 1298 | 1298 | (defun modmorph-recreate-sort-relations (module oldmod modmap sortmap sort-relations) |
| 1299 | 1299 | (macrolet ((reduce-sort-set (x) |
| 1300 | ` (let (($$res nil)) | |
| 1301 | (dolist (e ,x) (unless (memq e $$res) (push e $$res))) | |
| 1302 | (nreverse $$res)))) | |
| 1300 | ` (let (($$res nil)) | |
| 1301 | (dolist (e ,x) (unless (memq e $$res) (push e $$res))) | |
| 1302 | (nreverse $$res)))) | |
| 1303 | 1303 | (let ((res nil)) |
| 1304 | 1304 | (dolist (rel sort-relations) |
| 1305 | (let ((rel (elim-sys-sorts-from-relation rel))) | |
| 1306 | (when rel (push rel res)))) | |
| 1305 | (let ((rel (elim-sys-sorts-from-relation rel))) | |
| 1306 | (when rel (push rel res)))) | |
| 1307 | 1307 | (mapcar #'(lambda (sl) |
| 1308 | (let ((srt (modmorph-sort-image-create | |
| 1309 | module oldmod modmap sortmap | |
| 1310 | (sort-relation-sort sl))) | |
| 1311 | (subs (reduce-sort-set | |
| 1312 | (modmorph-sorts-image-create module oldmod modmap | |
| 1313 | sortmap (_subsorts | |
| 1314 | sl)))) | |
| 1315 | (sups (reduce-sort-set | |
| 1316 | (modmorph-sorts-image-create module oldmod modmap | |
| 1317 | sortmap (_supersorts | |
| 1318 | sl))))) | |
| 1319 | (make-sort-relation srt subs sups))) | |
| 1320 | res)))) | |
| 1308 | (let ((srt (modmorph-sort-image-create | |
| 1309 | module oldmod modmap sortmap | |
| 1310 | (sort-relation-sort sl))) | |
| 1311 | (subs (reduce-sort-set | |
| 1312 | (modmorph-sorts-image-create module oldmod modmap | |
| 1313 | sortmap (_subsorts | |
| 1314 | sl)))) | |
| 1315 | (sups (reduce-sort-set | |
| 1316 | (modmorph-sorts-image-create module oldmod modmap | |
| 1317 | sortmap (_supersorts | |
| 1318 | sl))))) | |
| 1319 | (make-sort-relation srt subs sups))) | |
| 1320 | res)))) | |
| 1321 | 1321 | |
| 1322 | 1322 | ;; *NOTE* assume all of the system generated sorts are eliminated. |
| 1323 | 1323 | |
| 1325 | 1325 | (dolist (x sl1) |
| 1326 | 1326 | (let ((rel (assq (sort-relation-sort x) sl2))) |
| 1327 | 1327 | (if rel |
| 1328 | (progn | |
| 1329 | (setf (_subsorts rel) (union (_subsorts x) (_subsorts rel) | |
| 1330 | :test #'eq)) | |
| 1331 | (setf (_supersorts rel) (union (_supersorts x) (_supersorts rel) | |
| 1332 | :test #'eq))) | |
| 1333 | (push x sl2)))) | |
| 1328 | (progn | |
| 1329 | (setf (_subsorts rel) (union (_subsorts x) (_subsorts rel) | |
| 1330 | :test #'eq)) | |
| 1331 | (setf (_supersorts rel) (union (_supersorts x) (_supersorts rel) | |
| 1332 | :test #'eq))) | |
| 1333 | (push x sl2)))) | |
| 1334 | 1334 | sl2) |
| 1335 | ||
| 1335 | ||
| 1336 | 1336 | ;;; |
| 1337 | 1337 | ;;; |
| 1338 | 1338 | (defun modmorph-sort-image-create (module oldmod modmap sortmap sort) |
| 1339 | 1339 | (let ((s1 (modmorph-assoc-image sortmap sort))) |
| 1340 | 1340 | (if (not (eq s1 sort)) |
| 1341 | s1 | |
| 1342 | (if (is-dummy-module (sort-module sort)) | |
| 1343 | (let* ((mod (sort-module sort)) | |
| 1344 | (info (get-rename-info mod)) | |
| 1345 | (oldmod (car info)) | |
| 1346 | (modim (cdr (assq oldmod modmap)))) | |
| 1347 | (if modim | |
| 1348 | (let ((val (let ((asrt | |
| 1349 | (modmorph-find-sort-in modim (sort-id sort)))) | |
| 1350 | (if asrt asrt | |
| 1351 | (if (or (eq sort *universal-sort*) | |
| 1352 | (eq sort *huniversal-sort*) | |
| 1353 | (eq sort *bool-sort*) | |
| 1354 | (eq sort *sort-error*)) | |
| 1355 | sort | |
| 1356 | nil))))) | |
| 1357 | (if val | |
| 1358 | val | |
| 1359 | (progn | |
| 1360 | (setf (sort-module sort) modim) | |
| 1361 | (add-sort-to-module sort modim) | |
| 1362 | sort))) | |
| 1363 | sort)) | |
| 1364 | (if (not (eq oldmod (sort-module sort))) | |
| 1365 | sort | |
| 1366 | (let ((newsort (modmorph-recreate-sort module | |
| 1367 | modmap | |
| 1368 | sortmap | |
| 1369 | sort))) | |
| 1370 | (add-sort-to-module newsort module) | |
| 1371 | newsort)))))) | |
| 1341 | s1 | |
| 1342 | (if (is-dummy-module (sort-module sort)) | |
| 1343 | (let* ((mod (sort-module sort)) | |
| 1344 | (info (get-rename-info mod)) | |
| 1345 | (oldmod (car info)) | |
| 1346 | (modim (cdr (assq oldmod modmap)))) | |
| 1347 | (if modim | |
| 1348 | (let ((val (let ((asrt | |
| 1349 | (modmorph-find-sort-in modim (sort-id sort)))) | |
| 1350 | (if asrt asrt | |
| 1351 | (if (or (eq sort *universal-sort*) | |
| 1352 | (eq sort *huniversal-sort*) | |
| 1353 | (eq sort *bool-sort*) | |
| 1354 | (eq sort *sort-error*)) | |
| 1355 | sort | |
| 1356 | nil))))) | |
| 1357 | (if val | |
| 1358 | val | |
| 1359 | (progn | |
| 1360 | (setf (sort-module sort) modim) | |
| 1361 | (add-sort-to-module sort modim) | |
| 1362 | sort))) | |
| 1363 | sort)) | |
| 1364 | (if (not (eq oldmod (sort-module sort))) | |
| 1365 | sort | |
| 1366 | (let ((newsort (modmorph-recreate-sort module | |
| 1367 | modmap | |
| 1368 | sortmap | |
| 1369 | sort))) | |
| 1370 | (add-sort-to-module newsort module) | |
| 1371 | newsort)))))) | |
| 1372 | 1372 | |
| 1373 | 1373 | (defun modmorph-sorts-image-create (module oldmod modmap sortmap sortlist) |
| 1374 | 1374 | (let ((img (mapcar #'(lambda (x) (modmorph-sort-image-create module |
| 1375 | oldmod | |
| 1376 | modmap | |
| 1377 | sortmap | |
| 1378 | x)) | |
| 1379 | sortlist))) | |
| 1375 | oldmod | |
| 1376 | modmap | |
| 1377 | sortmap | |
| 1378 | x)) | |
| 1379 | sortlist))) | |
| 1380 | 1380 | img)) |
| 1381 | 1381 | |
| 1382 | 1382 | ;;; sort should already exist |
| 1384 | 1384 | (defun modmorph-sort-image (module sortmap sort) |
| 1385 | 1385 | (let ((s1 (modmorph-assoc-image sortmap sort))) |
| 1386 | 1386 | (if (or (memq s1 (module-all-sorts module)) |
| 1387 | (memq s1 (module-error-sorts module))) | |
| 1388 | s1 | |
| 1387 | (memq s1 (module-error-sorts module))) | |
| 1388 | s1 | |
| 1389 | 1389 | (let ((val (if (err-sort-p sort) |
| 1390 | (find-compatible-err-sort sort module sortmap) | |
| 1391 | (find-sort-in module (sort-id s1))))) | |
| 1392 | ;; (break) | |
| 1390 | (find-compatible-err-sort sort module sortmap) | |
| 1391 | (find-sort-in module (sort-id s1))))) | |
| 1392 | ;; (break) | |
| 1393 | 1393 | (if val |
| 1394 | val | |
| 1395 | (if (or (eq sort *universal-sort*) | |
| 1396 | (eq sort *huniversal-sort*) | |
| 1397 | (eq sort *bool-sort*) | |
| 1398 | (eq sort *sort-error*)) | |
| 1399 | sort | |
| 1400 | (unless (err-sort-p s1) | |
| 1401 | (with-output-chaos-warning () | |
| 1402 | (format t "image sort ~a not found in module " | |
| 1403 | (string (sort-id s1))) | |
| 1404 | (print-chaos-object module) | |
| 1405 | ;; (break) | |
| 1406 | (return-from modmorph-sort-image nil))) | |
| 1407 | ))) | |
| 1408 | ))) | |
| 1394 | val | |
| 1395 | (if (or (eq sort *universal-sort*) | |
| 1396 | (eq sort *huniversal-sort*) | |
| 1397 | (eq sort *bool-sort*) | |
| 1398 | (eq sort *sort-error*)) | |
| 1399 | sort | |
| 1400 | (unless (err-sort-p s1) | |
| 1401 | (with-output-chaos-warning () | |
| 1402 | (format t "image sort ~a not found in module " | |
| 1403 | (string (sort-id s1))) | |
| 1404 | (print-chaos-object module) | |
| 1405 | ;; (break) | |
| 1406 | (return-from modmorph-sort-image nil))) | |
| 1407 | ))) | |
| 1408 | ))) | |
| 1409 | 1409 | |
| 1410 | 1410 | (defun modmorph-sorts-image (module sortmap sortlist) |
| 1411 | 1411 | (mapcar #'(lambda (x) (modmorph-sort-image module sortmap x)) |
| 1412 | sortlist)) | |
| 1412 | sortlist)) | |
| 1413 | 1413 | |
| 1414 | 1414 | ;;; OPERATORS |
| 1415 | 1415 | |
| 1419 | 1419 | |
| 1420 | 1420 | (defun modmorph-recreate-method (oldmodule module sortmap method) |
| 1421 | 1421 | (when (or (not (method-is-error-method method)) |
| 1422 | (method-is-user-defined-error-method method)) | |
| 1422 | (method-is-user-defined-error-method method)) | |
| 1423 | 1423 | (let ((op-symbol (method-symbol method)) |
| 1424 | (arity (modmorph-sorts-image module | |
| 1425 | sortmap | |
| 1426 | (method-arity method))) | |
| 1427 | (coarity (modmorph-sort-image module | |
| 1428 | sortmap | |
| 1429 | (method-coarity method)))) | |
| 1424 | (arity (modmorph-sorts-image module | |
| 1425 | sortmap | |
| 1426 | (method-arity method))) | |
| 1427 | (coarity (modmorph-sort-image module | |
| 1428 | sortmap | |
| 1429 | (method-coarity method)))) | |
| 1430 | 1430 | (let ((val (find-method-in module op-symbol arity coarity))) |
| 1431 | (when *on-modexp-debug* | |
| 1432 | (when val | |
| 1433 | ;; (break) | |
| 1434 | (format t "~&[modmorph-recreate-method] :") | |
| 1435 | (format t "~&-method image is already in module ") | |
| 1436 | (print-chaos-object method))) | |
| 1437 | (if val | |
| 1438 | (modmorph-recreate-method-aux-2 oldmodule module sortmap val) | |
| 1439 | (modmorph-recreate-method-aux-1 oldmodule | |
| 1440 | module | |
| 1441 | method | |
| 1442 | op-symbol | |
| 1443 | arity | |
| 1444 | coarity | |
| 1445 | sortmap)) | |
| 1446 | )))) | |
| 1431 | (when *on-modexp-debug* | |
| 1432 | (when val | |
| 1433 | ;; (break) | |
| 1434 | (format t "~%[modmorph-recreate-method] :") | |
| 1435 | (format t "~&-method image is already in module ") | |
| 1436 | (print-chaos-object method))) | |
| 1437 | (if val | |
| 1438 | (modmorph-recreate-method-aux-2 oldmodule module sortmap val) | |
| 1439 | (modmorph-recreate-method-aux-1 oldmodule | |
| 1440 | module | |
| 1441 | method | |
| 1442 | op-symbol | |
| 1443 | arity | |
| 1444 | coarity | |
| 1445 | sortmap)) | |
| 1446 | )))) | |
| 1447 | 1447 | |
| 1448 | 1448 | (defun modmorph-recreate-method-aux-1 (oldmodule module |
| 1449 | method | |
| 1450 | op-symbol | |
| 1451 | arity | |
| 1452 | coarity | |
| 1453 | sort-map) | |
| 1449 | method | |
| 1450 | op-symbol | |
| 1451 | arity | |
| 1452 | coarity | |
| 1453 | sort-map) | |
| 1454 | 1454 | (recreate-method oldmodule method module op-symbol arity coarity sort-map) |
| 1455 | 1455 | ) |
| 1456 | 1456 | |
| 1463 | 1463 | (let ((minfo (module-opinfo-table mod))) |
| 1464 | 1464 | (dolist (method (opinfo-methods opinfo)) |
| 1465 | 1465 | (let ((thy (method-theory method minfo))) |
| 1466 | (when thy | |
| 1467 | (setf (method-theory method minfo) | |
| 1468 | (cond ((theory-contains-identity thy) | |
| 1469 | (let ((zero (theory-zero thy))) | |
| 1470 | (if zero | |
| 1471 | (progn | |
| 1472 | ;; (break) ; | |
| 1473 | (theory-make | |
| 1474 | (theory-info thy) | |
| 1475 | (let ((srtmap (modmorph-sort map)) | |
| 1476 | (opmap (modmorph-op map)) | |
| 1477 | (modmap (modmorph-module map)) | |
| 1478 | (idinf (if (eq '%to-rename | |
| 1479 | (car zero)) | |
| 1480 | (cdr zero) | |
| 1481 | zero))) | |
| 1482 | (cons (modmorph-recreate-term mod | |
| 1483 | srtmap | |
| 1484 | opmap | |
| 1485 | modmap | |
| 1486 | (car idinf)) | |
| 1487 | (cdr idinf))))) | |
| 1488 | thy))) | |
| 1489 | (t thy))) | |
| 1490 | (compute-method-theory-info-for-matching method minfo)) | |
| 1491 | ) ; dolist | |
| 1466 | (when thy | |
| 1467 | (setf (method-theory method minfo) | |
| 1468 | (cond ((theory-contains-identity thy) | |
| 1469 | (let ((zero (theory-zero thy))) | |
| 1470 | (if zero | |
| 1471 | (progn | |
| 1472 | ;; (break) ; | |
| 1473 | (theory-make | |
| 1474 | (theory-info thy) | |
| 1475 | (let ((srtmap (modmorph-sort map)) | |
| 1476 | (opmap (modmorph-op map)) | |
| 1477 | (modmap (modmorph-module map)) | |
| 1478 | (idinf (if (eq '%to-rename | |
| 1479 | (car zero)) | |
| 1480 | (cdr zero) | |
| 1481 | zero))) | |
| 1482 | (cons (modmorph-recreate-term mod | |
| 1483 | srtmap | |
| 1484 | opmap | |
| 1485 | modmap | |
| 1486 | (car idinf)) | |
| 1487 | (cdr idinf))))) | |
| 1488 | thy))) | |
| 1489 | (t thy))) | |
| 1490 | (compute-method-theory-info-for-matching method minfo)) | |
| 1491 | ) ; dolist | |
| 1492 | 1492 | ))) |
| 1493 | 1493 | |
| 1494 | 1494 | ;;; TERMS |
| 1501 | 1501 | ;;; *VIEW-FROM???? |
| 1502 | 1502 | (defun modmorph-recreate-term (module sortmap opmap modmap term) |
| 1503 | 1503 | (cond ((term-is-an-error term) term) |
| 1504 | ((term-is-builtin-constant? term) | |
| 1505 | (make-bconst-term (modmorph-sort-image module | |
| 1506 | sortmap | |
| 1507 | (term-sort term)) | |
| 1508 | (term-builtin-value term))) | |
| 1509 | ((term-is-lisp-form? term) term) | |
| 1510 | ((term-is-variable? term) | |
| 1511 | (when *on-modexp-debug* | |
| 1512 | (format t "~&[modmorph-recreate-term] finding variable ~a of sort ~a" | |
| 1513 | (variable-name term) | |
| 1514 | (sort-name (variable-sort term)))) | |
| 1515 | ;; the operator should always be found | |
| 1516 | (let ((var-name (variable-name term))) | |
| 1517 | (let ((img-sort (modmorph-sort-image module | |
| 1518 | sortmap | |
| 1519 | (variable-sort term)))) | |
| 1520 | (let ((val2 (find-if #'(lambda (x) | |
| 1521 | (and (equal var-name (variable-name x)) | |
| 1522 | (sort= img-sort (variable-sort x)))) | |
| 1523 | *modmorph-local-vars*))) | |
| 1524 | (if val2 | |
| 1525 | (progn (when *on-modexp-debug* | |
| 1526 | (format t "~& variable found.")) | |
| 1527 | val2) | |
| 1528 | (let ((new-var (make-variable-term img-sort var-name))) | |
| 1529 | (when *on-modexp-debug* | |
| 1530 | (format t "~& variable not found in *modmorph-local-vars*")) | |
| 1531 | (push new-var *modmorph-local-vars*) | |
| 1532 | new-var)))) | |
| 1533 | )) | |
| 1534 | (t (let ((head (term-head term)) | |
| 1535 | (new-head nil)) | |
| 1536 | ;; look in the mapping | |
| 1537 | (when *on-modexp-debug* | |
| 1538 | (format t "~&[modmorph-recreate-term]: looking for image of ") | |
| 1539 | (print-method head)) | |
| 1540 | ;; | |
| 1541 | (let ((val (assoc head opmap))) | |
| 1542 | (if val | |
| 1543 | (progn | |
| 1544 | (when *on-modexp-debug* | |
| 1545 | (format t "~% found the image in map.") | |
| 1546 | (print-chaos-object (cddr val))) | |
| 1547 | (if (eq :replacement (second val)) | |
| 1548 | (progn (setq term (apply-op-mapping module | |
| 1549 | (cdr val) | |
| 1550 | term)) | |
| 1551 | (setq new-head (term-head term))) | |
| 1552 | (setq new-head (cddr val)))) | |
| 1553 | (when *on-modexp-debug* | |
| 1554 | (format t "~& image not found in map.") | |
| 1555 | )) | |
| 1556 | (unless new-head | |
| 1557 | ;; method is not mapped | |
| 1558 | (if (method-is-error-method head) | |
| 1559 | (setq new-head | |
| 1560 | (modmorph-find-error-method module | |
| 1561 | head | |
| 1562 | opmap | |
| 1563 | sortmap)) | |
| 1564 | (let ((aval (assoc (method-module head) modmap))) | |
| 1565 | (setq new-head | |
| 1566 | (if (not aval) | |
| 1567 | head | |
| 1568 | (let ((lookmod | |
| 1569 | (if (module-p (cdr aval)) | |
| 1570 | (cdr aval) | |
| 1571 | (if (view-p (cdr aval)) | |
| 1572 | (view-target (cdr aval)) | |
| 1573 | (cdr aval))))) | |
| 1574 | (find-method-in | |
| 1575 | lookmod | |
| 1576 | (method-symbol head) | |
| 1577 | (modmorph-sorts-image lookmod | |
| 1578 | sortmap | |
| 1579 | (method-arity head)) | |
| 1580 | (modmorph-sort-image lookmod | |
| 1581 | sortmap | |
| 1582 | (method-coarity head))) | |
| 1583 | )))))) | |
| 1584 | ;; | |
| 1585 | (unless new-head | |
| 1586 | (with-output-chaos-error ('no-such-operator) | |
| 1587 | (princ "mapping image of operator: ") | |
| 1588 | (with-in-module ((method-module head)) | |
| 1589 | (print-method-internal head)) | |
| 1590 | (print-next) | |
| 1591 | (princ "of module ") | |
| 1592 | (print-chaos-object (method-module head)) | |
| 1593 | (print-next) | |
| 1594 | (princ "was not found in the module ") | |
| 1595 | (print-chaos-object module) | |
| 1596 | )) | |
| 1597 | ;; | |
| 1598 | (if (term-is-builtin-constant? term) | |
| 1599 | term | |
| 1600 | (make-term-check-op-with-sort-check | |
| 1601 | new-head | |
| 1602 | (mapcar #'(lambda (tm) | |
| 1603 | (modmorph-recreate-term module | |
| 1604 | sortmap | |
| 1605 | opmap | |
| 1606 | modmap | |
| 1607 | tm)) | |
| 1608 | (term-subterms term)) | |
| 1609 | module)) | |
| 1610 | ))))) | |
| 1504 | ((term-is-builtin-constant? term) | |
| 1505 | (make-bconst-term (modmorph-sort-image module | |
| 1506 | sortmap | |
| 1507 | (term-sort term)) | |
| 1508 | (term-builtin-value term))) | |
| 1509 | ((term-is-lisp-form? term) term) | |
| 1510 | ((term-is-variable? term) | |
| 1511 | (when *on-modexp-debug* | |
| 1512 | (format t "~%[modmorph-recreate-term] finding variable ~a of sort ~a" | |
| 1513 | (variable-name term) | |
| 1514 | (sort-name (variable-sort term)))) | |
| 1515 | ;; the operator should always be found | |
| 1516 | (let ((var-name (variable-name term))) | |
| 1517 | (let ((img-sort (modmorph-sort-image module | |
| 1518 | sortmap | |
| 1519 | (variable-sort term)))) | |
| 1520 | (let ((val2 (find-if #'(lambda (x) | |
| 1521 | (and (equal var-name (variable-name x)) | |
| 1522 | (sort= img-sort (variable-sort x)))) | |
| 1523 | *modmorph-local-vars*))) | |
| 1524 | (if val2 | |
| 1525 | (progn (when *on-modexp-debug* | |
| 1526 | (format t "~% variable found.")) | |
| 1527 | val2) | |
| 1528 | (let ((new-var (make-variable-term img-sort var-name))) | |
| 1529 | (when *on-modexp-debug* | |
| 1530 | (format t "~% variable not found in *modmorph-local-vars*")) | |
| 1531 | (push new-var *modmorph-local-vars*) | |
| 1532 | new-var)))) | |
| 1533 | )) | |
| 1534 | (t (let ((head (term-head term)) | |
| 1535 | (new-head nil)) | |
| 1536 | ;; look in the mapping | |
| 1537 | (when *on-modexp-debug* | |
| 1538 | (format t "~%[modmorph-recreate-term]: looking for image of ") | |
| 1539 | (print-method head)) | |
| 1540 | ;; | |
| 1541 | (let ((val (assoc head opmap))) | |
| 1542 | (if val | |
| 1543 | (progn | |
| 1544 | (when *on-modexp-debug* | |
| 1545 | (format t "~% found the image in map.") | |
| 1546 | (print-chaos-object (cddr val))) | |
| 1547 | (if (eq :replacement (second val)) | |
| 1548 | (progn (setq term (apply-op-mapping module | |
| 1549 | (cdr val) | |
| 1550 | term)) | |
| 1551 | (setq new-head (term-head term))) | |
| 1552 | (setq new-head (cddr val)))) | |
| 1553 | (when *on-modexp-debug* | |
| 1554 | (format t "~% image not found in map."))) | |
| 1555 | (unless new-head | |
| 1556 | ;; method is not mapped | |
| 1557 | (if (method-is-error-method head) | |
| 1558 | (setq new-head | |
| 1559 | (modmorph-find-error-method module | |
| 1560 | head | |
| 1561 | opmap | |
| 1562 | sortmap)) | |
| 1563 | (let ((aval (assoc (method-module head) modmap))) | |
| 1564 | (setq new-head | |
| 1565 | (if (not aval) | |
| 1566 | head | |
| 1567 | (let ((lookmod | |
| 1568 | (if (module-p (cdr aval)) | |
| 1569 | (cdr aval) | |
| 1570 | (if (view-p (cdr aval)) | |
| 1571 | (view-target (cdr aval)) | |
| 1572 | (cdr aval))))) | |
| 1573 | (find-method-in | |
| 1574 | lookmod | |
| 1575 | (method-symbol head) | |
| 1576 | (modmorph-sorts-image lookmod | |
| 1577 | sortmap | |
| 1578 | (method-arity head)) | |
| 1579 | (modmorph-sort-image lookmod | |
| 1580 | sortmap | |
| 1581 | (method-coarity head))) | |
| 1582 | )))))) | |
| 1583 | ;; | |
| 1584 | (unless new-head | |
| 1585 | (with-output-chaos-error ('no-such-operator) | |
| 1586 | (princ "mapping image of operator: ") | |
| 1587 | (with-in-module ((method-module head)) | |
| 1588 | (print-method-internal head)) | |
| 1589 | (print-next) | |
| 1590 | (princ "of module ") | |
| 1591 | (print-chaos-object (method-module head)) | |
| 1592 | (print-next) | |
| 1593 | (princ "was not found in the module ") | |
| 1594 | (print-chaos-object module) | |
| 1595 | )) | |
| 1596 | ;; | |
| 1597 | (if (term-is-builtin-constant? term) | |
| 1598 | term | |
| 1599 | (make-term-check-op-with-sort-check | |
| 1600 | new-head | |
| 1601 | (mapcar #'(lambda (tm) | |
| 1602 | (modmorph-recreate-term module | |
| 1603 | sortmap | |
| 1604 | opmap | |
| 1605 | modmap | |
| 1606 | tm)) | |
| 1607 | (term-subterms term)) | |
| 1608 | module)) | |
| 1609 | ))))) | |
| 1611 | 1610 | |
| 1612 | 1611 | ;;; AXIOMS |
| 1613 | 1612 | |
| 1620 | 1619 | (with-in-module (module) |
| 1621 | 1620 | (let ((*modmorph-local-vars* nil)) |
| 1622 | 1621 | (make-rule :lhs (modmorph-recreate-term module |
| 1623 | sortmap | |
| 1624 | opmap | |
| 1625 | modmap | |
| 1626 | (axiom-lhs ax)) | |
| 1627 | :rhs (modmorph-recreate-term module | |
| 1628 | sortmap | |
| 1629 | opmap | |
| 1630 | modmap | |
| 1631 | (axiom-rhs ax)) | |
| 1632 | :condition (if (is-true? (axiom-condition ax)) | |
| 1633 | *bool-true* | |
| 1634 | (modmorph-recreate-term | |
| 1635 | module | |
| 1636 | sortmap | |
| 1637 | opmap | |
| 1638 | modmap | |
| 1639 | (axiom-condition ax))) | |
| 1640 | :labels (axiom-labels ax) | |
| 1641 | :behavioural (axiom-is-behavioural ax) | |
| 1642 | :type (axiom-type ax) | |
| 1643 | :kind (axiom-kind ax) | |
| 1644 | :meta-and-or (axiom-meta-and-or ax))))) | |
| 1622 | sortmap | |
| 1623 | opmap | |
| 1624 | modmap | |
| 1625 | (axiom-lhs ax)) | |
| 1626 | :rhs (modmorph-recreate-term module | |
| 1627 | sortmap | |
| 1628 | opmap | |
| 1629 | modmap | |
| 1630 | (axiom-rhs ax)) | |
| 1631 | :condition (if (is-true? (axiom-condition ax)) | |
| 1632 | *bool-true* | |
| 1633 | (modmorph-recreate-term | |
| 1634 | module | |
| 1635 | sortmap | |
| 1636 | opmap | |
| 1637 | modmap | |
| 1638 | (axiom-condition ax))) | |
| 1639 | :labels (axiom-labels ax) | |
| 1640 | :behavioural (axiom-is-behavioural ax) | |
| 1641 | :type (axiom-type ax) | |
| 1642 | :kind (axiom-kind ax) | |
| 1643 | :meta-and-or (axiom-meta-and-or ax))))) | |
| 1645 | 1644 | |
| 1646 | 1645 | ;;; ******************* |
| 1647 | 1646 | ;;; MISC MODMORPH UTILS_________________________________________________________ |
| 1653 | 1652 | |
| 1654 | 1653 | (defun modmorph-merge (m1 m2 &optional (warn t)) |
| 1655 | 1654 | (let ((nm1 (modmorph-name m1)) |
| 1656 | (nm2 (modmorph-name m2))) | |
| 1655 | (nm2 (modmorph-name m2))) | |
| 1657 | 1656 | (create-modmorph |
| 1658 | 1657 | ;; name will need to be used for memoization |
| 1659 | 1658 | ;; the assumption here is that basic mappings have names like: |
| 1660 | 1659 | ;; (map th vw) |
| 1661 | 1660 | ;; and that other names are create by this routine |
| 1662 | 1661 | (append (if (atom (car nm1)) (list nm1) nm1) |
| 1663 | (if (atom (car nm2)) (list nm2) nm2)) | |
| 1662 | (if (atom (car nm2)) (list nm2) nm2)) | |
| 1664 | 1663 | (modmorph-merge-assoc (modmorph-sort m1) (modmorph-sort m2) warn) |
| 1665 | 1664 | (modmorph-merge-op-assoc (modmorph-op m1) (modmorph-op m2) warn) |
| 1666 | 1665 | (modmorph-merge-assoc (modmorph-module m1) (modmorph-module m2) warn)) |
| 1670 | 1669 | (let ((res a2)) |
| 1671 | 1670 | (dolist (m a1) |
| 1672 | 1671 | (let ((im (assq (car m) a2))) |
| 1673 | (if (and im | |
| 1674 | (not (eq (car m) (cdr m)))) | |
| 1675 | (progn | |
| 1676 | (unless (eq (cdr im) (cdr m)) | |
| 1677 | (when warn | |
| 1678 | (with-output-chaos-warning () | |
| 1679 | (princ "instantiating module, ") | |
| 1680 | (print-next) | |
| 1681 | (princ "combined view has inconsistent mappings for: ") | |
| 1682 | (let ((*print-indent* (+ *print-indent* 2))) | |
| 1683 | (print-next) | |
| 1684 | (print-chaos-object (car m))) | |
| 1685 | (print-next) | |
| 1686 | (princ "target images are: ") | |
| 1687 | (let ((*print-indent* (+ *print-indent* 2))) | |
| 1688 | (print-next) | |
| 1689 | (print-chaos-object (cdr m)) | |
| 1690 | (print-next) | |
| 1691 | (print-chaos-object (cdr im))) | |
| 1692 | ))) | |
| 1693 | ;; (push (cons (car m) (cdr im)) res) | |
| 1694 | ) | |
| 1695 | (push m res)) | |
| 1696 | )) | |
| 1672 | (if (and im | |
| 1673 | (not (eq (car m) (cdr m)))) | |
| 1674 | (progn | |
| 1675 | (unless (eq (cdr im) (cdr m)) | |
| 1676 | (when warn | |
| 1677 | (with-output-chaos-warning () | |
| 1678 | (princ "instantiating module, ") | |
| 1679 | (print-next) | |
| 1680 | (princ "combined view has inconsistent mappings for: ") | |
| 1681 | (let ((*print-indent* (+ *print-indent* 2))) | |
| 1682 | (print-next) | |
| 1683 | (print-chaos-object (car m))) | |
| 1684 | (print-next) | |
| 1685 | (princ "target images are: ") | |
| 1686 | (let ((*print-indent* (+ *print-indent* 2))) | |
| 1687 | (print-next) | |
| 1688 | (print-chaos-object (cdr m)) | |
| 1689 | (print-next) | |
| 1690 | (print-chaos-object (cdr im))) | |
| 1691 | ))) | |
| 1692 | ;; (push (cons (car m) (cdr im)) res) | |
| 1693 | ) | |
| 1694 | (push m res)) | |
| 1695 | )) | |
| 1697 | 1696 | res |
| 1698 | 1697 | )) |
| 1699 | 1698 | |
| 1703 | 1702 | (eq (first map) (third map)) |
| 1704 | 1703 | ;; map := (term :replacement vars term) |
| 1705 | 1704 | (eq (first map) |
| 1706 | (term-head (fourth map))))) | |
| 1705 | (term-head (fourth map))))) | |
| 1707 | 1706 | |
| 1708 | 1707 | (defun modmorph-merge-op-assoc (a1 a2 &optional warn) |
| 1709 | 1708 | (let ((res a2)) |
| 1710 | 1709 | (dolist (m a1) |
| 1711 | 1710 | (let ((im (assq (car m) a2))) |
| 1712 | (if (and im | |
| 1713 | (not (modmorph-op-map-is-ident m))) | |
| 1714 | (progn | |
| 1715 | (unless (modmorph-same-op-image (cdr m) (cdr im)) | |
| 1716 | (when warn | |
| 1717 | (with-output-chaos-warning () | |
| 1718 | (princ "instantiating module,") | |
| 1719 | (print-next) | |
| 1720 | (princ "combined view has inconsistent mappings for operator: ") | |
| 1721 | (let ((*print-indent* (+ *print-indent* 2))) | |
| 1722 | (print-next) | |
| 1723 | (print-chaos-object (car m))) | |
| 1724 | (print-next) | |
| 1725 | (princ "images are: ") | |
| 1726 | (let ((*print-indent* (+ *print-indent* 2))) | |
| 1727 | (if (eq (cadr m) :replacement) | |
| 1728 | (progn | |
| 1729 | (print-next) | |
| 1730 | (print-chaos-object (cadddr m)) | |
| 1731 | (print-next) | |
| 1732 | (print-chaos-object (cadddr im))) | |
| 1733 | (progn | |
| 1734 | (print-next) | |
| 1735 | (print-chaos-object (caddr m)) | |
| 1736 | (print-next) | |
| 1737 | (print-chaos-object (caddr m))))) | |
| 1738 | ))) | |
| 1739 | ;; (push (cons (car m) (cdr im)) res) | |
| 1740 | ) | |
| 1741 | (push m res)) | |
| 1742 | )) | |
| 1711 | (if (and im | |
| 1712 | (not (modmorph-op-map-is-ident m))) | |
| 1713 | (progn | |
| 1714 | (unless (modmorph-same-op-image (cdr m) (cdr im)) | |
| 1715 | (when warn | |
| 1716 | (with-output-chaos-warning () | |
| 1717 | (princ "instantiating module,") | |
| 1718 | (print-next) | |
| 1719 | (princ "combined view has inconsistent mappings for operator: ") | |
| 1720 | (let ((*print-indent* (+ *print-indent* 2))) | |
| 1721 | (print-next) | |
| 1722 | (print-chaos-object (car m))) | |
| 1723 | (print-next) | |
| 1724 | (princ "images are: ") | |
| 1725 | (let ((*print-indent* (+ *print-indent* 2))) | |
| 1726 | (if (eq (cadr m) :replacement) | |
| 1727 | (progn | |
| 1728 | (print-next) | |
| 1729 | (print-chaos-object (cadddr m)) | |
| 1730 | (print-next) | |
| 1731 | (print-chaos-object (cadddr im))) | |
| 1732 | (progn | |
| 1733 | (print-next) | |
| 1734 | (print-chaos-object (caddr m)) | |
| 1735 | (print-next) | |
| 1736 | (print-chaos-object (caddr m))))) | |
| 1737 | ))) | |
| 1738 | ;; (push (cons (car m) (cdr im)) res) | |
| 1739 | ) | |
| 1740 | (push m res)) | |
| 1741 | )) | |
| 1743 | 1742 | res |
| 1744 | 1743 | )) |
| 1745 | 1744 | |
| 1750 | 1749 | (defun modmorph-same-op-image (im1 im2) |
| 1751 | 1750 | (if (and (consp im1) (eq :simple-map (car im1))) |
| 1752 | 1751 | (or (eq (cdr im1) (cdr im2)) |
| 1753 | (and (equal (method-name (cdr im1)) | |
| 1754 | (method-name (cdr im2))) | |
| 1755 | (sort= (method-coarity (cdr im1)) | |
| 1756 | *sort-id-sort*))) | |
| 1752 | (and (equal (method-name (cdr im1)) | |
| 1753 | (method-name (cdr im2))) | |
| 1754 | (sort= (method-coarity (cdr im1)) | |
| 1755 | *sort-id-sort*))) | |
| 1757 | 1756 | ;; |
| 1758 | 1757 | (if (and (consp im1) (eq :replacement (car im1))) |
| 1759 | (if (sort= (term-sort (caddr im1)) *sort-id-sort*) | |
| 1760 | (and (sort= (term-sort (caddr im2)) *sort-id-sort*) | |
| 1761 | (equal (method-name (term-head (caddr im1))) | |
| 1762 | (method-name (term-head (caddr im2))))) | |
| 1763 | (term-equational-equal (caddr im1) (caddr im2)))))) | |
| 1758 | (if (sort= (term-sort (caddr im1)) *sort-id-sort*) | |
| 1759 | (and (sort= (term-sort (caddr im2)) *sort-id-sort*) | |
| 1760 | (equal (method-name (term-head (caddr im1))) | |
| 1761 | (method-name (term-head (caddr im2))))) | |
| 1762 | (term-equational-equal (caddr im1) (caddr im2)))))) | |
| 1764 | 1763 | |
| 1765 | 1764 | ;;; op modmorph-find-sort-in : Module Sort-Name -> Sort |
| 1766 | 1765 | ;;; |
| 1767 | 1766 | (defun modmorph-find-sort-in (module sort-name) |
| 1768 | 1767 | (or (find sort-name (module-all-sorts module) |
| 1769 | :test #'(lambda (n s) | |
| 1770 | (and (equal n (sort-id s)) | |
| 1771 | (eq module (sort-module s))))) | |
| 1768 | :test #'(lambda (n s) | |
| 1769 | (and (equal n (sort-id s)) | |
| 1770 | (eq module (sort-module s))))) | |
| 1772 | 1771 | nil)) |
| 1773 | 1772 | |
| 1774 | 1773 | ;;; |
| 1775 | 1774 | ;;; |
| 1776 | 1775 | (defun modmorph-find-operator-named-in (module op-symbol) |
| 1777 | 1776 | (let ((res1 (find-if #'(lambda (opinfo) |
| 1778 | (let ((op (opinfo-operator opinfo))) | |
| 1779 | (or (equal op-symbol (operator-symbol op)) | |
| 1780 | (and (eq module (operator-module op)) | |
| 1781 | (if (atom op-symbol) | |
| 1782 | (equal op-symbol (car (operator-symbol op))) | |
| 1783 | (and (null (cdr op-symbol)) | |
| 1784 | (equal (car op-symbol) | |
| 1785 | (car (operator-symbol op))))))))) | |
| 1777 | (let ((op (opinfo-operator opinfo))) | |
| 1778 | (or (equal op-symbol (operator-symbol op)) | |
| 1779 | (and (eq module (operator-module op)) | |
| 1780 | (if (atom op-symbol) | |
| 1781 | (equal op-symbol (car (operator-symbol op))) | |
| 1782 | (and (null (cdr op-symbol)) | |
| 1783 | (equal (car op-symbol) | |
| 1784 | (car (operator-symbol op))))))))) | |
| 1786 | 1785 | (module-all-operators module)))) |
| 1787 | 1786 | (or res1 |
| 1788 | (dolist (srt (module-all-sorts module) nil) | |
| 1789 | (if (sort-is-builtin srt) | |
| 1790 | (let ((res (find-builtin-method-in module srt op-symbol))) | |
| 1791 | (if res (return res))))) | |
| 1792 | ))) | |
| 1787 | (dolist (srt (module-all-sorts module) nil) | |
| 1788 | (if (sort-is-builtin srt) | |
| 1789 | (let ((res (find-builtin-method-in module srt op-symbol))) | |
| 1790 | (if res (return res))))) | |
| 1791 | ))) | |
| 1793 | 1792 | |
| 1794 | 1793 | ;;; APPLY-OP-MAPPING : module op-mapping term -> term |
| 1795 | 1794 | ;;; |
| 1799 | 1798 | (defun apply-op-mapping (module op-mapping term) |
| 1800 | 1799 | (if (eq :simple-map (car op-mapping)) |
| 1801 | 1800 | (make-term-check-op-with-sort-check (cdr op-mapping) |
| 1802 | (term-subterms term)) | |
| 1801 | (term-subterms term)) | |
| 1803 | 1802 | (mapping-image (term-subterms term) (caddr op-mapping) module) |
| 1804 | ;caddr = dst-pattern | |
| 1803 | ;caddr = dst-pattern | |
| 1805 | 1804 | )) |
| 1806 | 1805 | |
| 1807 | 1806 | ;;; APPLY-OP-MAP |
| 1809 | 1808 | (defun apply-op-map (module op-map term) |
| 1810 | 1809 | (let ((val (assoc (term-head term) op-map))) |
| 1811 | 1810 | (if val |
| 1812 | (apply-op-mapping module (cdr val) term) | |
| 1813 | term))) | |
| 1811 | (apply-op-mapping module (cdr val) term) | |
| 1812 | term))) | |
| 1814 | 1813 | |
| 1815 | 1814 | ;;; MAPPING-IMAGE: |
| 1816 | 1815 | ;;; variables occuring in term are assumed to have numbers as names |
| 1819 | 1818 | ;;; |
| 1820 | 1819 | (defvar .mapping-debug. nil) |
| 1821 | 1820 | |
| 1822 | (defun mapping-image (term-list term &optional (module (or *current-module* | |
| 1823 | *last-module*))) | |
| 1821 | (defun mapping-image (term-list term &optional (module (get-context-module))) | |
| 1824 | 1822 | (when .mapping-debug. |
| 1825 | 1823 | (format t "~&[mapping-image] term = ") |
| 1826 | 1824 | (print-chaos-object term) |
| 1827 | 1825 | (format t "~% term-list = ") |
| 1828 | 1826 | (print-chaos-object term-list)) |
| 1829 | 1827 | (cond ((term-is-variable? term) |
| 1830 | (let ((nm (variable-name term))) | |
| 1831 | (if (integerp nm) (nth nm term-list) | |
| 1832 | (with-output-panic-message () | |
| 1833 | (princ "mapping-image: illegal variable") | |
| 1834 | (print-next) | |
| 1835 | (princ "var: ") (print-chaos-object term) | |
| 1836 | (chaos-error 'panic))))) | |
| 1837 | ((term-is-constant? term) term) | |
| 1838 | (t (make-term-check-op-with-sort-check | |
| 1839 | (term-head term) | |
| 1840 | (mapcar #'(lambda (st) (mapping-image term-list st)) | |
| 1841 | (term-subterms term)) | |
| 1842 | module) | |
| 1843 | ))) | |
| 1828 | (let ((nm (variable-name term))) | |
| 1829 | (if (integerp nm) (nth nm term-list) | |
| 1830 | (with-output-panic-message () | |
| 1831 | (princ "mapping-image: illegal variable") | |
| 1832 | (print-next) | |
| 1833 | (princ "var: ") (print-chaos-object term) | |
| 1834 | (chaos-error 'panic))))) | |
| 1835 | ((term-is-constant? term) term) | |
| 1836 | (t (make-term-check-op-with-sort-check | |
| 1837 | (term-head term) | |
| 1838 | (mapcar #'(lambda (st) (mapping-image term-list st)) | |
| 1839 | (term-subterms term)) | |
| 1840 | module) | |
| 1841 | ))) | |
| 1844 | 1842 | |
| 1845 | 1843 | (defun mapping-image-2 (map term_list term) |
| 1846 | 1844 | (cond ((term-is-variable? term) |
| 1847 | (let ((nm (variable-name term))) | |
| 1848 | (if (integerp nm) (nth nm term_list) | |
| 1849 | (with-output-panic-message () | |
| 1850 | (princ "mapping-image2: illegal variable") | |
| 1851 | (print-next) | |
| 1852 | (princ "var: ") (print-chaos-object term) | |
| 1853 | (chaos-error 'panic))))) | |
| 1854 | ((term-is-constant? term) term) | |
| 1855 | (t (let* ((op (term-head term)) | |
| 1856 | (om (method-module op)) | |
| 1857 | (as (or (cdr (assoc om (modmorph-module map))) | |
| 1858 | om))) | |
| 1859 | (when (and (not (eq as om)) | |
| 1860 | (module-p as)) | |
| 1861 | (setq op (find-method-in as ; was (cdr as). | |
| 1862 | (method-symbol op) | |
| 1863 | (modmorph-sorts-image as ; (cdr as) | |
| 1864 | (modmorph-sort map) | |
| 1865 | (method-arity op)) | |
| 1866 | (modmorph-sort-image as ; (cdr as) | |
| 1867 | (modmorph-sort map) | |
| 1868 | (method-coarity op))))) | |
| 1869 | (unless op | |
| 1870 | (with-output-panic-message () | |
| 1871 | (format t "mapping term image, could not find operator image:") | |
| 1872 | (print-method (term-head term)) | |
| 1873 | (chaos-error 'panic))) | |
| 1874 | (make-term-check-op-with-sort-check op | |
| 1875 | (mapcar #'(lambda (st) | |
| 1876 | (mapping-image-2 | |
| 1877 | map term_list | |
| 1878 | st)) | |
| 1879 | (term-subterms term)) | |
| 1880 | (if (module-p as) | |
| 1881 | as | |
| 1882 | om)) | |
| 1883 | )))) | |
| 1845 | (let ((nm (variable-name term))) | |
| 1846 | (if (integerp nm) (nth nm term_list) | |
| 1847 | (with-output-panic-message () | |
| 1848 | (princ "mapping-image2: illegal variable") | |
| 1849 | (print-next) | |
| 1850 | (princ "var: ") (print-chaos-object term) | |
| 1851 | (chaos-error 'panic))))) | |
| 1852 | ((term-is-constant? term) term) | |
| 1853 | (t (let* ((op (term-head term)) | |
| 1854 | (om (method-module op)) | |
| 1855 | (as (or (cdr (assoc om (modmorph-module map))) | |
| 1856 | om))) | |
| 1857 | (when (and (not (eq as om)) | |
| 1858 | (module-p as)) | |
| 1859 | (setq op (find-method-in as ; was (cdr as). | |
| 1860 | (method-symbol op) | |
| 1861 | (modmorph-sorts-image as ; (cdr as) | |
| 1862 | (modmorph-sort map) | |
| 1863 | (method-arity op)) | |
| 1864 | (modmorph-sort-image as ; (cdr as) | |
| 1865 | (modmorph-sort map) | |
| 1866 | (method-coarity op))))) | |
| 1867 | (unless op | |
| 1868 | (with-output-panic-message () | |
| 1869 | (format t "mapping term image, could not find operator image:") | |
| 1870 | (print-method (term-head term)) | |
| 1871 | (chaos-error 'panic))) | |
| 1872 | (make-term-check-op-with-sort-check op | |
| 1873 | (mapcar #'(lambda (st) | |
| 1874 | (mapping-image-2 | |
| 1875 | map term_list | |
| 1876 | st)) | |
| 1877 | (term-subterms term)) | |
| 1878 | (if (module-p as) | |
| 1879 | as | |
| 1880 | om)) | |
| 1881 | )))) | |
| 1884 | 1882 | |
| 1885 | 1883 | ;;; |
| 1886 | 1884 | (defun view-get-image-of-axioms (view) |
| 1887 | 1885 | (let* ((source (view-source view)) |
| 1888 | (target (view-target view)) | |
| 1889 | (morph (convert-view-to-modmorph source | |
| 1890 | view))) | |
| 1886 | (target (view-target view)) | |
| 1887 | (morph (convert-view-to-modmorph source | |
| 1888 | view))) | |
| 1891 | 1889 | (modmorph-get-image-of-axioms morph source target))) |
| 1892 | ||
| 1890 | ||
| 1893 | 1891 | (defun modmorph-get-image-of-axioms (morph source target) |
| 1894 | 1892 | (let ((sort-map (modmorph-sort morph)) |
| 1895 | (op-map (modmorph-op morph)) | |
| 1896 | (mod-map (modmorph-module morph)) | |
| 1897 | (all-axioms (get-module-axioms target)) | |
| 1898 | (axs nil)) | |
| 1893 | (op-map (modmorph-op morph)) | |
| 1894 | (mod-map (modmorph-module morph)) | |
| 1895 | (all-axioms (get-module-axioms target)) | |
| 1896 | (axs nil)) | |
| 1899 | 1897 | (dolist (ax (get-module-axioms source)) |
| 1900 | 1898 | (let ((ax-image (modmorph-recreate-axiom target sort-map op-map mod-map ax))) |
| 1901 | (unless (member ax-image all-axioms :test #'rule-is-similar?) | |
| 1902 | (push ax-image axs)))) | |
| 1899 | (unless (member ax-image all-axioms :test #'rule-is-similar?) | |
| 1900 | (push ax-image axs)))) | |
| 1903 | 1901 | (nreverse axs))) |
| 1904 | 1902 | |
| 1905 | 1903 | ;;; EOF |
| 0 | 0 | ;;;-*- Mode:LISP; Package:CHAOS; Base:10; Syntax:Common-lisp -*- |
| 1 | 1 | ;;; |
| 2 | ;;; Copyright (c) 2000-2014, Toshimi Sawada. All rights reserved. | |
| 2 | ;;; Copyright (c) 2000-2015, Toshimi Sawada. All rights reserved. | |
| 3 | 3 | ;;; |
| 4 | 4 | ;;; Redistribution and use in source and binary forms, with or without |
| 5 | 5 | ;;; modification, are permitted provided that the following conditions |
| 27 | 27 | ;;; |
| 28 | 28 | (in-package :chaos) |
| 29 | 29 | #|============================================================================== |
| 30 | System: CHAOS | |
| 31 | Module: deCafe | |
| 32 | File: mrmap.lisp | |
| 30 | System: CHAOS | |
| 31 | Module: deCafe | |
| 32 | File: mrmap.lisp | |
| 33 | 33 | ==============================================================================|# |
| 34 | 34 | #-:chaos-debug |
| 35 | 35 | (declaim (optimize (speed 3) (safety 0) #-GCL (debug 0))) |
| 56 | 56 | (unless rmap-1 (return-from compose-renames rmap-2)) |
| 57 | 57 | (unless rmap-2 (return-from compose-renames rmap-1)) |
| 58 | 58 | (let ((ren1 (if (%is-rmap rmap-1) |
| 59 | (%rmap-map rmap-1) | |
| 60 | rmap-2)) | |
| 61 | (ren2 (if (%is-rmap rmap-2) | |
| 62 | (%rmap-map rmap-2) | |
| 63 | rmap-2))) | |
| 59 | (%rmap-map rmap-1) | |
| 60 | rmap-2)) | |
| 61 | (ren2 (if (%is-rmap rmap-2) | |
| 62 | (%rmap-map rmap-2) | |
| 63 | rmap-2))) | |
| 64 | 64 | (let ((ops1 (cadr (assq '%ren-op ren1))) |
| 65 | (param1 (cadr (assq '%ren-param ren1))) | |
| 66 | (sorts1 (cadr (assq '%ren-sort ren1)))) | |
| 65 | (param1 (cadr (assq '%ren-param ren1))) | |
| 66 | (sorts1 (cadr (assq '%ren-sort ren1)))) | |
| 67 | 67 | (let ((ren2map (mapcar #'(lambda (map) |
| 68 | (cond ((%is-ren-sort map) | |
| 69 | (%ren-sort* | |
| 70 | (nconc | |
| 71 | (mapcar #'(lambda (x) | |
| 72 | (list (car x) | |
| 73 | (image-rename-sort sorts1 | |
| 74 | (cadr x)))) | |
| 75 | (%ren-sort-maps map)) | |
| 76 | sorts1))) | |
| 77 | ((%is-ren-op map) | |
| 78 | (%ren-op* | |
| 79 | (nconc | |
| 80 | (mapcar #'(lambda (x) | |
| 81 | (list (car x) | |
| 82 | (image-rename-op ops1 | |
| 83 | (cadr x)))) | |
| 84 | (%ren-op-maps map)) | |
| 85 | ops1))) | |
| 86 | ((%is-ren-param map) | |
| 87 | (%ren-param* | |
| 88 | (nconc | |
| 89 | (mapcar #'(lambda (x) | |
| 90 | (list (car x) | |
| 91 | (image-rename-param param1 | |
| 92 | (cadr x)))) | |
| 93 | (%ren-op-maps map)) | |
| 94 | param1))) | |
| 95 | (t (with-output-chaos-warning () | |
| 96 | (princ "renaming ") | |
| 97 | (print-ast map) | |
| 98 | (print-next) | |
| 99 | (princ " is not implemented yet."))))) | |
| 100 | ren2))) | |
| 101 | (apply #'%rmap* ren2map))) | |
| 68 | (cond ((%is-ren-sort map) | |
| 69 | (%ren-sort* | |
| 70 | (nconc | |
| 71 | (mapcar #'(lambda (x) | |
| 72 | (list (car x) | |
| 73 | (image-rename-sort sorts1 | |
| 74 | (cadr x)))) | |
| 75 | (%ren-sort-maps map)) | |
| 76 | sorts1))) | |
| 77 | ((%is-ren-op map) | |
| 78 | (%ren-op* | |
| 79 | (nconc | |
| 80 | (mapcar #'(lambda (x) | |
| 81 | (list (car x) | |
| 82 | (image-rename-op ops1 | |
| 83 | (cadr x)))) | |
| 84 | (%ren-op-maps map)) | |
| 85 | ops1))) | |
| 86 | ((%is-ren-param map) | |
| 87 | (%ren-param* | |
| 88 | (nconc | |
| 89 | (mapcar #'(lambda (x) | |
| 90 | (list (car x) | |
| 91 | (image-rename-param param1 | |
| 92 | (cadr x)))) | |
| 93 | (%ren-op-maps map)) | |
| 94 | param1))) | |
| 95 | (t (with-output-chaos-warning () | |
| 96 | (princ "renaming ") | |
| 97 | (print-ast map) | |
| 98 | (print-next) | |
| 99 | (princ " is not implemented yet."))))) | |
| 100 | ren2))) | |
| 101 | (apply #'%rmap* ren2map))) | |
| 102 | 102 | )) |
| 103 | 103 | |
| 104 | 104 | (defun rmap-sort-match (srtnm srtpat) |
| 109 | 109 | ;;; |
| 110 | 110 | (defun image-rename-sort (ren x) |
| 111 | 111 | (let ((imap (find-if #'(lambda (y) |
| 112 | (rmap-sort-match x (car y))) | |
| 113 | ren))) | |
| 112 | (rmap-sort-match x (car y))) | |
| 113 | ren))) | |
| 114 | 114 | (if imap |
| 115 | (cadr imap) | |
| 116 | x))) | |
| 115 | (cadr imap) | |
| 116 | x))) | |
| 117 | 117 | ;;; |
| 118 | 118 | (defun image-rename-op (ren x) |
| 119 | 119 | (let ((imap (find-if #'(lambda (y) |
| 120 | (equal x (car y))) | |
| 121 | ren))) | |
| 120 | (equal x (car y))) | |
| 121 | ren))) | |
| 122 | 122 | (if imap |
| 123 | (cadr imap) | |
| 124 | x))) | |
| 123 | (cadr imap) | |
| 124 | x))) | |
| 125 | 125 | |
| 126 | 126 | ;;; |
| 127 | 127 | (defun image-rename-param (ren x) |
| 128 | 128 | (let ((imap (find-if #'(lambda (y) |
| 129 | (equal x (car y))) | |
| 130 | ren))) | |
| 129 | (equal x (car y))) | |
| 130 | ren))) | |
| 131 | 131 | (if imap |
| 132 | (cadr imap) | |
| 133 | x))) | |
| 134 | ||
| 132 | (cadr imap) | |
| 133 | x))) | |
| 134 | ||
| 135 | 135 | ;;; |
| 136 | 136 | (defun inverse-image-rename-sort (ren x) |
| 137 | 137 | (let ((imap (find-if #'(lambda (y) |
| 138 | (rmap-sort-match x (car y))) | |
| 139 | ren))) | |
| 138 | (rmap-sort-match x (car y))) | |
| 139 | ren))) | |
| 140 | 140 | (if imap |
| 141 | (cadr imap) | |
| 142 | x))) | |
| 141 | (cadr imap) | |
| 142 | x))) | |
| 143 | 143 | |
| 144 | 144 | ;;; Some versions for %*maps |
| 145 | 145 | ;;;----------------------------------------------------------------------------- |
| 146 | 146 | |
| 147 | 147 | (defun *image-rename-sort (map x) |
| 148 | 148 | (let ((imap (find-if #'(lambda (y) |
| 149 | (sort= x (car y))) | |
| 150 | map))) | |
| 149 | (sort= x (car y))) | |
| 150 | map))) | |
| 151 | 151 | (if imap |
| 152 | (cdr imap) | |
| 153 | x))) | |
| 152 | (cdr imap) | |
| 153 | x))) | |
| 154 | 154 | |
| 155 | 155 | (defun *image-rename-sorts (map sorts) |
| 156 | 156 | (mapcar #'(lambda (x) (*image-rename-sort map x)) sorts)) |
| 157 | ||
| 157 | ||
| 158 | 158 | (defun *image-rename-method (map x) |
| 159 | 159 | (let ((imap (find-if #'(lambda (y) |
| 160 | (eq x (car y))) | |
| 161 | map))) | |
| 160 | (eq x (car y))) | |
| 161 | map))) | |
| 162 | 162 | (if imap |
| 163 | (cdr imap) | |
| 164 | x))) | |
| 163 | (cdr imap) | |
| 164 | x))) | |
| 165 | 165 | |
| 166 | 166 | |
| 167 | 167 | |
| 173 | 173 | ;;; |
| 174 | 174 | (defun reduce-rename (mod rmap) |
| 175 | 175 | (let ((ren (if (%is-rmap rmap) |
| 176 | (%rmap-map rmap) | |
| 177 | rmap))) | |
| 176 | (%rmap-map rmap) | |
| 177 | rmap))) | |
| 178 | 178 | (let ((sort-res nil) |
| 179 | (op-res nil) | |
| 180 | (param-res nil)) | |
| 179 | (op-res nil) | |
| 180 | (param-res nil)) | |
| 181 | 181 | (with-in-module (mod) |
| 182 | (do* ((lst ren (cdr lst)) | |
| 183 | (map (car lst) (car lst))) | |
| 184 | ((null lst)) | |
| 185 | (cond ((%is-ren-sort map) | |
| 186 | (dolist (x map) | |
| 187 | (when (let ((s (find-sort-in mod (car x)))) | |
| 188 | (and s (not (sort-is-hidden s)))) | |
| 189 | (push x sort-res)))) | |
| 190 | ((%is-ren-hsort map) | |
| 191 | (dolist (x map) | |
| 192 | (when (let ((s (find-sort-in mod (car x)))) | |
| 193 | (and s (sort-is-hidden s))) | |
| 194 | (push x sort-res)))) | |
| 195 | ((%is-ren-op map) | |
| 196 | (dolist (x map) | |
| 197 | (when (find-qual-operators (car x) mod :functional) | |
| 198 | (push x op-res)))) | |
| 199 | ((%is-ren-Bop map) | |
| 200 | (dolist (x map) | |
| 201 | (when (find-qual-operators (car x) mod :functional) | |
| 202 | (push x op-res)))) | |
| 203 | ((%is-ren-param map) | |
| 204 | (dolist (x map) | |
| 205 | (when (find-parameterized-submodule (car x) mod) | |
| 206 | (push x param-res)))) | |
| 207 | (t nil)))) | |
| 182 | (do* ((lst ren (cdr lst)) | |
| 183 | (map (car lst) (car lst))) | |
| 184 | ((null lst)) | |
| 185 | (cond ((%is-ren-sort map) | |
| 186 | (dolist (x map) | |
| 187 | (when (let ((s (find-sort-in mod (car x)))) | |
| 188 | (and s (not (sort-is-hidden s)))) | |
| 189 | (push x sort-res)))) | |
| 190 | ((%is-ren-hsort map) | |
| 191 | (dolist (x map) | |
| 192 | (when (let ((s (find-sort-in mod (car x)))) | |
| 193 | (and s (sort-is-hidden s))) | |
| 194 | (push x sort-res)))) | |
| 195 | ((%is-ren-op map) | |
| 196 | (dolist (x map) | |
| 197 | (when (find-qual-operators (car x) mod :functional) | |
| 198 | (push x op-res)))) | |
| 199 | ((%is-ren-Bop map) | |
| 200 | (dolist (x map) | |
| 201 | (when (find-qual-operators (car x) mod :functional) | |
| 202 | (push x op-res)))) | |
| 203 | ((%is-ren-param map) | |
| 204 | (dolist (x map) | |
| 205 | (when (find-parameterized-submodule (car x) mod) | |
| 206 | (push x param-res)))) | |
| 207 | (t nil)))) | |
| 208 | 208 | (%rmap* (nconc (when sort-res (list (%ren-sort* (nreverse sort-res)))) |
| 209 | (when op-res (list (%ren-op* (nreverse op-res)))) | |
| 210 | ;;; (when param-res (list (%ren-param* (nreverse param-res)))) | |
| 211 | )) | |
| 209 | (when op-res (list (%ren-op* (nreverse op-res)))) | |
| 210 | ;;; (when param-res (list (%ren-param* (nreverse param-res)))) | |
| 211 | )) | |
| 212 | 212 | ))) |
| 213 | 213 | |
| 214 | 214 | ;;; IS-RENAME-INJECTIVE : rmap -> bool |
| 216 | 216 | ;;; |
| 217 | 217 | (defun is-rename-injective (rmap) |
| 218 | 218 | (flet ((check-map (ren) |
| 219 | (dolist (x ren) | |
| 220 | (when (find-if #'(lambda (y) | |
| 221 | (and (not (eq x y)) | |
| 222 | (not (equal (car x) | |
| 223 | (car y))) | |
| 224 | (equal (cadr x) (cadr y)))) | |
| 225 | ren) | |
| 226 | (return-from check-map :warn))) | |
| 227 | (dolist (x ren) | |
| 228 | (when (find-if #'(lambda (y) | |
| 229 | (and (not (eq x y)) | |
| 230 | (equal (car x) (car y)) | |
| 231 | (not (equal (cadr x) (cadr y))))) | |
| 232 | ren) | |
| 233 | (return-from check-map :invalid))) | |
| 234 | :ok)) | |
| 219 | (dolist (x ren) | |
| 220 | (when (find-if #'(lambda (y) | |
| 221 | (and (not (eq x y)) | |
| 222 | (not (equal (car x) | |
| 223 | (car y))) | |
| 224 | (equal (cadr x) (cadr y)))) | |
| 225 | ren) | |
| 226 | (return-from check-map :warn))) | |
| 227 | (dolist (x ren) | |
| 228 | (when (find-if #'(lambda (y) | |
| 229 | (and (not (eq x y)) | |
| 230 | (equal (car x) (car y)) | |
| 231 | (not (equal (cadr x) (cadr y))))) | |
| 232 | ren) | |
| 233 | (return-from check-map :invalid))) | |
| 234 | :ok)) | |
| 235 | 235 | ;; |
| 236 | 236 | (let* ((ren (if (%is-rmap rmap) |
| 237 | (%rmap-map rmap) | |
| 238 | rmap)) | |
| 239 | (sort-map (cadr (assq '%ren-sort ren))) | |
| 240 | (op-map (cadr (assq '%ren-op ren)))) | |
| 237 | (%rmap-map rmap) | |
| 238 | rmap)) | |
| 239 | (sort-map (cadr (assq '%ren-sort ren))) | |
| 240 | (op-map (cadr (assq '%ren-op ren)))) | |
| 241 | 241 | (let ((sort-check (check-map sort-map)) |
| 242 | (op-check (check-map op-map))) | |
| 243 | (if (and (eq sort-check :ok) | |
| 244 | (eq op-check :ok)) | |
| 245 | :ok | |
| 246 | (if (or (eq sort-check :invalid) | |
| 247 | (eq sort-check :invalid)) | |
| 248 | :invalid | |
| 249 | :warn)))))) | |
| 242 | (op-check (check-map op-map))) | |
| 243 | (if (and (eq sort-check :ok) | |
| 244 | (eq op-check :ok)) | |
| 245 | :ok | |
| 246 | (if (or (eq sort-check :invalid) | |
| 247 | (eq sort-check :invalid)) | |
| 248 | :invalid | |
| 249 | :warn)))))) | |
| 250 | 250 | |
| 251 | 251 | ;;; ****************** |
| 252 | 252 | ;;; RENAME APPLICATION__________________________________________________________ |
| 277 | 277 | (return-from rename-sort old-sort)) |
| 278 | 278 | ;; |
| 279 | 279 | (let ((val (assq old-sort (modmorph-sort map)))) |
| 280 | (if (and (null val) ; not mapped. | |
| 281 | (null new-name) ; need not generate a sort. | |
| 282 | (not (eq oldmod (sort-module old-sort)))) | |
| 283 | ;; there's no image and is not a sort of oldmod | |
| 284 | ;; and we need not to generate a new sort. | |
| 285 | old-sort | |
| 280 | (if (and (null val) ; not mapped. | |
| 281 | (null new-name) ; need not generate a sort. | |
| 282 | (not (eq oldmod (sort-module old-sort)))) | |
| 283 | ;; there's no image and is not a sort of oldmod | |
| 284 | ;; and we need not to generate a new sort. | |
| 285 | old-sort | |
| 286 | 286 | ;; may have image in module morphism or in sortmap. |
| 287 | 287 | ;; or we must generate a sort with new-name. |
| 288 | 288 | (if (sort-struct-p (cdr val)) |
| 289 | ;; has image in map, and its a sort object. | |
| 290 | (cdr val) | |
| 291 | ;; has no sort object image and the sort is of oldmod, | |
| 292 | ;; or no image and must create with new-name. | |
| 293 | (let* ((mod (sort-module old-sort)) | |
| 294 | (mod-image (cdr (assq mod (modmorph-module map)))) | |
| 295 | (old-sort-id (sort-id old-sort))) | |
| 296 | ;; non nill mod-image means the sort's module is mapped by | |
| 297 | ;; module morphism `map' to mod-image. | |
| 298 | (let ((res (if mod-image | |
| 299 | (find-if #'(lambda (x) | |
| 300 | (and (equal (sort-id x) old-sort-id) | |
| 301 | (eq (sort-module x) mod))) | |
| 302 | (module-all-sorts mod-image))))) | |
| 303 | ;; | |
| 304 | (if res | |
| 305 | res | |
| 306 | (let ((dmod mod-image)) | |
| 307 | (unless dmod | |
| 308 | (setq dmod | |
| 309 | (if (eq mod oldmod) ; (assq mod (module-all-submodules oldmod)) | |
| 310 | newmod | |
| 311 | (create-dummy-module-then-map map | |
| 312 | (sort-module old-sort) | |
| 313 | (list old-sort new-name))))) | |
| 314 | (let ((newsort (!recreate-sort dmod old-sort new-name))) | |
| 315 | (if val | |
| 316 | (rplacd val newsort) | |
| 317 | (push (cons old-sort newsort) (modmorph-sort map))) | |
| 318 | (add-sort-to-module newsort dmod) | |
| 319 | newsort))))))))) | |
| 289 | ;; has image in map, and its a sort object. | |
| 290 | (cdr val) | |
| 291 | ;; has no sort object image and the sort is of oldmod, | |
| 292 | ;; or no image and must create with new-name. | |
| 293 | (let* ((mod (sort-module old-sort)) | |
| 294 | (mod-image (cdr (assq mod (modmorph-module map)))) | |
| 295 | (old-sort-id (sort-id old-sort))) | |
| 296 | ;; non nill mod-image means the sort's module is mapped by | |
| 297 | ;; module morphism `map' to mod-image. | |
| 298 | (let ((res (if mod-image | |
| 299 | (find-if #'(lambda (x) | |
| 300 | (and (equal (sort-id x) old-sort-id) | |
| 301 | (eq (sort-module x) mod))) | |
| 302 | (module-all-sorts mod-image))))) | |
| 303 | ;; | |
| 304 | (if res | |
| 305 | res | |
| 306 | (let ((dmod mod-image)) | |
| 307 | (unless dmod | |
| 308 | (setq dmod | |
| 309 | (if (eq mod oldmod) ; (assq mod (module-all-submodules oldmod)) | |
| 310 | newmod | |
| 311 | (create-dummy-module-then-map map | |
| 312 | (sort-module old-sort) | |
| 313 | (list old-sort new-name))))) | |
| 314 | (let ((newsort (!recreate-sort dmod old-sort new-name))) | |
| 315 | (if val | |
| 316 | (rplacd val newsort) | |
| 317 | (push (cons old-sort newsort) (modmorph-sort map))) | |
| 318 | (add-sort-to-module newsort dmod) | |
| 319 | newsort))))))))) | |
| 320 | 320 | |
| 321 | 321 | (defun rename-sorts (map oldmod newmod sorts) |
| 322 | 322 | (mapcar #'(lambda (x) (rename-sort map oldmod newmod x)) |
| 323 | sorts)) | |
| 323 | sorts)) | |
| 324 | 324 | |
| 325 | 325 | ;;; RENAME-RECORD |
| 326 | 326 | (defun rename-record (map oldmod newmod old-sort &optional new-name) |
| 334 | 334 | ;;; |
| 335 | 335 | (defun rename-op (map mod newmod opinfo op-name &optional theory-mod) |
| 336 | 336 | (let ((old-method-info-table (module-opinfo-table mod)) |
| 337 | (opnm (if (%is-opref op-name) | |
| 338 | (%opref-name op-name) | |
| 339 | op-name))) | |
| 337 | (opnm (if (%is-opref op-name) | |
| 338 | (%opref-name op-name) | |
| 339 | op-name))) | |
| 340 | 340 | (when (check-enclosing-parens op-name) |
| 341 | 341 | (setq opnm (butlast (cdr op-name)))) |
| 342 | 342 | ;; |
| 343 | 343 | (dolist (method (opinfo-methods opinfo)) |
| 344 | 344 | (when (or (method-is-user-defined-error-method method) |
| 345 | (not (method-is-error-method method))) | |
| 346 | ;;** | |
| 347 | (when *on-modexp-debug* | |
| 348 | (format t "~%[rename-op] op = ~s" (method-operator method old-method-info-table)) | |
| 349 | (format t "~% meth [~s] " method) | |
| 350 | (format t "of module ~s" (method-module method))) | |
| 351 | ;; ** | |
| 352 | (let* ((op (method-operator method old-method-info-table)) | |
| 353 | (oldmod (if (eq mod (method-module method)) | |
| 354 | mod | |
| 355 | (method-module method)))) | |
| 356 | (let ((amod (cdr (assq (method-module method) | |
| 357 | (modmorph-module map))))) | |
| 358 | (if amod | |
| 359 | (setq newmod amod) | |
| 360 | (setq newmod | |
| 361 | (create-dummy-module-then-map map | |
| 362 | (method-module method) | |
| 363 | (list ':op | |
| 364 | (operator-symbol op) | |
| 365 | op-name))))) | |
| 366 | ;; | |
| 367 | (let ((arity (rename-sorts map oldmod newmod | |
| 368 | (method-arity method))) | |
| 369 | (coarity (rename-sort map oldmod newmod | |
| 370 | (method-coarity method))) | |
| 371 | (newop nil) | |
| 372 | (newmeth nil)) | |
| 373 | (declare (type list arity) | |
| 374 | (type sort* coarity)) | |
| 375 | (with-in-module (newmod) | |
| 376 | (unless (find-operator opnm (length arity) newmod) | |
| 377 | (setq newop (make-operator-internal opnm (length arity) newmod)) | |
| 378 | (setf (operator-theory newop) | |
| 379 | (rename-recreate-theory (operator-theory op))) | |
| 380 | (setf (operator-precedence newop) | |
| 381 | (operator-precedence op)) | |
| 382 | (setf (operator-associativity newop) | |
| 383 | (operator-associativity op))) | |
| 384 | (unless (setq newmeth (find-method-in newmod opnm arity coarity)) | |
| 385 | (multiple-value-setq (newop newmeth) | |
| 386 | (add-operator-declaration-to-module opnm | |
| 387 | arity | |
| 388 | coarity | |
| 389 | newmod | |
| 390 | (method-constructor method) | |
| 391 | (method-behavioural method) | |
| 392 | nil ;; (method-coherent method) -- set later | |
| 393 | (method-is-user-defined-error-method method))) | |
| 394 | (setf (method-supplied-strategy newmeth) | |
| 395 | (method-supplied-strategy method)) | |
| 396 | (setf (method-precedence newmeth) | |
| 397 | (method-precedence method)) | |
| 398 | (setf (method-has-memo newmeth) | |
| 399 | (method-has-memo method)) | |
| 400 | (setf (method-is-meta-demod newmeth) | |
| 401 | (method-is-meta-demod method)) | |
| 402 | (setf (method-associativity newmeth) | |
| 403 | (method-associativity method)) | |
| 404 | (setf (method-theory newmeth) | |
| 405 | (rename-recreate-theory | |
| 406 | (method-theory method | |
| 407 | (module-opinfo-table | |
| 408 | (or theory-mod oldmod))))) | |
| 409 | (setf (method-derived-from newmeth) method) | |
| 410 | (setf (method-is-coherent newmeth) | |
| 411 | (method-is-coherent method | |
| 412 | (module-opinfo-table | |
| 413 | (or theory-mod oldmod)))) | |
| 414 | (compute-method-theory-info-for-matching newmeth) | |
| 415 | ;; (push (cons method newmeth) (modmorph-op map)) | |
| 416 | (if (method-is-user-defined-error-method method) | |
| 417 | (push (cons method (cons :simple-error-map newmeth)) | |
| 418 | (modmorph-op map)) | |
| 419 | (push (cons method (cons :simple-map newmeth)) | |
| 420 | (modmorph-op map))))))))) | |
| 345 | (not (method-is-error-method method))) | |
| 346 | ;;** | |
| 347 | (when *on-modexp-debug* | |
| 348 | (format t "~%[rename-op] op = ~s" (method-operator method old-method-info-table)) | |
| 349 | (format t "~% meth [~s] " method) | |
| 350 | (format t "of module ~s" (method-module method))) | |
| 351 | ;; ** | |
| 352 | (let* ((op (method-operator method old-method-info-table)) | |
| 353 | (oldmod (if (eq mod (method-module method)) | |
| 354 | mod | |
| 355 | (method-module method)))) | |
| 356 | (let ((amod (cdr (assq (method-module method) | |
| 357 | (modmorph-module map))))) | |
| 358 | (if amod | |
| 359 | (setq newmod amod) | |
| 360 | (setq newmod | |
| 361 | (create-dummy-module-then-map map | |
| 362 | (method-module method) | |
| 363 | (list ':op | |
| 364 | (operator-symbol op) | |
| 365 | op-name))))) | |
| 366 | ;; | |
| 367 | (let ((arity (rename-sorts map oldmod newmod | |
| 368 | (method-arity method))) | |
| 369 | (coarity (rename-sort map oldmod newmod | |
| 370 | (method-coarity method))) | |
| 371 | (newop nil) | |
| 372 | (newmeth nil)) | |
| 373 | (declare (type list arity) | |
| 374 | (type sort* coarity)) | |
| 375 | (with-in-module (newmod) | |
| 376 | (unless (find-operator opnm (length arity) newmod) | |
| 377 | (setq newop (make-operator-internal opnm (length arity) newmod)) | |
| 378 | (setf (operator-theory newop) | |
| 379 | (rename-recreate-theory (operator-theory op))) | |
| 380 | (setf (operator-precedence newop) | |
| 381 | (operator-precedence op)) | |
| 382 | (setf (operator-associativity newop) | |
| 383 | (operator-associativity op))) | |
| 384 | (unless (setq newmeth (find-method-in newmod opnm arity coarity)) | |
| 385 | (multiple-value-setq (newop newmeth) | |
| 386 | (add-operator-declaration-to-module opnm | |
| 387 | arity | |
| 388 | coarity | |
| 389 | newmod | |
| 390 | (method-constructor method) | |
| 391 | (method-behavioural method) | |
| 392 | nil ;; (method-coherent method) -- set later | |
| 393 | (method-is-user-defined-error-method method))) | |
| 394 | (setf (method-supplied-strategy newmeth) | |
| 395 | (method-supplied-strategy method)) | |
| 396 | (setf (method-precedence newmeth) | |
| 397 | (method-precedence method)) | |
| 398 | (setf (method-has-memo newmeth) | |
| 399 | (method-has-memo method)) | |
| 400 | (setf (method-is-meta-demod newmeth) | |
| 401 | (method-is-meta-demod method)) | |
| 402 | (setf (method-associativity newmeth) | |
| 403 | (method-associativity method)) | |
| 404 | (setf (method-theory newmeth) | |
| 405 | (rename-recreate-theory | |
| 406 | (method-theory method | |
| 407 | (module-opinfo-table | |
| 408 | (or theory-mod oldmod))))) | |
| 409 | (setf (method-derived-from newmeth) method) | |
| 410 | (setf (method-is-coherent newmeth) | |
| 411 | (method-is-coherent method | |
| 412 | (module-opinfo-table | |
| 413 | (or theory-mod oldmod)))) | |
| 414 | (compute-method-theory-info-for-matching newmeth) | |
| 415 | ;; (push (cons method newmeth) (modmorph-op map)) | |
| 416 | (if (method-is-user-defined-error-method method) | |
| 417 | (push (cons method (cons :simple-error-map newmeth)) | |
| 418 | (modmorph-op map)) | |
| 419 | (push (cons method (cons :simple-map newmeth)) | |
| 420 | (modmorph-op map))))))))) | |
| 421 | 421 | map)) |
| 422 | 422 | |
| 423 | 423 | ;;; |
| 425 | 425 | ;;; |
| 426 | 426 | (defun transfer-method (module from-module method) |
| 427 | 427 | (when (or (method-is-user-defined-error-method method) |
| 428 | (and (not (method-is-error-method method)) | |
| 429 | (not (method-is-for-regularity? method from-module)))) | |
| 428 | (and (not (method-is-error-method method)) | |
| 429 | (not (method-is-for-regularity? method from-module)))) | |
| 430 | 430 | (let ((from-opinfo (module-opinfo-table from-module)) |
| 431 | (so (module-sort-order module)) | |
| 432 | new-opinfo | |
| 433 | op) | |
| 431 | (so (module-sort-order module)) | |
| 432 | new-opinfo | |
| 433 | op) | |
| 434 | 434 | (setf op (method-operator method from-opinfo)) |
| 435 | 435 | (setf new-opinfo |
| 436 | (and op | |
| 437 | (dolist (x (module-all-operators module) nil) | |
| 438 | (when (and (operator-eql op (opinfo-operator x)) | |
| 439 | (is-in-same-connected-component* (method-coarity method) | |
| 440 | (method-coarity (car (opinfo-methods x))) | |
| 441 | so)) | |
| 442 | (return x))))) | |
| 436 | (and op | |
| 437 | (dolist (x (module-all-operators module) nil) | |
| 438 | (when (and (operator-eql op (opinfo-operator x)) | |
| 439 | (is-in-same-connected-component* (method-coarity method) | |
| 440 | (method-coarity (car (opinfo-methods x))) | |
| 441 | so)) | |
| 442 | (return x))))) | |
| 443 | 443 | (when *on-modexp-debug* |
| 444 | (format t "~&[transfer-method]: transfering ~a from " (operator-symbol op)) | |
| 445 | (print-modexp from-module) | |
| 446 | (format t " to") | |
| 447 | (print-modexp module)) | |
| 444 | (format t "~%[transfer-method]: transfering ~a from " (operator-symbol op)) | |
| 445 | (print-modexp from-module) | |
| 446 | (format t " to") | |
| 447 | (print-modexp module)) | |
| 448 | 448 | (unless new-opinfo |
| 449 | (when *on-modexp-debug* | |
| 450 | (format t "~& - creating new operator info for importing ~a.~a" | |
| 451 | (operator-symbol op) | |
| 452 | (make-module-print-name (operator-module op)))) | |
| 453 | (setf new-opinfo (make-opinfo :operator op)) | |
| 454 | (push new-opinfo (module-all-operators module))) | |
| 449 | (when *on-modexp-debug* | |
| 450 | (format t "~& - creating new operator info for importing ~a.~a" | |
| 451 | (operator-symbol op) | |
| 452 | (make-module-print-name (operator-module op)))) | |
| 453 | (setf new-opinfo (make-opinfo :operator op)) | |
| 454 | (push new-opinfo (module-all-operators module))) | |
| 455 | 455 | (with-in-module (module) |
| 456 | (let ((to-opinfo (module-opinfo-table module))) | |
| 457 | (let ((method-info (get-method-info method to-opinfo))) | |
| 458 | (unless method-info | |
| 459 | (setf (get-method-info method to-opinfo) | |
| 460 | (make-method-info method module op)) | |
| 461 | )) | |
| 462 | (when (add-method-to-table new-opinfo method module) | |
| 463 | (setf (method-theory method to-opinfo) | |
| 464 | (method-theory method from-opinfo)) | |
| 465 | (setf (method-theory-info-for-matching method to-opinfo) | |
| 466 | (method-theory-info-for-matching method from-opinfo)) | |
| 467 | ) | |
| 468 | ))))) | |
| 456 | (let ((to-opinfo (module-opinfo-table module))) | |
| 457 | (let ((method-info (get-method-info method to-opinfo))) | |
| 458 | (unless method-info | |
| 459 | (setf (get-method-info method to-opinfo) | |
| 460 | (make-method-info method module op)) | |
| 461 | )) | |
| 462 | (when (add-method-to-table new-opinfo method module) | |
| 463 | (setf (method-theory method to-opinfo) | |
| 464 | (method-theory method from-opinfo)) | |
| 465 | (setf (method-theory-info-for-matching method to-opinfo) | |
| 466 | (method-theory-info-for-matching method from-opinfo)) | |
| 467 | ) | |
| 468 | ))))) | |
| 469 | 469 | |
| 470 | 470 | (defun transfer-method-axioms (module from-module method) |
| 471 | 471 | (with-in-module (module) |
| 472 | 472 | (let ((from-opinfo (module-opinfo-table from-module)) |
| 473 | (to-opinfo (module-opinfo-table module))) | |
| 473 | (to-opinfo (module-opinfo-table module))) | |
| 474 | 474 | (dolist (rule (rule-ring-to-list (method-rules-with-same-top method |
| 475 | from-opinfo))) | |
| 476 | (add-rule-to-method (check-axiom-error-method module rule) | |
| 477 | method | |
| 478 | to-opinfo) | |
| 479 | (pushnew rule (module-all-rules module) :test #'rule-is-similar?)) | |
| 475 | from-opinfo))) | |
| 476 | (add-rule-to-method (check-axiom-error-method module rule) | |
| 477 | method | |
| 478 | to-opinfo) | |
| 479 | (pushnew rule (module-all-rules module) :test #'rule-is-similar?)) | |
| 480 | 480 | (dolist (r (reverse (method-rules-with-different-top method |
| 481 | from-opinfo))) | |
| 482 | (add-rule-to-method (check-axiom-error-method module r) | |
| 483 | method | |
| 484 | to-opinfo) | |
| 485 | (pushnew r (module-all-rules module) :test #'rule-is-similar?)) | |
| 481 | from-opinfo))) | |
| 482 | (add-rule-to-method (check-axiom-error-method module r) | |
| 483 | method | |
| 484 | to-opinfo) | |
| 485 | (pushnew r (module-all-rules module) :test #'rule-is-similar?)) | |
| 486 | 486 | ))) |
| 487 | 487 | |
| 488 | 488 | ;;; |
| 499 | 499 | (format t "~% ... ~a --> ~a" (module-print-name mod) (module-print-name newmod)) |
| 500 | 500 | (format t "~% - map = ") (print-mapping map)) |
| 501 | 501 | ;; ------------------------------------------------------- |
| 502 | (let ((modmap (modmorph-module map))) ; module map | |
| 502 | (let ((modmap (modmorph-module map))) ; module map | |
| 503 | 503 | ;; sort mapping |
| 504 | 504 | (dolist (sm (modmorph-sort map)) |
| 505 | (let ((s1 (car sm)) ; source | |
| 506 | (s2 (cdr sm))) ; target | |
| 507 | (let* ((mod1 (sort-module s1)) | |
| 508 | (a1 (cdr (assq mod1 modmap))) | |
| 509 | (mod2 (sort-module s2))) | |
| 510 | (when *on-modexp-debug* | |
| 511 | (format t "~& - source = ~a.~a" (string (sort-id s1)) (module-print-name mod1)) | |
| 512 | ;; (print-modexp mod1) | |
| 513 | (format t "~& - target = ~a.~a" (string (sort-id s2)) (module-print-name mod2)) | |
| 514 | ;; (print-modexp mod2) | |
| 515 | (when a1 | |
| 516 | (format t "~& - module of sort ~a is mapped to ~a" (string (sort-id s1)) (module-print-name a1)))) | |
| 517 | ;; | |
| 518 | (if (and a1 (not (eq a1 mod2))) | |
| 519 | ;; s1.mod1 -> s2.mod2 | |
| 520 | ;; mod1 -> a1 =/= mod2 | |
| 521 | ;; module of source sort is mapped and | |
| 522 | ;; its image is not the same as of target sort. | |
| 523 | (progn | |
| 524 | ;; s2.mod2 ==> s2.a1 | |
| 525 | (when *on-modexp-debug* | |
| 526 | (format t "~& - changes target module to ") | |
| 527 | (print-modexp a1)) | |
| 528 | (setf (sort-module s2) a1) | |
| 529 | (add-sort-to-module s2 newmod)) | |
| 530 | ;; source sort is generated in dummy module. | |
| 531 | ;; mod1 is not mapped, | |
| 532 | ;; or s1.mod1 -> s2.mod2 | |
| 533 | ;; mod1 -> a1 == mod2 | |
| 534 | (if (or ;; (and a1 (eq a1 mod2)) | |
| 535 | ;; s1.mod1 -> s2.mod2 | |
| 536 | ;; mod1 -> a1 = mod2 | |
| 537 | (module-is-rename-dummy-for mod1 mod)) | |
| 538 | (progn | |
| 539 | (when *on-modexp-debug* | |
| 540 | (format t "~& - changes target module to ~a" (module-print-name newmod)) | |
| 541 | (setf (sort-module s2) newmod) | |
| 542 | (add-sort-to-module s2 newmod)))))))) | |
| 505 | (let ((s1 (car sm)) ; source | |
| 506 | (s2 (cdr sm))) ; target | |
| 507 | (let* ((mod1 (sort-module s1)) | |
| 508 | (a1 (cdr (assq mod1 modmap))) | |
| 509 | (mod2 (sort-module s2))) | |
| 510 | (when *on-modexp-debug* | |
| 511 | (format t "~% - source = ~a.~a" (string (sort-id s1)) (module-print-name mod1)) | |
| 512 | ;; (print-modexp mod1) | |
| 513 | (format t "~& - target = ~a.~a" (string (sort-id s2)) (module-print-name mod2)) | |
| 514 | ;; (print-modexp mod2) | |
| 515 | (when a1 | |
| 516 | (format t "~& - module of sort ~a is mapped to ~a" (string (sort-id s1)) (module-print-name a1)))) | |
| 517 | ;; | |
| 518 | (if (and a1 (not (eq a1 mod2))) | |
| 519 | ;; s1.mod1 -> s2.mod2 | |
| 520 | ;; mod1 -> a1 =/= mod2 | |
| 521 | ;; module of source sort is mapped and | |
| 522 | ;; its image is not the same as of target sort. | |
| 523 | (progn | |
| 524 | ;; s2.mod2 ==> s2.a1 | |
| 525 | (when *on-modexp-debug* | |
| 526 | (format t "~% - changes target module to ") | |
| 527 | (print-modexp a1)) | |
| 528 | (setf (sort-module s2) a1) | |
| 529 | (add-sort-to-module s2 newmod)) | |
| 530 | ;; source sort is generated in dummy module. | |
| 531 | ;; mod1 is not mapped, | |
| 532 | ;; or s1.mod1 -> s2.mod2 | |
| 533 | ;; mod1 -> a1 == mod2 | |
| 534 | (if (or ;; (and a1 (eq a1 mod2)) | |
| 535 | ;; s1.mod1 -> s2.mod2 | |
| 536 | ;; mod1 -> a1 = mod2 | |
| 537 | (module-is-rename-dummy-for mod1 mod)) | |
| 538 | (progn | |
| 539 | (when *on-modexp-debug* | |
| 540 | (format t "~% - changes target module to ~a" (module-print-name newmod)) | |
| 541 | (setf (sort-module s2) newmod) | |
| 542 | (add-sort-to-module s2 newmod)))))))) | |
| 543 | 543 | ;; |
| 544 | 544 | ;; operator mapping |
| 545 | 545 | ;; (method1 :simple-map . method2) |
| 546 | 546 | (dolist (om (modmorph-op map)) |
| 547 | (let ((method-1 (car om)) ; source | |
| 548 | (method-2 (cddr om))) ; target | |
| 549 | (let* ((mod1 (method-module method-1)) | |
| 550 | (a1 (cdr (assq mod1 modmap)))) | |
| 551 | (if (and a1 | |
| 552 | (not (eq a1 (method-module method-2)))) | |
| 553 | (progn | |
| 554 | (setf (method-module method-2) a1) | |
| 555 | (modmorph-check-rank newmod mod map method-2) | |
| 556 | (transfer-method newmod mod method-2)) | |
| 557 | (if (or ;; (and a1 (is-dummy-module a1)) | |
| 558 | (module-is-rename-dummy-for mod1 mod)) | |
| 559 | (progn | |
| 560 | (setf (method-module method-2) newmod) | |
| 561 | (modmorph-check-rank newmod mod map method-2) | |
| 562 | (transfer-method newmod mod method-2))))))))) | |
| 547 | (let ((method-1 (car om)) ; source | |
| 548 | (method-2 (cddr om))) ; target | |
| 549 | (let* ((mod1 (method-module method-1)) | |
| 550 | (a1 (cdr (assq mod1 modmap)))) | |
| 551 | (if (and a1 | |
| 552 | (not (eq a1 (method-module method-2)))) | |
| 553 | (progn | |
| 554 | (setf (method-module method-2) a1) | |
| 555 | (modmorph-check-rank newmod mod map method-2) | |
| 556 | (transfer-method newmod mod method-2)) | |
| 557 | (if (or ;; (and a1 (is-dummy-module a1)) | |
| 558 | (module-is-rename-dummy-for mod1 mod)) | |
| 559 | (progn | |
| 560 | (setf (method-module method-2) newmod) | |
| 561 | (modmorph-check-rank newmod mod map method-2) | |
| 562 | (transfer-method newmod mod method-2))))))))) | |
| 563 | 563 | |
| 564 | 564 | ;;; FIX-SORT-RENAMING |
| 565 | 565 | ;;; fix the following situation: |
| 568 | 568 | ;;; |
| 569 | 569 | (defun fix-sort-renaming (map newmod) |
| 570 | 570 | (dolist (sm (modmorph-sort map)) |
| 571 | (let ((s1 (car sm)) ; source | |
| 572 | (s2 (cdr sm))) ; target | |
| 571 | (let ((s1 (car sm)) ; source | |
| 572 | (s2 (cdr sm))) ; target | |
| 573 | 573 | (let* ((mod1 (sort-module s1)) |
| 574 | (mod2 (sort-module s2)) | |
| 575 | (a1 (cdr (assq mod1 (modmorph-module map))))) | |
| 576 | ;; s1.mod1 -> s2.mod2 | |
| 577 | ;; mod1 -> a1 | |
| 578 | ;; | |
| 579 | (when (and a1 (not (eq a1 (sort-module s2)))) | |
| 580 | ;;--- | |
| 581 | (when *on-modexp-debug* | |
| 582 | (format t "~&fix-sort-renaming : ") | |
| 583 | (format t "~& - ~a." (string (sort-id s1))) | |
| 584 | (print-modexp mod1) | |
| 585 | (format t "~& (=> ") (print-modexp a1) | |
| 586 | (format t ") --> ~a." (string (sort-id s2))) (print-modexp mod2)) | |
| 587 | ;;-- | |
| 588 | (setf (module-sorts newmod) (remove s2 (module-sorts newmod))) | |
| 589 | (setf (module-all-sorts newmod) (remove s2 (module-all-sorts newmod))) | |
| 590 | (let ((srt (or (modmorph-find-sort-in a1 (sort-id s2)) | |
| 591 | (modmorph-find-sort-in mod2 (sort-id s2)) | |
| 592 | ))) | |
| 593 | ;; (break) | |
| 594 | (unless srt (error "Sorry, PANIC! no sort image, could not fix.")) | |
| 595 | (add-sort-to-module srt newmod) | |
| 596 | (rplacd sm srt) | |
| 597 | (setf (sort-derived-from srt) s1) | |
| 598 | ) | |
| 599 | ) | |
| 600 | )) | |
| 574 | (mod2 (sort-module s2)) | |
| 575 | (a1 (cdr (assq mod1 (modmorph-module map))))) | |
| 576 | ;; s1.mod1 -> s2.mod2 | |
| 577 | ;; mod1 -> a1 | |
| 578 | ;; | |
| 579 | (when (and a1 (not (eq a1 (sort-module s2)))) | |
| 580 | ;;--- | |
| 581 | (when *on-modexp-debug* | |
| 582 | (format t "~%fix-sort-renaming : ") | |
| 583 | (format t "~& - ~a." (string (sort-id s1))) | |
| 584 | (print-modexp mod1) | |
| 585 | (format t "~& (=> ") (print-modexp a1) | |
| 586 | (format t ") --> ~a." (string (sort-id s2))) (print-modexp mod2)) | |
| 587 | ;;-- | |
| 588 | (setf (module-sorts newmod) (remove s2 (module-sorts newmod))) | |
| 589 | (setf (module-all-sorts newmod) (remove s2 (module-all-sorts newmod))) | |
| 590 | (let ((srt (or (modmorph-find-sort-in a1 (sort-id s2)) | |
| 591 | (modmorph-find-sort-in mod2 (sort-id s2)) | |
| 592 | ))) | |
| 593 | ;; (break) | |
| 594 | (unless srt (error "Sorry, PANIC! no sort image, could not fix.")) | |
| 595 | (add-sort-to-module srt newmod) | |
| 596 | (rplacd sm srt) | |
| 597 | (setf (sort-derived-from srt) s1) | |
| 598 | ) | |
| 599 | ) | |
| 600 | )) | |
| 601 | 601 | )) |
| 602 | 602 | |
| 603 | 603 | ;;; FIX-METHOD-RENAMING |
| 607 | 607 | (let ((modmap (modmorph-module map))) |
| 608 | 608 | (dolist (om (modmorph-op map)) |
| 609 | 609 | (let ((method-1 (car om)) |
| 610 | (method-2 (cddr om))) ; (source :simple-map . target) | |
| 610 | (method-2 (cddr om))) ; (source :simple-map . target) | |
| 611 | 611 | (let* ((mod1 (method-module method-1)) |
| 612 | 612 | (a1 (cdr (assq mod1 modmap)))) |
| 613 | 613 | (when (and a1 (not (eq a1 (method-module method-2)))) |
| 614 | #|| | |
| 615 | (with-output-panic-message () | |
| 616 | (break) | |
| 617 | (princ "sorry, please e-mail to sawada@sra.co.jp, say \"this happens\"") | |
| 618 | (chaos-to-top)) | |
| 619 | ||# | |
| 620 | (setf (method-module method-2) a1) ; is this really right? | |
| 621 | )))))) | |
| 614 | #|| | |
| 615 | (with-output-panic-message () | |
| 616 | (break) | |
| 617 | (princ "sorry, please e-mail to sawada@sra.co.jp, say \"this happens\"") | |
| 618 | (chaos-to-top)) | |
| 619 | ||# | |
| 620 | (setf (method-module method-2) a1) ; is this really right? | |
| 621 | )))))) | |
| 622 | 622 | |
| 623 | 623 | ;;; RENAME-RECREATE-THEORY |
| 624 | 624 | ;;; |
| 625 | 625 | (defun rename-recreate-theory (thy) |
| 626 | 626 | (if thy |
| 627 | 627 | (if (theory-contains-identity thy) |
| 628 | (let ((zero (theory-zero thy))) | |
| 629 | ;; (break) | |
| 630 | (setq zero (cons '%to-rename zero)) | |
| 631 | (theory-make (theory-info thy) zero)) | |
| 632 | thy) | |
| 628 | (let ((zero (theory-zero thy))) | |
| 629 | ;; (break) | |
| 630 | (setq zero (cons '%to-rename zero)) | |
| 631 | (theory-make (theory-info thy) zero)) | |
| 632 | thy) | |
| 633 | 633 | nil)) |
| 634 | 634 | |
| 635 | 635 | ;;; FIND-SOME-METHOD-IN |
| 636 | 636 | ;;; |
| 637 | 637 | (defun find-some-method-in (module arity coarity theory) |
| 638 | 638 | (declare (type module module) |
| 639 | (type list arity) | |
| 640 | (type sort* coarity) | |
| 641 | (type op-theory theory)) | |
| 639 | (type list arity) | |
| 640 | (type sort* coarity) | |
| 641 | (type op-theory theory)) | |
| 642 | 642 | (macrolet ((is-similar-theory? (th1_? th2_?) |
| 643 | (once-only (th1_? th2_?) | |
| 644 | ` (and (if (theory-contains-associativity ,th1_?) | |
| 645 | (theory-contains-associativity ,th2_?) | |
| 646 | t) | |
| 647 | (if (theory-contains-commutativity ,th1_?) | |
| 648 | (theory-contains-commutativity ,th2_?) | |
| 649 | t) | |
| 650 | (if (theory-contains-identity ,th1_?) | |
| 651 | (theory-contains-identity ,th2_?) | |
| 652 | t))))) | |
| 643 | (once-only (th1_? th2_?) | |
| 644 | ` (and (if (theory-contains-associativity ,th1_?) | |
| 645 | (theory-contains-associativity ,th2_?) | |
| 646 | t) | |
| 647 | (if (theory-contains-commutativity ,th1_?) | |
| 648 | (theory-contains-commutativity ,th2_?) | |
| 649 | t) | |
| 650 | (if (theory-contains-identity ,th1_?) | |
| 651 | (theory-contains-identity ,th2_?) | |
| 652 | t))))) | |
| 653 | 653 | (let ((opinfos (find-operators-num-args module (length arity)))) |
| 654 | 654 | (dolist (opinfo opinfos) |
| 655 | (let ((val (remove-if-not | |
| 656 | #'(lambda (method) | |
| 657 | (and (sort= coarity (method-coarity method)) | |
| 658 | (= (the fixnum (length arity)) | |
| 659 | (the fixnum (length (method-arity method)))) | |
| 660 | (every #'(lambda (s1 s2) | |
| 661 | (and s1 s2 | |
| 662 | (equal (sort-id s1) (sort-id s2)))) | |
| 663 | arity | |
| 664 | (method-arity method)) | |
| 665 | (is-similar-theory? theory | |
| 666 | (method-theory method | |
| 667 | (module-opinfo-table | |
| 668 | module))) | |
| 669 | )) | |
| 670 | (opinfo-methods opinfo)))) | |
| 671 | (when (and val (null (cdr val))) | |
| 672 | (return-from find-some-method-in (car val))))) | |
| 655 | (let ((val (remove-if-not | |
| 656 | #'(lambda (method) | |
| 657 | (and (sort= coarity (method-coarity method)) | |
| 658 | (= (the fixnum (length arity)) | |
| 659 | (the fixnum (length (method-arity method)))) | |
| 660 | (every #'(lambda (s1 s2) | |
| 661 | (and s1 s2 | |
| 662 | (equal (sort-id s1) (sort-id s2)))) | |
| 663 | arity | |
| 664 | (method-arity method)) | |
| 665 | (is-similar-theory? theory | |
| 666 | (method-theory method | |
| 667 | (module-opinfo-table | |
| 668 | module))) | |
| 669 | )) | |
| 670 | (opinfo-methods opinfo)))) | |
| 671 | (when (and val (null (cdr val))) | |
| 672 | (return-from find-some-method-in (car val))))) | |
| 673 | 673 | nil))) |
| 674 | 674 | |
| 675 | 675 | (defun recreate-renamed-sort (mod ren srt) |
| 676 | 676 | (let ((num 0) |
| 677 | (srtnm (sort-id srt)) | |
| 678 | (im nil)) | |
| 677 | (srtnm (sort-id srt)) | |
| 678 | (im nil)) | |
| 679 | 679 | (declare (type fixnum num)) |
| 680 | 680 | (dolist (s (module-all-sorts mod)) |
| 681 | 681 | (when (equal srtnm (sort-id s)) |
| 682 | (unless im (setq im s)) | |
| 683 | (incf num))) | |
| 682 | (unless im (setq im s)) | |
| 683 | (incf num))) | |
| 684 | 684 | (if (= 1 num) |
| 685 | im | |
| 686 | (let ((renmod (eval-modexp (%rename* (sort-module srt) ren)))) | |
| 687 | (dolist (s (module-all-sorts renmod)) | |
| 688 | (when (and (eq renmod (sort-module s)) | |
| 689 | (equal srtnm (sort-id s))) | |
| 690 | (return s))) | |
| 691 | )))) | |
| 685 | im | |
| 686 | (let ((renmod (eval-modexp (%rename* (sort-module srt) ren)))) | |
| 687 | (dolist (s (module-all-sorts renmod)) | |
| 688 | (when (and (eq renmod (sort-module s)) | |
| 689 | (equal srtnm (sort-id s))) | |
| 690 | (return s))) | |
| 691 | )))) | |
| 692 | 692 | |
| 693 | 693 | #|| the followings are not yet implemented properly. |
| 694 | 694 | |
| 695 | 695 | (defun find-renamed-method-named-in (srtmap mod opn) |
| 696 | 696 | (let ((opnm (if (check-enclosing-parens opn) (butlast (cdr opn)) opn))) |
| 697 | 697 | (if (member "->" (member ":" opnm :test #'equal) :test #'equal) |
| 698 | (let* ((pos1 (position ":" opnm :from-end t :test #'equal)) | |
| 699 | (pos2 (position "->" opnm :from-end t :test #'equal)) | |
| 700 | (op-symbol (subseq opnm 0 pos1)) | |
| 701 | (ar (subseq opnm (1+ pos1) pos2)) | |
| 702 | (coar (nth (1+ pos2) opnm))) | |
| 703 | (let ((val (find-method-from-rank ; * TO DO *-------- | |
| 704 | mod | |
| 705 | (append | |
| 706 | op-symbol '(":") | |
| 707 | (mapcar #'(lambda (x) | |
| 708 | (sort-id (*image-rename-sort srtmap x))) | |
| 709 | ar) | |
| 710 | '("->") | |
| 711 | (sort-id (*image-rename-sort srtmap coar))) | |
| 712 | ))) | |
| 713 | (when val (list val)))) | |
| 714 | (find-method-named-in mod opn)))) | |
| 698 | (let* ((pos1 (position ":" opnm :from-end t :test #'equal)) | |
| 699 | (pos2 (position "->" opnm :from-end t :test #'equal)) | |
| 700 | (op-symbol (subseq opnm 0 pos1)) | |
| 701 | (ar (subseq opnm (1+ pos1) pos2)) | |
| 702 | (coar (nth (1+ pos2) opnm))) | |
| 703 | (let ((val (find-method-from-rank ; * TO DO *-------- | |
| 704 | mod | |
| 705 | (append | |
| 706 | op-symbol '(":") | |
| 707 | (mapcar #'(lambda (x) | |
| 708 | (sort-id (*image-rename-sort srtmap x))) | |
| 709 | ar) | |
| 710 | '("->") | |
| 711 | (sort-id (*image-rename-sort srtmap coar))) | |
| 712 | ))) | |
| 713 | (when val (list val)))) | |
| 714 | (find-method-named-in mod opn)))) | |
| 715 | 715 | |
| 716 | 716 | (defun find-renamed-method-named-in-sort (srtmap mod srt opn) |
| 717 | 717 | (declare (ignore srtmap mod srt opn)) |
| 0 | 0 | ;;;-*- Mode:LISP; Package:CHAOS; Base:10; Syntax:Common-lisp -*- |
| 1 | 1 | ;;; |
| 2 | ;;; Copyright (c) 2000-2014, Toshimi Sawada. All rights reserved. | |
| 2 | ;;; Copyright (c) 2000-2015, Toshimi Sawada. All rights reserved. | |
| 3 | 3 | ;;; |
| 4 | 4 | ;;; Redistribution and use in source and binary forms, with or without |
| 5 | 5 | ;;; modification, are permitted provided that the following conditions |
| 27 | 27 | ;;; |
| 28 | 28 | (in-package :chaos) |
| 29 | 29 | #|============================================================================== |
| 30 | System: CHAOS | |
| 31 | Module: deCafe | |
| 32 | File: mutils.lisp | |
| 30 | System: CHAOS | |
| 31 | Module: deCafe | |
| 32 | File: mutils.lisp | |
| 33 | 33 | ==============================================================================|# |
| 34 | 34 | #-:chaos-debug |
| 35 | 35 | (declaim (optimize (speed 3) (safety 0) #-GCL (debug 0))) |
| 50 | 50 | (do ((r l (cdr r)) |
| 51 | 51 | (i 0 (1+ i)) |
| 52 | 52 | (res nil (cons (make-variable-term (term-sort (car r)) i) |
| 53 | res))) | |
| 53 | res))) | |
| 54 | 54 | ((null r) (nreverse res)) |
| 55 | 55 | (declare (type fixnum i)))) |
| 56 | 56 | |
| 66 | 66 | |
| 67 | 67 | (defun appropriate-method (srcmod module op) |
| 68 | 68 | (when (or (null module) |
| 69 | (not (member op | |
| 70 | (module-all-operators module) | |
| 71 | :test #'(lambda (x y) | |
| 72 | (operator= x (opinfo-operator y))) | |
| 73 | ))) | |
| 69 | (not (member op | |
| 70 | (module-all-operators module) | |
| 71 | :test #'(lambda (x y) | |
| 72 | (operator= x (opinfo-operator y))) | |
| 73 | ))) | |
| 74 | 74 | (setq module (operator-module op))) |
| 75 | 75 | (let ((arnum (operator-num-args op)) |
| 76 | ;; (theory (operator-theory op)) ; not used now | |
| 77 | ) | |
| 76 | ;; (theory (operator-theory op)) ; not used now | |
| 77 | ) | |
| 78 | 78 | (declare (type fixnum arnum)) |
| 79 | 79 | (let ((val (remove-if-not |
| 80 | #'(lambda (opinfo) | |
| 81 | (let ((opr (opinfo-operator opinfo))) | |
| 82 | (and (= arnum (the fixnum (operator-num-args opr))) | |
| 80 | #'(lambda (opinfo) | |
| 81 | (let ((opr (opinfo-operator opinfo))) | |
| 82 | (and (= arnum (the fixnum (operator-num-args opr))) | |
| 83 | 83 | ;; * todo * is-similar-theory |
| 84 | ;; (is-similar-theory (operator-theory opr) theory) | |
| 85 | (eq srcmod (operator-module opr))))) | |
| 86 | (module-all-operators srcmod)))) | |
| 84 | ;; (is-similar-theory (operator-theory opr) theory) | |
| 85 | (eq srcmod (operator-module opr))))) | |
| 86 | (module-all-operators srcmod)))) | |
| 87 | 87 | (if val |
| 88 | (if (null (cdr val)) | |
| 89 | (car val) | |
| 90 | nil) | |
| 91 | nil)))) | |
| 88 | (if (null (cdr val)) | |
| 89 | (car val) | |
| 90 | nil) | |
| 91 | nil)))) | |
| 92 | 92 | |
| 93 | 93 | (defun modexp-eval-principal-op (mod) |
| 94 | 94 | (let ((all-ops (module-all-operators mod))) |
| 101 | 101 | ;;; |
| 102 | 102 | (defun modmorph-check-rank (newmod oldmod map method) |
| 103 | 103 | (let ((modmap (modmorph-module map)) |
| 104 | (sortmap (modmorph-sort map)) | |
| 105 | (ar (method-arity method)) | |
| 106 | (coar (method-coarity method))) | |
| 104 | (sortmap (modmorph-sort map)) | |
| 105 | (ar (method-arity method)) | |
| 106 | (coar (method-coarity method))) | |
| 107 | 107 | (setf (method-arity method) |
| 108 | (modmorph-sorts-image-create newmod | |
| 109 | oldmod | |
| 110 | modmap | |
| 111 | sortmap | |
| 112 | ar)) | |
| 108 | (modmorph-sorts-image-create newmod | |
| 109 | oldmod | |
| 110 | modmap | |
| 111 | sortmap | |
| 112 | ar)) | |
| 113 | 113 | (setf (method-coarity method) |
| 114 | (modmorph-sort-image-create newmod | |
| 115 | oldmod | |
| 116 | modmap | |
| 117 | sortmap | |
| 118 | coar)) | |
| 114 | (modmorph-sort-image-create newmod | |
| 115 | oldmod | |
| 116 | modmap | |
| 117 | sortmap | |
| 118 | coar)) | |
| 119 | 119 | )) |
| 120 | 120 | |
| 0 | 0 | ;;;-*- Mode:LISP; Package:CHAOS; Base:10; Syntax:Common-lisp -*- |
| 1 | 1 | ;;; |
| 2 | ;;; Copyright (c) 2000-2014, Toshimi Sawada. All rights reserved. | |
| 2 | ;;; Copyright (c) 2000-2015, Toshimi Sawada. All rights reserved. | |
| 3 | 3 | ;;; |
| 4 | 4 | ;;; Redistribution and use in source and binary forms, with or without |
| 5 | 5 | ;;; modification, are permitted provided that the following conditions |
| 27 | 27 | ;;; |
| 28 | 28 | (in-package :chaos) |
| 29 | 29 | #|============================================================================== |
| 30 | System: CHAOS | |
| 31 | Module: deCafe | |
| 32 | File: view.lisp | |
| 30 | System: CHAOS | |
| 31 | Module: deCafe | |
| 32 | File: view.lisp | |
| 33 | 33 | ==============================================================================|# |
| 34 | 34 | #-:chaos-debug |
| 35 | 35 | (declaim (optimize (speed 3) (safety 0) #-GCL (debug 0))) |
| 53 | 53 | |
| 54 | 54 | (defun views-to-modmorph (mod args &optional (warn t)) |
| 55 | 55 | (let* ((morphs (mapcar #'(lambda (arg) |
| 56 | (view->modmorph mod arg)) | |
| 57 | args)) | |
| 58 | (m-morph (car morphs))) | |
| 56 | (view->modmorph mod arg)) | |
| 57 | args)) | |
| 58 | (m-morph (car morphs))) | |
| 59 | 59 | (dolist (m (cdr morphs)) |
| 60 | 60 | (setq m-morph (modmorph-merge m-morph m warn))) |
| 61 | 61 | m-morph)) |
| 63 | 63 | (defun view->modmorph (mod arg) |
| 64 | 64 | (let ((arg-name (%!arg-name arg))) |
| 65 | 65 | (when (and (consp arg-name) |
| 66 | (cdr arg-name)) | |
| 66 | (cdr arg-name)) | |
| 67 | 67 | (setq arg-name |
| 68 | (cons (car arg-name) | |
| 69 | ;; also local | |
| 70 | (eval-modexp (cdr arg-name) t)))) | |
| 68 | (cons (car arg-name) | |
| 69 | ;; also local | |
| 70 | (eval-modexp (cdr arg-name) t)))) | |
| 71 | 71 | (let ((ath (find-parameterized-submodule arg-name mod)) |
| 72 | (vw (%!arg-view arg))) | |
| 72 | (vw (%!arg-view arg))) | |
| 73 | 73 | (when (or (modexp-is-error ath) (null ath)) |
| 74 | (with-output-panic-message () | |
| 75 | (format t "could not find theory module specified by the argument ~s" | |
| 76 | (%!arg-name arg)) | |
| 77 | (chaos-error 'panic))) | |
| 74 | (with-output-panic-message () | |
| 75 | (format t "could not find theory module specified by the argument ~s" | |
| 76 | (%!arg-name arg)) | |
| 77 | (chaos-error 'panic))) | |
| 78 | 78 | (convert-view-to-modmorph ath vw)))) |
| 79 | 79 | |
| 80 | 80 | ;;; CONVERT-VIEW-TO-MODMORPH ath avw |
| 91 | 91 | (setq avw (make-real-view ath avw))) |
| 92 | 92 | ;; |
| 93 | 93 | (let ((modm (acons ath |
| 94 | avw ; needs to be the view itself | |
| 95 | ; to allow proper composition. | |
| 96 | nil)) | |
| 97 | (sortm (view-sort-maps avw)) | |
| 98 | (opm (mapcar #'(lambda (x) | |
| 99 | (if (operator-method-p (car x)) | |
| 100 | ;; no need to convert | |
| 101 | x | |
| 102 | (cons (term-head (car x)) | |
| 103 | `(:replacement ,(term-subterms (car x)) | |
| 104 | ,(cadr x))))) | |
| 105 | (view-op-maps avw))) | |
| 106 | (modmorph nil)) | |
| 94 | avw ; needs to be the view itself | |
| 95 | ; to allow proper composition. | |
| 96 | nil)) | |
| 97 | (sortm (view-sort-maps avw)) | |
| 98 | (opm (mapcar #'(lambda (x) | |
| 99 | (if (operator-method-p (car x)) | |
| 100 | ;; no need to convert | |
| 101 | x | |
| 102 | (cons (term-head (car x)) | |
| 103 | `(:replacement ,(term-subterms (car x)) | |
| 104 | ,(cadr x))))) | |
| 105 | (view-op-maps avw))) | |
| 106 | (modmorph nil)) | |
| 107 | 107 | (setq modmorph (create-modmorph `(%map ,ath ,avw) sortm opm modm)) |
| 108 | 108 | ;; |
| 109 | 109 | #|| |
| 110 | 110 | (when (int-instantiation-p (view-target avw)) |
| 111 | 111 | ;; target is another instantiation |
| 112 | 112 | (let ((mappg (views-to-modmorph (int-instantiation-module (view-target avw)) |
| 113 | (int-instantiation-args (view-target avw)) | |
| 114 | nil))) | |
| 115 | (setq modmorph (modmorph-merge modmorph mappg nil)))) | |
| 113 | (int-instantiation-args (view-target avw)) | |
| 114 | nil))) | |
| 115 | (setq modmorph (modmorph-merge modmorph mappg nil)))) | |
| 116 | 116 | ||# |
| 117 | 117 | modmorph |
| 118 | 118 | )) |
| 124 | 124 | #|| |
| 125 | 125 | (defun make-real-view (ath avw) |
| 126 | 126 | (labels ((find-sort-or-error (sort) |
| 127 | (or (find-sort-in ath (sort-id sort)) | |
| 128 | (with-output-chaos-error ('no-such-sort) | |
| 129 | (format t "constructing view, no such sort ~a in " (sort-id sort)) | |
| 130 | (print-mod-name ath *standard-output* t t) | |
| 131 | ))) | |
| 132 | (find-method-or-error (method) | |
| 133 | (or (find-method-in (method-symbol ath) | |
| 134 | (mapcar #'find-sort-or-error (method-arity method)) | |
| 135 | (find-sort-or-error (method-coarity method))) | |
| 136 | (with-output-chaos-error ('no-such-sort) | |
| 137 | (princ "constructing view:") | |
| 138 | (print-next) | |
| 139 | (princ "~&no such operator ") | |
| 140 | (print-chaos-object method) | |
| 141 | (print-next) | |
| 142 | (princ "in module ") | |
| 143 | (print-mod-name ath *standard-output* t t) | |
| 144 | ))) | |
| 145 | ) | |
| 127 | (or (find-sort-in ath (sort-id sort)) | |
| 128 | (with-output-chaos-error ('no-such-sort) | |
| 129 | (format t "constructing view, no such sort ~a in " (sort-id sort)) | |
| 130 | (print-mod-name ath *standard-output* t t) | |
| 131 | ))) | |
| 132 | (find-method-or-error (method) | |
| 133 | (or (find-method-in (method-symbol ath) | |
| 134 | (mapcar #'find-sort-or-error (method-arity method)) | |
| 135 | (find-sort-or-error (method-coarity method))) | |
| 136 | (with-output-chaos-error ('no-such-sort) | |
| 137 | (princ "constructing view:") | |
| 138 | (print-next) | |
| 139 | (princ "~%no such operator ") | |
| 140 | (print-chaos-object method) | |
| 141 | (print-next) | |
| 142 | (princ "in module ") | |
| 143 | (print-mod-name ath *standard-output* t t) | |
| 144 | ))) | |
| 145 | ) | |
| 146 | 146 | (let (sort-mapping |
| 147 | op-mapping | |
| 148 | new-view) | |
| 147 | op-mapping | |
| 148 | new-view) | |
| 149 | 149 | (setq sort-mapping |
| 150 | (mapcar #'(lambda (x) | |
| 151 | (cons (find-sort-or-error (car x)) | |
| 152 | (cdr x))) | |
| 153 | (view-sort-maps avw))) | |
| 150 | (mapcar #'(lambda (x) | |
| 151 | (cons (find-sort-or-error (car x)) | |
| 152 | (cdr x))) | |
| 153 | (view-sort-maps avw))) | |
| 154 | 154 | (setq op-mapping |
| 155 | (mapcar #'(lambda (x) | |
| 156 | (cons (term-head (car x)) | |
| 157 | `(:replacement ,(term-subterms (car x)) ,(cdr x)))) | |
| 158 | (mapcar #'(lambda (v) | |
| 159 | (cons (let ((method (term-head (car v)))) | |
| 160 | (make-term-check-op | |
| 161 | (find-method-or-error method | |
| 162 | ath | |
| 163 | (method-symbol method) | |
| 164 | (mapcar #'(lambda (s) | |
| 165 | (find-sort-in ath | |
| 166 | (sort-id s))) | |
| 167 | (method-arity method)) | |
| 168 | (find-sort-in ath | |
| 169 | (sort-id (method-coarity | |
| 170 | method)))) | |
| 171 | (term-subterms (car v)))) | |
| 172 | (cadr v))) | |
| 173 | (view-op-maps avw)))) | |
| 155 | (mapcar #'(lambda (x) | |
| 156 | (cons (term-head (car x)) | |
| 157 | `(:replacement ,(term-subterms (car x)) ,(cdr x)))) | |
| 158 | (mapcar #'(lambda (v) | |
| 159 | (cons (let ((method (term-head (car v)))) | |
| 160 | (make-term-check-op | |
| 161 | (find-method-or-error method | |
| 162 | ath | |
| 163 | (method-symbol method) | |
| 164 | (mapcar #'(lambda (s) | |
| 165 | (find-sort-in ath | |
| 166 | (sort-id s))) | |
| 167 | (method-arity method)) | |
| 168 | (find-sort-in ath | |
| 169 | (sort-id (method-coarity | |
| 170 | method)))) | |
| 171 | (term-subterms (car v)))) | |
| 172 | (cadr v))) | |
| 173 | (view-op-maps avw)))) | |
| 174 | 174 | (setq new-view (view-struct* (view-struct-name avw))) |
| 175 | 175 | (setf (view-src new-view) ath) |
| 176 | 176 | (setf (view-target new-view) (view-target avw)) |
| 200 | 200 | (defun view-map-image-sort (mod x sort-map) |
| 201 | 201 | (let ((val (find-if #'(lambda (v) (sort= x (car v))) sort-map))) |
| 202 | 202 | (if val |
| 203 | (cdr val) | |
| 204 | (if (memq x (module-all-sorts mod)) | |
| 205 | x | |
| 206 | (let ((val2 (find-sort-in mod (sort-id x)))) | |
| 207 | (if val2 val2 x)))))) | |
| 203 | (cdr val) | |
| 204 | (if (memq x (module-all-sorts mod)) | |
| 205 | x | |
| 206 | (let ((val2 (find-sort-in mod (sort-id x)))) | |
| 207 | (if val2 val2 x)))))) | |
| 208 | 208 | |
| 209 | 209 | (defun view-map-image-sorts (mod l sort-map) |
| 210 | 210 | (mapcar #'(lambda (x) (view-map-image-sort mod x sort-map)) |
| 211 | l)) | |
| 211 | l)) | |
| 212 | 212 | |
| 213 | 213 | ;;; |
| 214 | 214 | ;;; COMPLETE-VIEW |
| 215 | 215 | ;;; |
| 216 | 216 | (defun complete-view (vw &optional arg-name mod pre-map) |
| 217 | 217 | (let ((view nil) |
| 218 | (source-module nil)) | |
| 218 | (source-module nil)) | |
| 219 | 219 | ;; |
| 220 | 220 | ;; construct the view object to be used for instantiation process. |
| 221 | 221 | ;; |
| 222 | 222 | (let ((target (if (eq 'none (%view-target vw)) |
| 223 | (with-output-chaos-error ('modexp-eval) | |
| 224 | (princ "target module cannot be omitted in view.") | |
| 225 | ) | |
| 226 | (%view-target vw)))) | |
| 223 | (with-output-chaos-error ('modexp-eval) | |
| 224 | (princ "target module cannot be omitted in view.") | |
| 225 | ) | |
| 226 | (%view-target vw)))) | |
| 227 | 227 | ;; evaluate source |
| 228 | (cond (arg-name ;formal argument name --> theory module | |
| 229 | ;; resolve qualification in arg-name | |
| 230 | (when (and (consp arg-name) (cdr arg-name)) | |
| 231 | ;; qualified view (arg-name . context) | |
| 232 | (setq arg-name (cons (car arg-name) | |
| 233 | ;; also local | |
| 234 | (eval-modexp (cdr arg-name) t))) | |
| 235 | (when (modexp-is-error (cdr arg-name)) | |
| 236 | (with-output-chaos-error ('modexp-eval) | |
| 237 | (format t "error in argument name : no such module ~a." (cdr arg-name)) | |
| 238 | ))) | |
| 239 | (setq source-module (find-parameterized-submodule arg-name mod))) | |
| 240 | (t (setq source-module (eval-modexp (%view-module vw) t)))) | |
| 228 | (cond (arg-name ;formal argument name --> theory module | |
| 229 | ;; resolve qualification in arg-name | |
| 230 | (when (and (consp arg-name) (cdr arg-name)) | |
| 231 | ;; qualified view (arg-name . context) | |
| 232 | (setq arg-name (cons (car arg-name) | |
| 233 | ;; also local | |
| 234 | (eval-modexp (cdr arg-name) t))) | |
| 235 | (when (modexp-is-error (cdr arg-name)) | |
| 236 | (with-output-chaos-error ('modexp-eval) | |
| 237 | (format t "error in argument name : no such module ~a." (cdr arg-name)) | |
| 238 | ))) | |
| 239 | (setq source-module (find-parameterized-submodule arg-name mod))) | |
| 240 | (t (setq source-module (eval-modexp (%view-module vw) t)))) | |
| 241 | 241 | (when (modexp-is-error source-module) |
| 242 | (with-output-chaos-error ('modexp-eval) | |
| 243 | (cond (arg-name | |
| 244 | (format t "no such parameter ~a" (if (consp arg-name) | |
| 245 | (car arg-name) | |
| 246 | arg-name)) | |
| 247 | (print-next) | |
| 248 | (princ "in module ") | |
| 249 | (print-mod-name mod)) | |
| 250 | (t (format t "could not evaluate view source module ~a" (%view-module vw)))) | |
| 251 | )) | |
| 242 | (with-output-chaos-error ('modexp-eval) | |
| 243 | (cond (arg-name | |
| 244 | (format t "no such parameter ~a" (if (consp arg-name) | |
| 245 | (car arg-name) | |
| 246 | arg-name)) | |
| 247 | (print-next) | |
| 248 | (princ "in module ") | |
| 249 | (print-mod-name mod)) | |
| 250 | (t (format t "could not evaluate view source module ~a" (%view-module vw)))) | |
| 251 | )) | |
| 252 | 252 | ;; |
| 253 | 253 | (when (modexp-is-?name? target) |
| 254 | (setq target (?name-name target))) | |
| 254 | (setq target (?name-name target))) | |
| 255 | 255 | ;; target can be a predefined view name. |
| 256 | 256 | (when (stringp target) |
| 257 | (setq view (find-view-in-env (normalize-modexp target))) | |
| 258 | (when (and view (view-is-inconsistent view)) | |
| 259 | ;; reconstruct from the scratch | |
| 260 | ;; view will be updated by side-effect. | |
| 261 | (eval-modexp (view-decl-form view)) | |
| 262 | ;; set dependency relation | |
| 263 | (add-depend-relation mod :view view))) | |
| 257 | (setq view (find-view-in-env (normalize-modexp target))) | |
| 258 | (when (and view (view-is-inconsistent view)) | |
| 259 | ;; reconstruct from the scratch | |
| 260 | ;; view will be updated by side-effect. | |
| 261 | (eval-modexp (view-decl-form view)) | |
| 262 | ;; set dependency relation | |
| 263 | (add-depend-relation mod :view view))) | |
| 264 | 264 | ;; |
| 265 | 265 | (if view |
| 266 | view | |
| 267 | ;; we construct a brand new view object. | |
| 268 | (progn | |
| 269 | (setq view (create-view source-module | |
| 270 | target | |
| 271 | (%view-map vw) | |
| 272 | pre-map)) | |
| 273 | (mark-view-as-consistent view) | |
| 274 | (setf (view-decl-form view) vw) | |
| 275 | view))))) | |
| 266 | view | |
| 267 | ;; we construct a brand new view object. | |
| 268 | (progn | |
| 269 | (setq view (create-view source-module | |
| 270 | target | |
| 271 | (%view-map vw) | |
| 272 | pre-map)) | |
| 273 | (mark-view-as-consistent view) | |
| 274 | (setf (view-decl-form view) vw) | |
| 275 | view))))) | |
| 276 | 276 | |
| 277 | 277 | ;;; |
| 278 | 278 | ;;; CREATE-VIEW |
| 280 | 280 | (defun principal-sort (module) |
| 281 | 281 | (or (module-principal-sort module) |
| 282 | 282 | (let ((sorts (module-all-sorts module))) |
| 283 | (if (null (cdr sorts)) | |
| 284 | (car sorts) | |
| 285 | (if (not (module-is-hard-wired module)) | |
| 286 | (progn | |
| 287 | (setq sorts | |
| 288 | (remove-if #'(lambda (x) (module-is-hard-wired (sort-module x))) | |
| 289 | sorts)) | |
| 290 | (if (null (cdr sorts)) | |
| 291 | (car sorts) | |
| 292 | nil)) | |
| 293 | nil))))) | |
| 283 | (if (null (cdr sorts)) | |
| 284 | (car sorts) | |
| 285 | (if (not (module-is-hard-wired module)) | |
| 286 | (progn | |
| 287 | (setq sorts | |
| 288 | (remove-if #'(lambda (x) (module-is-hard-wired (sort-module x))) | |
| 289 | sorts)) | |
| 290 | (if (null (cdr sorts)) | |
| 291 | (car sorts) | |
| 292 | nil)) | |
| 293 | nil))))) | |
| 294 | 294 | |
| 295 | 295 | #|| |
| 296 | 296 | (defun create-view (th mod rename-map) |
| 297 | 297 | (let ((vw-map (if (%is-rmap rename-map) |
| 298 | (%rmap-map rename-map) | |
| 299 | rename-map))) | |
| 298 | (%rmap-map rename-map) | |
| 299 | rename-map))) | |
| 300 | 300 | ;; |
| 301 | 301 | ;; eval source & target module |
| 302 | 302 | ;; |
| 303 | (let ((src-mod (eval-modexp th t)) ; should already evaluated but.. | |
| 304 | (dst-mod (eval-modexp mod t))) ; really evaluate the target. | |
| 303 | (let ((src-mod (eval-modexp th t)) ; should already evaluated but.. | |
| 304 | (dst-mod (eval-modexp mod t))) ; really evaluate the target. | |
| 305 | 305 | (when (or (modexp-is-error src-mod) (modexp-is-error dst-mod)) |
| 306 | ;; error, ivalid args as modules | |
| 307 | (with-output-chaos-error ('modexp-eval) | |
| 308 | (princ "Cannot evaluate module in view: ") | |
| 309 | (when (modexp-is-error src-mod) | |
| 310 | (princ "view source = ") | |
| 311 | (print-modexp th)) | |
| 312 | (when (modexp-is-error dst-mod) | |
| 313 | (when (modexp-is-error src-mod) | |
| 314 | (princ ", and ")) | |
| 315 | (princ "view target = ") | |
| 316 | (print-modexp mod)) | |
| 317 | )) | |
| 306 | ;; error, ivalid args as modules | |
| 307 | (with-output-chaos-error ('modexp-eval) | |
| 308 | (princ "Cannot evaluate module in view: ") | |
| 309 | (when (modexp-is-error src-mod) | |
| 310 | (princ "view source = ") | |
| 311 | (print-modexp th)) | |
| 312 | (when (modexp-is-error dst-mod) | |
| 313 | (when (modexp-is-error src-mod) | |
| 314 | (princ ", and ")) | |
| 315 | (princ "view target = ") | |
| 316 | (print-modexp mod)) | |
| 317 | )) | |
| 318 | 318 | ;; |
| 319 | 319 | ;; compute mappings. |
| 320 | 320 | ;; |
| 321 | 321 | (let ((sort-maps (cadr (assq '%ren-sort vw-map))) |
| 322 | (op-maps (cadr (assq '%ren-op vw-map))) | |
| 323 | (hsort-maps (cadr (assq '%ren-hsort vw-map))) | |
| 324 | (bop-maps (cadr (assq '%ren-bop vw-map))) | |
| 325 | (vars (cadr (assq '%vars vw-map))) | |
| 326 | (pr (principal-sort src-mod)) | |
| 327 | ; NOW we support. May/'97 | |
| 328 | ) | |
| 329 | ;; | |
| 330 | ;; ** compute sort mappings --------------------------------- | |
| 331 | ;; | |
| 332 | (let ((sort-mapping (compute-sort-mappings src-mod | |
| 333 | dst-mod | |
| 334 | sort-maps | |
| 335 | hsort-maps))) | |
| 336 | ;; make sort mappings with completing sort maps not explicitly | |
| 337 | ;; specified. | |
| 338 | (dolist (s (module-all-sorts src-mod)) | |
| 339 | (unless (*find-sort-in-map sort-mapping s) | |
| 340 | ;; map is not specified. | |
| 341 | (let ((val (find-sort-in dst-mod (sort-id s) t))) | |
| 342 | (when (eq s pr) ; is this the principal sort? | |
| 343 | (let ((pval (principal-sort dst-mod))) | |
| 344 | (when pval | |
| 345 | (setq val pval)))) | |
| 346 | ;; find compatible same name sort --- | |
| 347 | ;; should check types,i.e., visible & hidden. | |
| 348 | (if val | |
| 349 | (unless (sort= s val) | |
| 350 | (push (cons s val) sort-mapping)) | |
| 351 | (with-output-chaos-warning () | |
| 352 | (princ "view incomplete for sort ") | |
| 353 | (print-chaos-object s) | |
| 354 | (print-next) | |
| 355 | (princ "view from ") | |
| 356 | (print-chaos-object src-mod) | |
| 357 | (princ " to ") | |
| 358 | (print-chaos-object dst-mod) | |
| 359 | (print-next) | |
| 360 | (princ "!! MAY BE HARMFUL !!") | |
| 361 | ;; (chaos-error 'modexp-eval) | |
| 362 | ) | |
| 363 | ) | |
| 364 | ))) | |
| 365 | ;; | |
| 366 | ;; ** compute operator mapping ------------------------------------ | |
| 367 | ;; | |
| 368 | (let* ((src-vars | |
| 369 | (mapcan #'(lambda (x) | |
| 370 | (let ((sort (find-sort-in src-mod | |
| 371 | (cadr x)))) | |
| 372 | (unless sort | |
| 373 | (with-output-chaos-error ('modexp-eval) | |
| 374 | (format t "sort ~a not found in view variable" | |
| 375 | (cadr x)) | |
| 376 | )) | |
| 377 | (mapcar #'(lambda (y) | |
| 378 | (make-variable-term sort | |
| 379 | (if (stringp y) | |
| 380 | (intern y) | |
| 381 | y))) | |
| 382 | (car x)))) | |
| 383 | vars)) | |
| 384 | (dst-vars | |
| 385 | (mapcar #'(lambda (x) | |
| 386 | (let ((val (cdr (assq (variable-sort x) | |
| 387 | sort-mapping)))) | |
| 388 | (if val | |
| 389 | (make-variable-term val (variable-name x)) | |
| 390 | x))) | |
| 391 | src-vars)) | |
| 392 | ;; | |
| 393 | (op-mapping (compute-op-mappings src-mod | |
| 394 | dst-mod | |
| 395 | sort-mapping | |
| 396 | op-maps | |
| 397 | bop-maps | |
| 398 | src-vars | |
| 399 | dst-vars | |
| 400 | ))) | |
| 401 | ;; now op-mapping is in form of ( op-map ... ), | |
| 402 | ;; where op-map is | |
| 403 | ;; (source-pattern target-pattern) | |
| 404 | ;; this will be converted to operator map of modmorhp: | |
| 405 | ;; (method :replacement List[psuedo-var] target-pattern) | |
| 406 | ;; >> *NOTE* we do not use ':simple-map for view. | |
| 407 | ;; we are now about to complete method mapping. | |
| 408 | ;; >> *NOTE* handle constants last. | |
| 409 | ;; make method map with the same name iff not mapped already. | |
| 410 | ;; | |
| 411 | (dolist (oinfo (module-all-operators src-mod)) | |
| 412 | (dolist (method (opinfo-methods oinfo)) | |
| 413 | (block next-method | |
| 414 | (let ((target-method nil)) | |
| 415 | (when (and | |
| 416 | (or (method-is-user-defined-error-method method) | |
| 417 | (not (method-is-error-method method))) | |
| 418 | (let ((xmod (method-module method))) | |
| 419 | (not | |
| 420 | (memq xmod *kernel-hard-wired-builtin-modules*)) | |
| 421 | )) | |
| 422 | (unless (*find-method-in-map op-mapping method) | |
| 423 | ;; | |
| 424 | ;; not in the map | |
| 425 | ;; | |
| 426 | (when *on-view-debug* | |
| 427 | (format t "~&[create-view] :") | |
| 428 | (format t "~&-find non-specified method ") | |
| 429 | (print-method method) | |
| 430 | (format t "~&-try finding in module ") | |
| 431 | (print-mod-name dst-mod)) | |
| 432 | ;; find in destination module with | |
| 433 | ;; name, arity and coarity mapped by sort-map. | |
| 434 | (unless (sort= (method-coarity method) *sort-id-sort*) | |
| 435 | (setq target-method | |
| 436 | (find-method-in dst-mod | |
| 437 | (method-symbol method) | |
| 438 | (view-map-image-sorts | |
| 439 | dst-mod | |
| 440 | (method-arity method) | |
| 441 | sort-mapping) | |
| 442 | (view-map-image-sort | |
| 443 | dst-mod | |
| 444 | (method-coarity method) | |
| 445 | sort-mapping))) | |
| 446 | (unless target-method | |
| 447 | ;; failed to find. | |
| 448 | ;; we continue, but may cause big problem later | |
| 449 | ;; so gives a warning. | |
| 450 | (with-output-chaos-warning () | |
| 451 | (princ "view incomplete for operator ") | |
| 452 | (print-method method) | |
| 453 | (princ " of ") | |
| 454 | (print-mod-name src-mod) | |
| 455 | (print-next) | |
| 456 | (princ "view to ") | |
| 457 | (print-mod-name dst-mod) | |
| 458 | (print-next) | |
| 459 | (princ "!! MAY CAUSE PANIC LATER !!")) | |
| 460 | (return-from next-method nil) | |
| 461 | ) | |
| 462 | ||
| 463 | ;; | |
| 464 | ;; found the target-method in dst-mod, | |
| 465 | ;; i.e., with the same name & has proper rank. | |
| 466 | ;; | |
| 467 | (unless (eq method target-method) | |
| 468 | ;; construct map iff they are different object. | |
| 469 | (let ((vars (make-psuedo-vars-from-sorts | |
| 470 | (method-arity method)))) | |
| 471 | (when *on-view-debug* | |
| 472 | (format t "~&-*creating new op-mapping ") | |
| 473 | (format t "~& from ") | |
| 474 | (print-method method) | |
| 475 | (format t "~& to ") | |
| 476 | (print-method target-method)) | |
| 477 | (push (list (make-term-check-op method vars src-mod) | |
| 478 | (make-term-check-op target-method | |
| 479 | vars | |
| 480 | dst-mod)) | |
| 481 | op-mapping) | |
| 482 | ) | |
| 483 | ;; | |
| 484 | (let ((thy1 (method-theory method | |
| 485 | (module-opinfo-table src-mod))) | |
| 486 | (thy2 (method-theory target-method | |
| 487 | (module-opinfo-table dst-mod)))) | |
| 488 | (let ((z1 (car (theory-zero thy1))) | |
| 489 | (z2 (car (theory-zero thy2)))) | |
| 490 | (when (and z1 | |
| 491 | (not (*find-method-in-map op-mapping | |
| 492 | (term-head z1))) | |
| 493 | z2 | |
| 494 | (term-is-constant? z1) | |
| 495 | (term-is-constant? z2)) | |
| 496 | (push (list z1 z2) | |
| 497 | op-mapping)))))))))))) | |
| 498 | ;; | |
| 499 | ;; make SortId op mappings | |
| 500 | ;; | |
| 501 | (let ((s-op nil) | |
| 502 | (t-op nil) | |
| 503 | (ignore-these (list *cosmos* *universal-sort* | |
| 504 | *huniversal-sort* *bottom-sort*))) | |
| 505 | (dolist (s-map sort-mapping) | |
| 506 | (let ((source (car s-map)) | |
| 507 | (target (cdr s-map))) | |
| 508 | (break) | |
| 509 | (unless (or (err-sort-p source) | |
| 510 | (memq source ignore-these) | |
| 511 | (memq target ignore-these)) | |
| 512 | (setq s-op (find-method-in src-mod | |
| 513 | (string (sort-id source)) | |
| 514 | nil | |
| 515 | *sort-id-sort*)) | |
| 516 | (unless (*find-method-in-map op-mapping s-op) | |
| 517 | (setq t-op (find-method-in dst-mod | |
| 518 | (string (sort-id target)) | |
| 519 | nil | |
| 520 | *sort-id-sort*)) | |
| 521 | (push (list (make-term-check-op s-op nil src-mod) | |
| 522 | (make-term-check-op t-op nil dst-mod)) | |
| 523 | op-mapping)))))) | |
| 524 | ||
| 525 | ;; | |
| 526 | ;; final result | |
| 527 | ;; | |
| 528 | (let ((view (view-struct* :anon-view))) | |
| 529 | (initialize-view view) | |
| 530 | (setf (view-src view) src-mod | |
| 531 | (view-target view) dst-mod | |
| 532 | (view-sort-maps view) sort-mapping | |
| 533 | (view-op-maps view) op-mapping) | |
| 534 | ;; | |
| 535 | (when *on-view-debug* | |
| 536 | (format t "~%[generated view]:") | |
| 537 | (format t "~& source = ") (print-chaos-object src-mod) | |
| 538 | (format t "~& target = ") (print-chaos-object dst-mod) | |
| 539 | (format t "~& sort-map = ") | |
| 540 | (dolist (smap sort-mapping) | |
| 541 | (terpri) | |
| 542 | (print-chaos-object smap)) | |
| 543 | (format t "~& op-map =") | |
| 544 | (dolist (opmap op-mapping) | |
| 545 | (terpri) | |
| 546 | (print-term-method (car opmap)) | |
| 547 | (princ " --> ") | |
| 548 | (princ (cdr opmap)) | |
| 549 | ;; (print-chaos-object opmap) | |
| 550 | )) | |
| 551 | ;; | |
| 552 | view) | |
| 553 | )))))) | |
| 322 | (op-maps (cadr (assq '%ren-op vw-map))) | |
| 323 | (hsort-maps (cadr (assq '%ren-hsort vw-map))) | |
| 324 | (bop-maps (cadr (assq '%ren-bop vw-map))) | |
| 325 | (vars (cadr (assq '%vars vw-map))) | |
| 326 | (pr (principal-sort src-mod)) | |
| 327 | ; NOW we support. May/'97 | |
| 328 | ) | |
| 329 | ;; | |
| 330 | ;; ** compute sort mappings --------------------------------- | |
| 331 | ;; | |
| 332 | (let ((sort-mapping (compute-sort-mappings src-mod | |
| 333 | dst-mod | |
| 334 | sort-maps | |
| 335 | hsort-maps))) | |
| 336 | ;; make sort mappings with completing sort maps not explicitly | |
| 337 | ;; specified. | |
| 338 | (dolist (s (module-all-sorts src-mod)) | |
| 339 | (unless (*find-sort-in-map sort-mapping s) | |
| 340 | ;; map is not specified. | |
| 341 | (let ((val (find-sort-in dst-mod (sort-id s) t))) | |
| 342 | (when (eq s pr) ; is this the principal sort? | |
| 343 | (let ((pval (principal-sort dst-mod))) | |
| 344 | (when pval | |
| 345 | (setq val pval)))) | |
| 346 | ;; find compatible same name sort --- | |
| 347 | ;; should check types,i.e., visible & hidden. | |
| 348 | (if val | |
| 349 | (unless (sort= s val) | |
| 350 | (push (cons s val) sort-mapping)) | |
| 351 | (with-output-chaos-warning () | |
| 352 | (princ "view incomplete for sort ") | |
| 353 | (print-chaos-object s) | |
| 354 | (print-next) | |
| 355 | (princ "view from ") | |
| 356 | (print-chaos-object src-mod) | |
| 357 | (princ " to ") | |
| 358 | (print-chaos-object dst-mod) | |
| 359 | (print-next) | |
| 360 | (princ "!! MAY BE HARMFUL !!") | |
| 361 | ;; (chaos-error 'modexp-eval) | |
| 362 | ) | |
| 363 | ) | |
| 364 | ))) | |
| 365 | ;; | |
| 366 | ;; ** compute operator mapping ------------------------------------ | |
| 367 | ;; | |
| 368 | (let* ((src-vars | |
| 369 | (mapcan #'(lambda (x) | |
| 370 | (let ((sort (find-sort-in src-mod | |
| 371 | (cadr x)))) | |
| 372 | (unless sort | |
| 373 | (with-output-chaos-error ('modexp-eval) | |
| 374 | (format t "sort ~a not found in view variable" | |
| 375 | (cadr x)) | |
| 376 | )) | |
| 377 | (mapcar #'(lambda (y) | |
| 378 | (make-variable-term sort | |
| 379 | (if (stringp y) | |
| 380 | (intern y) | |
| 381 | y))) | |
| 382 | (car x)))) | |
| 383 | vars)) | |
| 384 | (dst-vars | |
| 385 | (mapcar #'(lambda (x) | |
| 386 | (let ((val (cdr (assq (variable-sort x) | |
| 387 | sort-mapping)))) | |
| 388 | (if val | |
| 389 | (make-variable-term val (variable-name x)) | |
| 390 | x))) | |
| 391 | src-vars)) | |
| 392 | ;; | |
| 393 | (op-mapping (compute-op-mappings src-mod | |
| 394 | dst-mod | |
| 395 | sort-mapping | |
| 396 | op-maps | |
| 397 | bop-maps | |
| 398 | src-vars | |
| 399 | dst-vars | |
| 400 | ))) | |
| 401 | ;; now op-mapping is in form of ( op-map ... ), | |
| 402 | ;; where op-map is | |
| 403 | ;; (source-pattern target-pattern) | |
| 404 | ;; this will be converted to operator map of modmorhp: | |
| 405 | ;; (method :replacement List[psuedo-var] target-pattern) | |
| 406 | ;; >> *NOTE* we do not use ':simple-map for view. | |
| 407 | ;; we are now about to complete method mapping. | |
| 408 | ;; >> *NOTE* handle constants last. | |
| 409 | ;; make method map with the same name iff not mapped already. | |
| 410 | ;; | |
| 411 | (dolist (oinfo (module-all-operators src-mod)) | |
| 412 | (dolist (method (opinfo-methods oinfo)) | |
| 413 | (block next-method | |
| 414 | (let ((target-method nil)) | |
| 415 | (when (and | |
| 416 | (or (method-is-user-defined-error-method method) | |
| 417 | (not (method-is-error-method method))) | |
| 418 | (let ((xmod (method-module method))) | |
| 419 | (not | |
| 420 | (memq xmod *kernel-hard-wired-builtin-modules*)) | |
| 421 | )) | |
| 422 | (unless (*find-method-in-map op-mapping method) | |
| 423 | ;; | |
| 424 | ;; not in the map | |
| 425 | ;; | |
| 426 | (when *on-view-debug* | |
| 427 | (format t "~%[create-view] :") | |
| 428 | (format t "~&-find non-specified method ") | |
| 429 | (print-method method) | |
| 430 | (format t "~&-try finding in module ") | |
| 431 | (print-mod-name dst-mod)) | |
| 432 | ;; find in destination module with | |
| 433 | ;; name, arity and coarity mapped by sort-map. | |
| 434 | (unless (sort= (method-coarity method) *sort-id-sort*) | |
| 435 | (setq target-method | |
| 436 | (find-method-in dst-mod | |
| 437 | (method-symbol method) | |
| 438 | (view-map-image-sorts | |
| 439 | dst-mod | |
| 440 | (method-arity method) | |
| 441 | sort-mapping) | |
| 442 | (view-map-image-sort | |
| 443 | dst-mod | |
| 444 | (method-coarity method) | |
| 445 | sort-mapping))) | |
| 446 | (unless target-method | |
| 447 | ;; failed to find. | |
| 448 | ;; we continue, but may cause big problem later | |
| 449 | ;; so gives a warning. | |
| 450 | (with-output-chaos-warning () | |
| 451 | (princ "view incomplete for operator ") | |
| 452 | (print-method method) | |
| 453 | (princ " of ") | |
| 454 | (print-mod-name src-mod) | |
| 455 | (print-next) | |
| 456 | (princ "view to ") | |
| 457 | (print-mod-name dst-mod) | |
| 458 | (print-next) | |
| 459 | (princ "!! MAY CAUSE PANIC LATER !!")) | |
| 460 | (return-from next-method nil) | |
| 461 | ) | |
| 462 | ||
| 463 | ;; | |
| 464 | ;; found the target-method in dst-mod, | |
| 465 | ;; i.e., with the same name & has proper rank. | |
| 466 | ;; | |
| 467 | (unless (eq method target-method) | |
| 468 | ;; construct map iff they are different object. | |
| 469 | (let ((vars (make-psuedo-vars-from-sorts | |
| 470 | (method-arity method)))) | |
| 471 | (when *on-view-debug* | |
| 472 | (format t "~%-*creating new op-mapping ") | |
| 473 | (format t "~& from ") | |
| 474 | (print-method method) | |
| 475 | (format t "~& to ") | |
| 476 | (print-method target-method)) | |
| 477 | (push (list (make-term-check-op method vars src-mod) | |
| 478 | (make-term-check-op target-method | |
| 479 | vars | |
| 480 | dst-mod)) | |
| 481 | op-mapping) | |
| 482 | ) | |
| 483 | ;; | |
| 484 | (let ((thy1 (method-theory method | |
| 485 | (module-opinfo-table src-mod))) | |
| 486 | (thy2 (method-theory target-method | |
| 487 | (module-opinfo-table dst-mod)))) | |
| 488 | (let ((z1 (car (theory-zero thy1))) | |
| 489 | (z2 (car (theory-zero thy2)))) | |
| 490 | (when (and z1 | |
| 491 | (not (*find-method-in-map op-mapping | |
| 492 | (term-head z1))) | |
| 493 | z2 | |
| 494 | (term-is-constant? z1) | |
| 495 | (term-is-constant? z2)) | |
| 496 | (push (list z1 z2) | |
| 497 | op-mapping)))))))))))) | |
| 498 | ;; | |
| 499 | ;; make SortId op mappings | |
| 500 | ;; | |
| 501 | (let ((s-op nil) | |
| 502 | (t-op nil) | |
| 503 | (ignore-these (list *cosmos* *universal-sort* | |
| 504 | *huniversal-sort* *bottom-sort*))) | |
| 505 | (dolist (s-map sort-mapping) | |
| 506 | (let ((source (car s-map)) | |
| 507 | (target (cdr s-map))) | |
| 508 | (break) | |
| 509 | (unless (or (err-sort-p source) | |
| 510 | (memq source ignore-these) | |
| 511 | (memq target ignore-these)) | |
| 512 | (setq s-op (find-method-in src-mod | |
| 513 | (string (sort-id source)) | |
| 514 | nil | |
| 515 | *sort-id-sort*)) | |
| 516 | (unless (*find-method-in-map op-mapping s-op) | |
| 517 | (setq t-op (find-method-in dst-mod | |
| 518 | (string (sort-id target)) | |
| 519 | nil | |
| 520 | *sort-id-sort*)) | |
| 521 | (push (list (make-term-check-op s-op nil src-mod) | |
| 522 | (make-term-check-op t-op nil dst-mod)) | |
| 523 | op-mapping)))))) | |
| 524 | ||
| 525 | ;; | |
| 526 | ;; final result | |
| 527 | ;; | |
| 528 | (let ((view (view-struct* :anon-view))) | |
| 529 | (initialize-view view) | |
| 530 | (setf (view-src view) src-mod | |
| 531 | (view-target view) dst-mod | |
| 532 | (view-sort-maps view) sort-mapping | |
| 533 | (view-op-maps view) op-mapping) | |
| 534 | ;; | |
| 535 | (when *on-view-debug* | |
| 536 | (format t "~%[generated view]:") | |
| 537 | (format t "~& source = ") (print-chaos-object src-mod) | |
| 538 | (format t "~& target = ") (print-chaos-object dst-mod) | |
| 539 | (format t "~& sort-map = ") | |
| 540 | (dolist (smap sort-mapping) | |
| 541 | (terpri) | |
| 542 | (print-chaos-object smap)) | |
| 543 | (format t "~& op-map =") | |
| 544 | (dolist (opmap op-mapping) | |
| 545 | (terpri) | |
| 546 | (print-term-method (car opmap)) | |
| 547 | (princ " --> ") | |
| 548 | (princ (cdr opmap)) | |
| 549 | ;; (print-chaos-object opmap) | |
| 550 | )) | |
| 551 | ;; | |
| 552 | view) | |
| 553 | )))))) | |
| 554 | 554 | |
| 555 | 555 | ||# |
| 556 | 556 | |
| 557 | 557 | (defun create-view (th mod rename-map pre-map) |
| 558 | 558 | (let ((vw-map (if (%is-rmap rename-map) |
| 559 | (%rmap-map rename-map) | |
| 560 | rename-map))) | |
| 559 | (%rmap-map rename-map) | |
| 560 | rename-map))) | |
| 561 | 561 | ;; |
| 562 | 562 | ;; eval source & target module |
| 563 | 563 | ;; |
| 564 | (let ((src-mod (eval-modexp th t)) ; should already evaluated but.. | |
| 565 | (dst-mod (eval-modexp mod t))) ; really evaluate the target. | |
| 564 | (let ((src-mod (eval-modexp th t)) ; should already evaluated but.. | |
| 565 | (dst-mod (eval-modexp mod t))) ; really evaluate the target. | |
| 566 | 566 | (when (or (modexp-is-error src-mod) (modexp-is-error dst-mod)) |
| 567 | ;; error, ivalid args as modules | |
| 568 | (with-output-chaos-error ('modexp-eval) | |
| 569 | (princ "Cannot evaluate module in view: ") | |
| 570 | (when (modexp-is-error src-mod) | |
| 571 | (princ "view source = ") | |
| 572 | (print-modexp th)) | |
| 573 | (when (modexp-is-error dst-mod) | |
| 574 | (when (modexp-is-error src-mod) | |
| 575 | (princ ", and ")) | |
| 576 | (princ "view target = ") | |
| 577 | (print-modexp mod)) | |
| 578 | )) | |
| 567 | ;; error, ivalid args as modules | |
| 568 | (with-output-chaos-error ('modexp-eval) | |
| 569 | (princ "Cannot evaluate module in view: ") | |
| 570 | (when (modexp-is-error src-mod) | |
| 571 | (princ "view source = ") | |
| 572 | (print-modexp th)) | |
| 573 | (when (modexp-is-error dst-mod) | |
| 574 | (when (modexp-is-error src-mod) | |
| 575 | (princ ", and ")) | |
| 576 | (princ "view target = ") | |
| 577 | (print-modexp mod)) | |
| 578 | )) | |
| 579 | 579 | ;; |
| 580 | 580 | ;; compute mappings. |
| 581 | 581 | ;; |
| 582 | 582 | (let ((pre-sort-mapping nil) |
| 583 | (pre-op-mapping nil) | |
| 584 | ) | |
| 585 | ;; | |
| 586 | (when pre-map | |
| 587 | (setq pre-sort-mapping (modmorph-sort pre-map)) | |
| 588 | (setq pre-op-mapping (modmorph-op pre-map))) | |
| 589 | #|| | |
| 590 | (when (int-instantiation-p dst-mod) | |
| 591 | (let ((mappg (views-to-modmorph (int-instantiation-module dst-mod) | |
| 592 | (int-instantiation-args dst-mod)))) | |
| 593 | (setq pre-sort-mapping (modmorph-sort mappg)) | |
| 594 | (setq pre-op-mapping (modmorph-op mappg)))) | |
| 595 | ||# | |
| 596 | ;; | |
| 597 | ||
| 598 | (let ((sort-maps (cadr (assq '%ren-sort vw-map))) | |
| 599 | (op-maps (cadr (assq '%ren-op vw-map))) | |
| 600 | (hsort-maps (cadr (assq '%ren-hsort vw-map))) | |
| 601 | (bop-maps (cadr (assq '%ren-bop vw-map))) | |
| 602 | (vars (cadr (assq '%vars vw-map))) | |
| 603 | (pr (principal-sort src-mod)) | |
| 604 | ; NOW we support. May/'97 | |
| 605 | ) | |
| 606 | ;; | |
| 607 | ;; ** compute sort mappings --------------------------------- | |
| 608 | ;; | |
| 609 | (let ((sort-mapping (compute-sort-mappings src-mod | |
| 610 | dst-mod | |
| 611 | sort-maps | |
| 612 | hsort-maps))) | |
| 613 | #|| | |
| 614 | (when pre-sort-mapping | |
| 615 | (setq sort-mapping | |
| 616 | (modmorph-merge-assoc sort-mapping pre-sort-mapping nil))) | |
| 617 | ||# | |
| 618 | ;; make sort mappings with completing sort maps not explicitly | |
| 619 | ;; specified. | |
| 620 | (dolist (s (module-all-sorts src-mod)) | |
| 621 | (unless (*find-sort-in-map sort-mapping s) | |
| 622 | ;; map is not specified. | |
| 623 | ;; we prefer map in pre-sort-mapping iff given. | |
| 624 | (let ((pre (assq s pre-sort-mapping))) | |
| 625 | (if pre | |
| 626 | (push pre sort-mapping) | |
| 627 | ;; else find by `the same name principle.' | |
| 628 | (let ((val (find-sort-in dst-mod (sort-id s) t))) | |
| 629 | (when (eq s pr) ; is this the principal sort? | |
| 630 | (let ((pval (principal-sort dst-mod))) | |
| 631 | (when pval | |
| 632 | (setq val pval)))) | |
| 633 | ;; find compatible same name sort --- | |
| 634 | ;; should check types,i.e., visible & hidden. | |
| 635 | (if val | |
| 636 | (unless (sort= s val) | |
| 637 | (push (cons s val) sort-mapping)) | |
| 638 | (with-output-chaos-warning () | |
| 639 | (princ "view incomplete for sort ") | |
| 640 | (print-chaos-object s) | |
| 641 | (print-next) | |
| 642 | (princ "view from ") | |
| 643 | (print-chaos-object src-mod) | |
| 644 | (princ " to ") | |
| 645 | (print-chaos-object dst-mod) | |
| 646 | (print-next) | |
| 647 | (princ "!! this can cause panic.") | |
| 648 | ;; (chaos-error 'modexp-eval) | |
| 649 | ))) | |
| 650 | )))) | |
| 651 | ;; | |
| 652 | ;; ** compute operator mapping ------------------------------------ | |
| 653 | ;; | |
| 654 | (let* ((src-vars | |
| 655 | (mapcan #'(lambda (x) | |
| 656 | (let ((sort (find-sort-in src-mod | |
| 657 | (cadr x)))) | |
| 658 | (unless sort | |
| 659 | (with-output-chaos-error ('modexp-eval) | |
| 660 | (format t "sort ~a not found in view variable" | |
| 661 | (cadr x)) | |
| 662 | )) | |
| 663 | (mapcar #'(lambda (y) | |
| 664 | (make-variable-term sort | |
| 665 | (if (stringp y) | |
| 666 | (intern y) | |
| 667 | y))) | |
| 668 | (car x)))) | |
| 669 | vars)) | |
| 670 | (dst-vars | |
| 671 | (mapcar #'(lambda (x) | |
| 672 | (let ((val (cdr (assq (variable-sort x) | |
| 673 | sort-mapping)))) | |
| 674 | (if val | |
| 675 | (make-variable-term val (variable-name x)) | |
| 676 | x))) | |
| 677 | src-vars)) | |
| 678 | ;; | |
| 679 | (op-mapping (compute-op-mappings src-mod | |
| 680 | dst-mod | |
| 681 | sort-mapping | |
| 682 | op-maps | |
| 683 | bop-maps | |
| 684 | src-vars | |
| 685 | dst-vars | |
| 686 | ))) | |
| 687 | #|| | |
| 688 | (when pre-op-mapping | |
| 689 | (setq op-mapping | |
| 690 | (modmorph-merge-op-assoc op-mapping | |
| 691 | pre-op-mapping))) | |
| 692 | ||# | |
| 693 | ;; now op-mapping is in form of ( op-map ... ), | |
| 694 | ;; where op-map is | |
| 695 | ;; (source-pattern target-pattern) | |
| 696 | ;; this will be converted to operator map of modmorhp: | |
| 697 | ;; (method :replacement List[psuedo-var] target-pattern) | |
| 698 | ;; >> *NOTE* we do not use ':simple-map for view. | |
| 699 | ;; we are now about to complete method mapping. | |
| 700 | ;; >> *NOTE* handle constants last. | |
| 701 | ;; make method map with the same name iff not mapped already. | |
| 702 | ;; | |
| 703 | (dolist (oinfo (module-all-operators src-mod)) | |
| 704 | (dolist (method (opinfo-methods oinfo)) | |
| 705 | (block next-method | |
| 706 | (let ((target-method nil)) | |
| 707 | (when (and | |
| 708 | (or (method-is-user-defined-error-method method) | |
| 709 | ;; t | |
| 710 | (not (method-is-error-method method))) | |
| 711 | (let ((xmod (method-module method))) | |
| 712 | (not | |
| 713 | (memq xmod *kernel-hard-wired-builtin-modules*)) | |
| 714 | )) | |
| 715 | (unless (*find-method-in-map op-mapping method) | |
| 716 | ;; | |
| 717 | ;; not in the map | |
| 718 | ;; | |
| 719 | (when *on-view-debug* | |
| 720 | (format t "~&[create-view] :") | |
| 721 | (format t "~&-find non-specified method ") | |
| 722 | (print-method method) | |
| 723 | (format t "~&-try finding in module ") | |
| 724 | (print-mod-name dst-mod)) | |
| 725 | ;; check in pre-op-mapping, | |
| 726 | ;; if found use this map. | |
| 727 | (let ((pre (*find-method-in-map pre-op-mapping method))) | |
| 728 | (if pre | |
| 729 | (push pre op-mapping) | |
| 730 | ;; find in destination module with | |
| 731 | ;; name, arity and coarity mapped by sort-map. | |
| 732 | (unless (sort= (method-coarity method) | |
| 733 | *sort-id-sort*) | |
| 734 | (setq target-method | |
| 735 | (find-method-in dst-mod | |
| 736 | (method-symbol method) | |
| 737 | (view-map-image-sorts | |
| 738 | dst-mod | |
| 739 | (method-arity method) | |
| 740 | sort-mapping) | |
| 741 | (view-map-image-sort | |
| 742 | dst-mod | |
| 743 | (method-coarity method) | |
| 744 | sort-mapping))) | |
| 745 | (unless target-method | |
| 746 | ;; failed to find. | |
| 747 | ;; we continue, but may cause big problem later | |
| 748 | ;; so gives a warning. | |
| 749 | (with-output-chaos-warning () | |
| 750 | (princ "view incomplete for operator ") | |
| 751 | (print-method method) | |
| 752 | (princ " of ") | |
| 753 | (print-mod-name src-mod) | |
| 754 | (print-next) | |
| 755 | (princ "view to ") | |
| 756 | (print-mod-name dst-mod) | |
| 757 | (print-next) | |
| 758 | (princ "can cause panic later !!")) | |
| 759 | (return-from next-method nil) | |
| 760 | ) | |
| 761 | ;; | |
| 762 | ;; found the target-method in dst-mod, | |
| 763 | ;; i.e., with the same name & has proper rank. | |
| 764 | ;; | |
| 765 | (unless (eq method target-method) | |
| 766 | ;; construct map iff they are different object. | |
| 767 | (let ((vars (make-psuedo-vars-from-sorts | |
| 768 | (method-arity method)))) | |
| 769 | (when *on-view-debug* | |
| 770 | (format t "~&-*creating new op-mapping ") | |
| 771 | (format t "~& from ") | |
| 772 | (print-method method) | |
| 773 | (format t "~& to ") | |
| 774 | (print-method target-method)) | |
| 775 | (push (list (make-term-check-op | |
| 776 | method | |
| 777 | vars | |
| 778 | src-mod) | |
| 779 | (make-term-check-op | |
| 780 | target-method | |
| 781 | vars | |
| 782 | dst-mod)) | |
| 783 | op-mapping) | |
| 784 | ) | |
| 785 | ;; | |
| 786 | (let ((thy1 (method-theory | |
| 787 | method | |
| 788 | (module-opinfo-table src-mod))) | |
| 789 | (thy2 (method-theory | |
| 790 | target-method | |
| 791 | (module-opinfo-table dst-mod)))) | |
| 792 | (let ((z1 (car (theory-zero thy1))) | |
| 793 | (z2 (car (theory-zero thy2)))) | |
| 794 | (when (and z1 | |
| 795 | (not (*find-method-in-map | |
| 796 | op-mapping | |
| 797 | (term-head z1))) | |
| 798 | z2 | |
| 799 | (term-is-constant? z1) | |
| 800 | (term-is-constant? z2)) | |
| 801 | (push (list z1 z2) | |
| 802 | op-mapping)))))))))))))) | |
| 803 | ;; | |
| 804 | ;; make SortId op mappings | |
| 805 | ;; | |
| 806 | (let ((s-op nil) | |
| 807 | (t-op nil)) | |
| 808 | (dolist (s-map sort-mapping) | |
| 809 | (let ((source (car s-map)) | |
| 810 | (target (cdr s-map)) | |
| 811 | (ignore-these (list *cosmos* *universal-sort* | |
| 812 | *huniversal-sort* | |
| 813 | *bottom-sort*))) | |
| 814 | (unless (or (err-sort-p source) | |
| 815 | (memq source ignore-these) | |
| 816 | (memq target ignore-these)) | |
| 817 | (setq s-op (find-method-in src-mod | |
| 818 | (string (sort-id source)) | |
| 819 | nil | |
| 820 | *sort-id-sort*)) | |
| 821 | (unless (*find-method-in-map op-mapping s-op) | |
| 822 | (setq t-op (find-method-in dst-mod | |
| 823 | (string (sort-id target)) | |
| 824 | nil | |
| 825 | *sort-id-sort*)) | |
| 826 | (push (list (make-term-check-op s-op nil src-mod) | |
| 827 | (make-term-check-op t-op nil dst-mod)) | |
| 828 | op-mapping)))))) | |
| 829 | ;; | |
| 830 | ;; final result | |
| 831 | ;; | |
| 832 | (let ((view (view-struct* :anon-view))) | |
| 833 | (initialize-view view) | |
| 834 | (setf (view-src view) src-mod | |
| 835 | (view-target view) dst-mod | |
| 836 | (view-sort-maps view) sort-mapping | |
| 837 | (view-op-maps view) op-mapping) | |
| 838 | ;; | |
| 839 | (when *on-view-debug* | |
| 840 | (format t "~%[generated view]:") | |
| 841 | (format t "~& source = ") (print-chaos-object src-mod) | |
| 842 | (format t "~& target = ") (print-chaos-object dst-mod) | |
| 843 | (format t "~& sort-map = ") | |
| 844 | (dolist (smap sort-mapping) | |
| 845 | (terpri) | |
| 846 | (print-chaos-object smap)) | |
| 847 | (format t "~& op-map =") | |
| 848 | (dolist (opmap op-mapping) | |
| 849 | (terpri) | |
| 850 | (print-term-method (car opmap)) | |
| 851 | (princ " --> ") | |
| 852 | (princ (cdr opmap)) | |
| 853 | ;; (print-chaos-object opmap) | |
| 854 | )) | |
| 855 | ;; | |
| 856 | view) | |
| 857 | ))))))) | |
| 583 | (pre-op-mapping nil) | |
| 584 | ) | |
| 585 | ;; | |
| 586 | (when pre-map | |
| 587 | (setq pre-sort-mapping (modmorph-sort pre-map)) | |
| 588 | (setq pre-op-mapping (modmorph-op pre-map))) | |
| 589 | #|| | |
| 590 | (when (int-instantiation-p dst-mod) | |
| 591 | (let ((mappg (views-to-modmorph (int-instantiation-module dst-mod) | |
| 592 | (int-instantiation-args dst-mod)))) | |
| 593 | (setq pre-sort-mapping (modmorph-sort mappg)) | |
| 594 | (setq pre-op-mapping (modmorph-op mappg)))) | |
| 595 | ||# | |
| 596 | ;; | |
| 597 | ||
| 598 | (let ((sort-maps (cadr (assq '%ren-sort vw-map))) | |
| 599 | (op-maps (cadr (assq '%ren-op vw-map))) | |
| 600 | (hsort-maps (cadr (assq '%ren-hsort vw-map))) | |
| 601 | (bop-maps (cadr (assq '%ren-bop vw-map))) | |
| 602 | (vars (cadr (assq '%vars vw-map))) | |
| 603 | (pr (principal-sort src-mod)) | |
| 604 | ; NOW we support. May/'97 | |
| 605 | ) | |
| 606 | ;; | |
| 607 | ;; ** compute sort mappings --------------------------------- | |
| 608 | ;; | |
| 609 | (let ((sort-mapping (compute-sort-mappings src-mod | |
| 610 | dst-mod | |
| 611 | sort-maps | |
| 612 | hsort-maps))) | |
| 613 | #|| | |
| 614 | (when pre-sort-mapping | |
| 615 | (setq sort-mapping | |
| 616 | (modmorph-merge-assoc sort-mapping pre-sort-mapping nil))) | |
| 617 | ||# | |
| 618 | ;; make sort mappings with completing sort maps not explicitly | |
| 619 | ;; specified. | |
| 620 | (dolist (s (module-all-sorts src-mod)) | |
| 621 | (unless (*find-sort-in-map sort-mapping s) | |
| 622 | ;; map is not specified. | |
| 623 | ;; we prefer map in pre-sort-mapping iff given. | |
| 624 | (let ((pre (assq s pre-sort-mapping))) | |
| 625 | (if pre | |
| 626 | (push pre sort-mapping) | |
| 627 | ;; else find by `the same name principle.' | |
| 628 | (let ((val (find-sort-in dst-mod (sort-id s) t))) | |
| 629 | (when (eq s pr) ; is this the principal sort? | |
| 630 | (let ((pval (principal-sort dst-mod))) | |
| 631 | (when pval | |
| 632 | (setq val pval)))) | |
| 633 | ;; find compatible same name sort --- | |
| 634 | ;; should check types,i.e., visible & hidden. | |
| 635 | (if val | |
| 636 | (unless (sort= s val) | |
| 637 | (push (cons s val) sort-mapping)) | |
| 638 | (with-output-chaos-warning () | |
| 639 | (princ "view incomplete for sort ") | |
| 640 | (print-chaos-object s) | |
| 641 | (print-next) | |
| 642 | (princ "view from ") | |
| 643 | (print-chaos-object src-mod) | |
| 644 | (princ " to ") | |
| 645 | (print-chaos-object dst-mod) | |
| 646 | (print-next) | |
| 647 | (princ "!! this can cause panic.") | |
| 648 | ;; (chaos-error 'modexp-eval) | |
| 649 | ))) | |
| 650 | )))) | |
| 651 | ;; | |
| 652 | ;; ** compute operator mapping ------------------------------------ | |
| 653 | ;; | |
| 654 | (let* ((src-vars | |
| 655 | (mapcan #'(lambda (x) | |
| 656 | (let ((sort (find-sort-in src-mod | |
| 657 | (cadr x)))) | |
| 658 | (unless sort | |
| 659 | (with-output-chaos-error ('modexp-eval) | |
| 660 | (format t "sort ~a not found in view variable" | |
| 661 | (cadr x)) | |
| 662 | )) | |
| 663 | (mapcar #'(lambda (y) | |
| 664 | (make-variable-term sort | |
| 665 | (if (stringp y) | |
| 666 | (intern y) | |
| 667 | y))) | |
| 668 | (car x)))) | |
| 669 | vars)) | |
| 670 | (dst-vars | |
| 671 | (mapcar #'(lambda (x) | |
| 672 | (let ((val (cdr (assq (variable-sort x) | |
| 673 | sort-mapping)))) | |
| 674 | (if val | |
| 675 | (make-variable-term val (variable-name x)) | |
| 676 | x))) | |
| 677 | src-vars)) | |
| 678 | ;; | |
| 679 | (op-mapping (compute-op-mappings src-mod | |
| 680 | dst-mod | |
| 681 | sort-mapping | |
| 682 | op-maps | |
| 683 | bop-maps | |
| 684 | src-vars | |
| 685 | dst-vars | |
| 686 | ))) | |
| 687 | #|| | |
| 688 | (when pre-op-mapping | |
| 689 | (setq op-mapping | |
| 690 | (modmorph-merge-op-assoc op-mapping | |
| 691 | pre-op-mapping))) | |
| 692 | ||# | |
| 693 | ;; now op-mapping is in form of ( op-map ... ), | |
| 694 | ;; where op-map is | |
| 695 | ;; (source-pattern target-pattern) | |
| 696 | ;; this will be converted to operator map of modmorhp: | |
| 697 | ;; (method :replacement List[psuedo-var] target-pattern) | |
| 698 | ;; >> *NOTE* we do not use ':simple-map for view. | |
| 699 | ;; we are now about to complete method mapping. | |
| 700 | ;; >> *NOTE* handle constants last. | |
| 701 | ;; make method map with the same name iff not mapped already. | |
| 702 | ;; | |
| 703 | (dolist (oinfo (module-all-operators src-mod)) | |
| 704 | (dolist (method (opinfo-methods oinfo)) | |
| 705 | (block next-method | |
| 706 | (let ((target-method nil)) | |
| 707 | (when (and | |
| 708 | (or (method-is-user-defined-error-method method) | |
| 709 | ;; t | |
| 710 | (not (method-is-error-method method))) | |
| 711 | (let ((xmod (method-module method))) | |
| 712 | (not | |
| 713 | (memq xmod *kernel-hard-wired-builtin-modules*)) | |
| 714 | )) | |
| 715 | (unless (*find-method-in-map op-mapping method) | |
| 716 | ;; | |
| 717 | ;; not in the map | |
| 718 | ;; | |
| 719 | (when *on-view-debug* | |
| 720 | (format t "~%[create-view] :") | |
| 721 | (format t "~&-find non-specified method ") | |
| 722 | (print-method method) | |
| 723 | (format t "~&-try finding in module ") | |
| 724 | (print-mod-name dst-mod)) | |
| 725 | ;; check in pre-op-mapping, | |
| 726 | ;; if found use this map. | |
| 727 | (let ((pre (*find-method-in-map pre-op-mapping method))) | |
| 728 | (if pre | |
| 729 | (push pre op-mapping) | |
| 730 | ;; find in destination module with | |
| 731 | ;; name, arity and coarity mapped by sort-map. | |
| 732 | (unless (sort= (method-coarity method) | |
| 733 | *sort-id-sort*) | |
| 734 | (setq target-method | |
| 735 | (find-method-in dst-mod | |
| 736 | (method-symbol method) | |
| 737 | (view-map-image-sorts | |
| 738 | dst-mod | |
| 739 | (method-arity method) | |
| 740 | sort-mapping) | |
| 741 | (view-map-image-sort | |
| 742 | dst-mod | |
| 743 | (method-coarity method) | |
| 744 | sort-mapping))) | |
| 745 | (unless target-method | |
| 746 | ;; failed to find. | |
| 747 | ;; we continue, but may cause big problem later | |
| 748 | ;; so gives a warning. | |
| 749 | (with-output-chaos-warning () | |
| 750 | (princ "view incomplete for operator ") | |
| 751 | (print-method method) | |
| 752 | (princ " of ") | |
| 753 | (print-mod-name src-mod) | |
| 754 | (print-next) | |
| 755 | (princ "view to ") | |
| 756 | (print-mod-name dst-mod) | |
| 757 | (print-next) | |
| 758 | (princ "can cause panic later !!")) | |
| 759 | (return-from next-method nil) | |
| 760 | ) | |
| 761 | ;; | |
| 762 | ;; found the target-method in dst-mod, | |
| 763 | ;; i.e., with the same name & has proper rank. | |
| 764 | ;; | |
| 765 | (unless (eq method target-method) | |
| 766 | ;; construct map iff they are different object. | |
| 767 | (let ((vars (make-psuedo-vars-from-sorts | |
| 768 | (method-arity method)))) | |
| 769 | (when *on-view-debug* | |
| 770 | (format t "~%-*creating new op-mapping ") | |
| 771 | (format t "~& from ") | |
| 772 | (print-method method) | |
| 773 | (format t "~& to ") | |
| 774 | (print-method target-method)) | |
| 775 | (push (list (make-term-check-op | |
| 776 | method | |
| 777 | vars | |
| 778 | src-mod) | |
| 779 | (make-term-check-op | |
| 780 | target-method | |
| 781 | vars | |
| 782 | dst-mod)) | |
| 783 | op-mapping) | |
| 784 | ) | |
| 785 | ;; | |
| 786 | (let ((thy1 (method-theory | |
| 787 | method | |
| 788 | (module-opinfo-table src-mod))) | |
| 789 | (thy2 (method-theory | |
| 790 | target-method | |
| 791 | (module-opinfo-table dst-mod)))) | |
| 792 | (let ((z1 (car (theory-zero thy1))) | |
| 793 | (z2 (car (theory-zero thy2)))) | |
| 794 | (when (and z1 | |
| 795 | (not (*find-method-in-map | |
| 796 | op-mapping | |
| 797 | (term-head z1))) | |
| 798 | z2 | |
| 799 | (term-is-constant? z1) | |
| 800 | (term-is-constant? z2)) | |
| 801 | (push (list z1 z2) | |
| 802 | op-mapping)))))))))))))) | |
| 803 | ;; | |
| 804 | ;; make SortId op mappings | |
| 805 | ;; | |
| 806 | (let ((s-op nil) | |
| 807 | (t-op nil)) | |
| 808 | (dolist (s-map sort-mapping) | |
| 809 | (let ((source (car s-map)) | |
| 810 | (target (cdr s-map)) | |
| 811 | (ignore-these (list *cosmos* *universal-sort* | |
| 812 | *huniversal-sort* | |
| 813 | *bottom-sort*))) | |
| 814 | (unless (or (err-sort-p source) | |
| 815 | (memq source ignore-these) | |
| 816 | (memq target ignore-these)) | |
| 817 | (setq s-op (find-method-in src-mod | |
| 818 | (string (sort-id source)) | |
| 819 | nil | |
| 820 | *sort-id-sort*)) | |
| 821 | (unless (*find-method-in-map op-mapping s-op) | |
| 822 | (setq t-op (find-method-in dst-mod | |
| 823 | (string (sort-id target)) | |
| 824 | nil | |
| 825 | *sort-id-sort*)) | |
| 826 | (push (list (make-term-check-op s-op nil src-mod) | |
| 827 | (make-term-check-op t-op nil dst-mod)) | |
| 828 | op-mapping)))))) | |
| 829 | ;; | |
| 830 | ;; final result | |
| 831 | ;; | |
| 832 | (let ((view (view-struct* :anon-view))) | |
| 833 | (initialize-view view) | |
| 834 | (setf (view-src view) src-mod | |
| 835 | (view-target view) dst-mod | |
| 836 | (view-sort-maps view) sort-mapping | |
| 837 | (view-op-maps view) op-mapping) | |
| 838 | ;; | |
| 839 | (when *on-view-debug* | |
| 840 | (format t "~%[generated view]:") | |
| 841 | (format t "~& source = ") (print-chaos-object src-mod) | |
| 842 | (format t "~& target = ") (print-chaos-object dst-mod) | |
| 843 | (format t "~& sort-map = ") | |
| 844 | (dolist (smap sort-mapping) | |
| 845 | (terpri) | |
| 846 | (print-chaos-object smap)) | |
| 847 | (format t "~& op-map =") | |
| 848 | (dolist (opmap op-mapping) | |
| 849 | (terpri) | |
| 850 | (print-term-method (car opmap)) | |
| 851 | (princ " --> ") | |
| 852 | (princ (cdr opmap)) | |
| 853 | ;; (print-chaos-object opmap) | |
| 854 | )) | |
| 855 | ;; | |
| 856 | view) | |
| 857 | ))))))) | |
| 858 | 858 | |
| 859 | 859 | (defun *find-sort-in-map (map x) |
| 860 | 860 | (let ((imap (find-if #'(lambda (y) |
| 861 | (sort= x (car y))) | |
| 862 | map))) | |
| 861 | (sort= x (car y))) | |
| 862 | map))) | |
| 863 | 863 | (if imap |
| 864 | (cdr imap) | |
| 865 | nil))) | |
| 864 | (cdr imap) | |
| 865 | nil))) | |
| 866 | 866 | |
| 867 | 867 | (defun *find-method-in-map (op-mapping method) |
| 868 | 868 | ;; |
| 869 | 869 | (find-if #'(lambda (x) (if (operator-method-p (car x)) |
| 870 | (eq method (car x)) | |
| 871 | (eq method (term-head (car x))))) | |
| 872 | op-mapping)) | |
| 870 | (eq method (car x)) | |
| 871 | (eq method (term-head (car x))))) | |
| 872 | op-mapping)) | |
| 873 | 873 | |
| 874 | 874 | ;;; *********************** |
| 875 | 875 | ;;; COMPUTING REAL MAPPINGS |
| 886 | 886 | ;;; |
| 887 | 887 | (defun compute-sort-mappings (src-mod dst-mod sort-maps hsort-maps) |
| 888 | 888 | (let ((res (nconc (mapcan |
| 889 | #'(lambda (x) | |
| 890 | (compute-sort-mapping src-mod dst-mod x :visible)) | |
| 891 | sort-maps) | |
| 892 | (mapcan | |
| 893 | #'(lambda (x) | |
| 894 | (compute-sort-mapping src-mod dst-mod x :hidden)) | |
| 895 | hsort-maps))) | |
| 896 | (f-so (module-sort-order src-mod)) | |
| 897 | (t-so (module-sort-order dst-mod)) | |
| 898 | (err-map nil)) | |
| 889 | #'(lambda (x) | |
| 890 | (compute-sort-mapping src-mod dst-mod x :visible)) | |
| 891 | sort-maps) | |
| 892 | (mapcan | |
| 893 | #'(lambda (x) | |
| 894 | (compute-sort-mapping src-mod dst-mod x :hidden)) | |
| 895 | hsort-maps))) | |
| 896 | (f-so (module-sort-order src-mod)) | |
| 897 | (t-so (module-sort-order dst-mod)) | |
| 898 | (err-map nil)) | |
| 899 | 899 | ;; make implicit mapping for error sorts, if not specified. |
| 900 | 900 | (dolist (map res) |
| 901 | 901 | (let ((s-err (the-err-sort (car map) f-so)) |
| 902 | (t-err (the-err-sort (cdr map) t-so))) | |
| 903 | (unless (assq s-err res) | |
| 904 | (push (cons s-err t-err) err-map)))) | |
| 902 | (t-err (the-err-sort (cdr map) t-so))) | |
| 903 | (unless (assq s-err res) | |
| 904 | (push (cons s-err t-err) err-map)))) | |
| 905 | 905 | (when err-map |
| 906 | 906 | (setq res (nconc res err-map))) |
| 907 | 907 | ;; |
| 909 | 909 | |
| 910 | 910 | (defun compute-sort-mapping (src-mod dst-mod sort-map &optional (type :visible)) |
| 911 | 911 | (let ((srcs (find-sort-in src-mod (car sort-map))) |
| 912 | (tgts (find-sort-in dst-mod (cadr sort-map)))) | |
| 912 | (tgts (find-sort-in dst-mod (cadr sort-map)))) | |
| 913 | 913 | (unless srcs |
| 914 | 914 | (with-output-chaos-error ('modexp-eval) |
| 915 | (princ "in view from ") | |
| 916 | (print-mod-name src-mod) | |
| 917 | (princ " to ") | |
| 918 | (print-mod-name dst-mod) | |
| 919 | (print-next) | |
| 920 | (princ "source sort not recognized : ") | |
| 921 | (print-sort-ref (car sort-map)) | |
| 922 | )) | |
| 915 | (princ "in view from ") | |
| 916 | (print-mod-name src-mod) | |
| 917 | (princ " to ") | |
| 918 | (print-mod-name dst-mod) | |
| 919 | (print-next) | |
| 920 | (princ "source sort not recognized : ") | |
| 921 | (print-sort-ref (car sort-map)) | |
| 922 | )) | |
| 923 | 923 | (unless tgts |
| 924 | 924 | (with-output-chaos-error ('modexp-eval) |
| 925 | (princ "in view from ") | |
| 926 | (print-mod-name src-mod) | |
| 927 | (princ " to ") | |
| 928 | (print-mod-name dst-mod) | |
| 929 | (print-next) | |
| 930 | (princ "target sort not recognized: ") | |
| 931 | (print-sort-ref (cadr sort-map)) | |
| 932 | )) | |
| 925 | (princ "in view from ") | |
| 926 | (print-mod-name src-mod) | |
| 927 | (princ " to ") | |
| 928 | (print-mod-name dst-mod) | |
| 929 | (print-next) | |
| 930 | (princ "target sort not recognized: ") | |
| 931 | (print-sort-ref (cadr sort-map)) | |
| 932 | )) | |
| 933 | 933 | (case type |
| 934 | 934 | (:visible (unless (and (sort-is-visible srcs) |
| 935 | (sort-is-visible tgts)) | |
| 936 | (with-output-chaos-error ('invalid-map) | |
| 937 | (format t "both source(~A) and target(~A) sorts must be visible for `sort' map" | |
| 938 | (sort-id srcs) | |
| 939 | (sort-id tgts)) | |
| 940 | ))) | |
| 935 | (sort-is-visible tgts)) | |
| 936 | (with-output-chaos-error ('invalid-map) | |
| 937 | (format t "both source(~A) and target(~A) sorts must be visible for `sort' map" | |
| 938 | (sort-id srcs) | |
| 939 | (sort-id tgts)) | |
| 940 | ))) | |
| 941 | 941 | (otherwise (unless (and (sort-is-hidden srcs) |
| 942 | (sort-is-hidden tgts)) | |
| 943 | (with-output-chaos-error ('invalid-map) | |
| 944 | (format t "both source(~A) and target(~A) sort must be hidden for `hsort' map." | |
| 945 | (sort-id srcs) | |
| 946 | (sort-id tgts)) | |
| 947 | )))) | |
| 942 | (sort-is-hidden tgts)) | |
| 943 | (with-output-chaos-error ('invalid-map) | |
| 944 | (format t "both source(~A) and target(~A) sort must be hidden for `hsort' map." | |
| 945 | (sort-id srcs) | |
| 946 | (sort-id tgts)) | |
| 947 | )))) | |
| 948 | 948 | ;; |
| 949 | 949 | (list (cons srcs tgts)))) |
| 950 | 950 | |
| 968 | 968 | |
| 969 | 969 | (defun compute-op-mappings (src-mod dst-mod sort-maps op-maps bop-maps src-vars dst-vars) |
| 970 | 970 | (nconc (mapcan #'(lambda (opmap) |
| 971 | (compute-op-mapping src-mod | |
| 972 | dst-mod | |
| 973 | sort-maps | |
| 974 | opmap | |
| 975 | src-vars | |
| 976 | dst-vars | |
| 977 | :functional | |
| 978 | )) | |
| 979 | op-maps) | |
| 980 | (mapcan #'(lambda (opmap) | |
| 981 | (compute-op-mapping src-mod | |
| 982 | dst-mod | |
| 983 | sort-maps | |
| 984 | opmap | |
| 985 | src-vars | |
| 986 | dst-vars | |
| 987 | :behavioural | |
| 988 | )) | |
| 989 | bop-maps))) | |
| 971 | (compute-op-mapping src-mod | |
| 972 | dst-mod | |
| 973 | sort-maps | |
| 974 | opmap | |
| 975 | src-vars | |
| 976 | dst-vars | |
| 977 | :functional | |
| 978 | )) | |
| 979 | op-maps) | |
| 980 | (mapcan #'(lambda (opmap) | |
| 981 | (compute-op-mapping src-mod | |
| 982 | dst-mod | |
| 983 | sort-maps | |
| 984 | opmap | |
| 985 | src-vars | |
| 986 | dst-vars | |
| 987 | :behavioural | |
| 988 | )) | |
| 989 | bop-maps))) | |
| 990 | 990 | |
| 991 | 991 | (defun resolve-op-pattern-as-term (mod pat vars) |
| 992 | 992 | (let ((pparsed (let ((*parse-variables* (mapcar #'(lambda (x) |
| 993 | (cons (variable-name x) x)) | |
| 994 | vars))) | |
| 995 | (if (and (term? pat) | |
| 996 | (term-is-application-form? pat)) | |
| 997 | pat | |
| 998 | (parse-quiet-parse mod pat)) | |
| 999 | ) | |
| 1000 | )) | |
| 993 | (cons (variable-name x) x)) | |
| 994 | vars))) | |
| 995 | (if (and (term? pat) | |
| 996 | (term-is-application-form? pat)) | |
| 997 | pat | |
| 998 | (parse-quiet-parse mod pat)) | |
| 999 | ) | |
| 1000 | )) | |
| 1001 | 1001 | (if (term-is-an-error pparsed) |
| 1002 | (when *on-view-debug* | |
| 1003 | (with-in-module (mod) | |
| 1004 | (print-term-tree pparsed) | |
| 1005 | nil)) | |
| 1006 | (if (term-is-builtin-constant? pparsed) | |
| 1007 | (values pparsed | |
| 1008 | (term-builtin-value pparsed) | |
| 1009 | nil | |
| 1010 | nil) | |
| 1011 | (values pparsed | |
| 1012 | (term-head pparsed) | |
| 1013 | (term-variables pparsed) | |
| 1014 | (make-psuedo-vars (term-subterms pparsed))) | |
| 1015 | )))) | |
| 1002 | (when *on-view-debug* | |
| 1003 | (with-in-module (mod) | |
| 1004 | (print-term-tree pparsed) | |
| 1005 | nil)) | |
| 1006 | (if (term-is-builtin-constant? pparsed) | |
| 1007 | (values pparsed | |
| 1008 | (term-builtin-value pparsed) | |
| 1009 | nil | |
| 1010 | nil) | |
| 1011 | (values pparsed | |
| 1012 | (term-head pparsed) | |
| 1013 | (term-variables pparsed) | |
| 1014 | (make-psuedo-vars (term-subterms pparsed))) | |
| 1015 | )))) | |
| 1016 | 1016 | |
| 1017 | 1017 | (defun split-str (str) |
| 1018 | 1018 | (let ((len (length str)) |
| 1019 | (index 0) | |
| 1020 | (r nil)) | |
| 1019 | (index 0) | |
| 1020 | (r nil)) | |
| 1021 | 1021 | (dotimes (i len (progn (unless (= index len) |
| 1022 | (push (subseq str index) r)) | |
| 1023 | (reverse r))) | |
| 1022 | (push (subseq str index) r)) | |
| 1023 | (reverse r))) | |
| 1024 | 1024 | (when (char= (char str i) #\_) |
| 1025 | (unless (= index i) | |
| 1026 | (push (subseq str index i) r)) | |
| 1027 | (push "_" r) | |
| 1028 | (setf index (1+ i))) | |
| 1025 | (unless (= index i) | |
| 1026 | (push (subseq str index i) r)) | |
| 1027 | (push "_" r) | |
| 1028 | (setf index (1+ i))) | |
| 1029 | 1029 | ))) |
| 1030 | ||
| 1030 | ||
| 1031 | 1031 | (defun delimit-op-pat (pat) |
| 1032 | 1032 | (let ((res nil)) |
| 1033 | 1033 | (dolist (p pat) |
| 1037 | 1037 | (defun resolve-op-pattern-as-reference (mod pat) |
| 1038 | 1038 | (setq pat (delimit-op-pat pat)) |
| 1039 | 1039 | (let ((*modexp-parse-input* (append pat '("."))) |
| 1040 | (new-pat nil) | |
| 1041 | (info nil) | |
| 1042 | (res nil)) | |
| 1040 | (new-pat nil) | |
| 1041 | (info nil) | |
| 1042 | (res nil)) | |
| 1043 | 1043 | (setq new-pat (parse-operator-reference '("."))) |
| 1044 | 1044 | (setq info (find-qual-operators new-pat mod)) |
| 1045 | 1045 | #|| |
| 1046 | 1046 | (when (cdr info) |
| 1047 | 1047 | (with-output-chaos-warning () |
| 1048 | (format t "operator reference ~A is ambiguous" pat) | |
| 1049 | ;;(print-ast new-pat) | |
| 1050 | (print-next) | |
| 1051 | (princ "in the context: ") | |
| 1052 | (print-mod-name mod *standard-output* t) | |
| 1053 | )) | |
| 1048 | (format t "operator reference ~A is ambiguous" pat) | |
| 1049 | ;;(print-ast new-pat) | |
| 1050 | (print-next) | |
| 1051 | (princ "in the context: ") | |
| 1052 | (print-mod-name mod *standard-output* t) | |
| 1053 | )) | |
| 1054 | 1054 | ||# |
| 1055 | 1055 | ;; we only need methods |
| 1056 | 1056 | (dolist (i info) |
| 1057 | 1057 | (dolist (m (opinfo-methods i)) |
| 1058 | (push m res))) | |
| 1058 | (push m res))) | |
| 1059 | 1059 | (if res |
| 1060 | (list 'dummy-op (nreverse res)) | |
| 1061 | nil))) | |
| 1062 | ||
| 1060 | (list 'dummy-op (nreverse res)) | |
| 1061 | nil))) | |
| 1062 | ||
| 1063 | 1063 | (defun compute-op-mapping (src-mod dst-mod sort-maps op-map src-vars dst-vars |
| 1064 | &optional (type :functional)) | |
| 1064 | &optional (type :functional)) | |
| 1065 | 1065 | (let ((src-opex (car op-map)) |
| 1066 | (dst-opex (cadr op-map)) | |
| 1067 | (src-opinfo nil) | |
| 1068 | (dst-opinfo nil) | |
| 1069 | (mappings nil) | |
| 1070 | (source-map-type :term) | |
| 1071 | (target-map-type :term) | |
| 1072 | ) | |
| 1066 | (dst-opex (cadr op-map)) | |
| 1067 | (src-opinfo nil) | |
| 1068 | (dst-opinfo nil) | |
| 1069 | (mappings nil) | |
| 1070 | (source-map-type :term) | |
| 1071 | (target-map-type :term) | |
| 1072 | ) | |
| 1073 | 1073 | (multiple-value-bind (src-pat src-method src-varbs src-p-vars) |
| 1074 | ;; | |
| 1075 | ;; source op pattern | |
| 1076 | ;; | |
| 1077 | ;; first we assume pattern is given as term. | |
| 1078 | (resolve-op-pattern-as-term src-mod src-opex src-vars) | |
| 1074 | ;; | |
| 1075 | ;; source op pattern | |
| 1076 | ;; | |
| 1077 | ;; first we assume pattern is given as term. | |
| 1078 | (resolve-op-pattern-as-term src-mod src-opex src-vars) | |
| 1079 | 1079 | ;; |
| 1080 | 1080 | (when src-pat |
| 1081 | (unless (every #'(lambda (x) (term-is-variable? x)) | |
| 1082 | (term-subterms src-pat)) | |
| 1083 | (with-output-chaos-error ('invalid-op-map) | |
| 1084 | (princ "mapping operator: ") | |
| 1085 | (print-method (term-head src-pat)) | |
| 1086 | (print-next) | |
| 1087 | (princ "source pattern must not have non-variable subterms:") | |
| 1088 | )) | |
| 1089 | ;; construct a generic pattern with psuedo variables: | |
| 1090 | (unless (term-is-builtin-constant? src-pat) | |
| 1091 | (setq src-pat | |
| 1092 | (make-term-check-op src-method src-p-vars src-mod))) | |
| 1093 | (setq source-map-type :term)) | |
| 1081 | (unless (every #'(lambda (x) (term-is-variable? x)) | |
| 1082 | (term-subterms src-pat)) | |
| 1083 | (with-output-chaos-error ('invalid-op-map) | |
| 1084 | (princ "mapping operator: ") | |
| 1085 | (print-method (term-head src-pat)) | |
| 1086 | (print-next) | |
| 1087 | (princ "source pattern must not have non-variable subterms:") | |
| 1088 | )) | |
| 1089 | ;; construct a generic pattern with psuedo variables: | |
| 1090 | (unless (term-is-builtin-constant? src-pat) | |
| 1091 | (setq src-pat | |
| 1092 | (make-term-check-op src-method src-p-vars src-mod))) | |
| 1093 | (setq source-map-type :term)) | |
| 1094 | 1094 | ;; |
| 1095 | 1095 | ;; also try, |
| 1096 | 1096 | ;; given source op pattern may be a operator reference. |
| 1097 | 1097 | ;; |
| 1098 | 1098 | (unless src-pat |
| 1099 | (setq src-opinfo (resolve-op-pattern-as-reference src-mod src-opex))) | |
| 1099 | (setq src-opinfo (resolve-op-pattern-as-reference src-mod src-opex))) | |
| 1100 | 1100 | (if src-opinfo |
| 1101 | (setq source-map-type :op-ref) | |
| 1102 | (unless src-pat | |
| 1103 | (with-output-chaos-error ('invalid-map) | |
| 1104 | (format t "could not resolve source operator pattern : ~a" | |
| 1105 | src-opex) | |
| 1106 | ))) | |
| 1101 | (setq source-map-type :op-ref) | |
| 1102 | (unless src-pat | |
| 1103 | (with-output-chaos-error ('invalid-map) | |
| 1104 | (format t "could not resolve source operator pattern : ~a" | |
| 1105 | src-opex) | |
| 1106 | ))) | |
| 1107 | 1107 | ;; |
| 1108 | 1108 | ;; target pattern |
| 1109 | 1109 | ;; |
| 1110 | 1110 | (multiple-value-bind (dst-pat dst-method dst-varbs dst-p-vars) |
| 1111 | (if src-pat | |
| 1112 | (resolve-op-pattern-as-term dst-mod dst-opex dst-vars) | |
| 1113 | nil) | |
| 1114 | (declare (ignore dst-method dst-p-vars)) | |
| 1115 | (when dst-pat | |
| 1116 | ;; construct generic target pattern: | |
| 1117 | ;; replaces | |
| 1118 | (let ((subst nil) | |
| 1119 | (src-vn (mapcar #'(lambda (x) (variable-name x)) | |
| 1120 | src-varbs))) | |
| 1121 | (dolist (dv dst-varbs) | |
| 1122 | (let* ((vm (variable-name dv)) | |
| 1123 | (vpos (position-if #'(lambda (x) (equal vm x)) src-vn))) | |
| 1124 | (if vpos (push (cons dv (nth vpos src-p-vars)) subst)))) | |
| 1125 | (setq dst-pat | |
| 1126 | (substitution-simple-image subst dst-pat)) | |
| 1127 | (setq target-map-type :term))) | |
| 1128 | ;; | |
| 1129 | (when src-opinfo | |
| 1130 | (setq dst-opinfo (resolve-op-pattern-as-reference dst-mod dst-opex)) | |
| 1131 | (if dst-opinfo | |
| 1132 | (setq target-map-type :op-ref) | |
| 1133 | (unless dst-pat | |
| 1134 | (with-output-chaos-error ('invalid-map) | |
| 1135 | (format t "could not resolve operator target pattern : ~a" | |
| 1136 | dst-opex) | |
| 1137 | )))) | |
| 1138 | ;; | |
| 1139 | ;; make mapping | |
| 1140 | ;; | |
| 1141 | (cond ((and src-opinfo dst-opinfo) | |
| 1142 | ;; construct mappings, target must be always a term. | |
| 1143 | (let ((tm-list (opinfo-methods dst-opinfo))) | |
| 1144 | (dolist (sm (opinfo-methods src-opinfo)) | |
| 1145 | (when (or (method-is-user-defined-error-method sm) | |
| 1146 | (not (method-is-error-method sm))) | |
| 1147 | (let ((tm (find-method-mapped sm | |
| 1148 | sort-maps | |
| 1149 | tm-list | |
| 1150 | src-mod | |
| 1151 | dst-mod))) | |
| 1152 | (if tm | |
| 1153 | (let ((vars (make-psuedo-vars-from-sorts | |
| 1154 | (method-arity sm)))) | |
| 1155 | (push (list (make-term-check-op sm vars src-mod) | |
| 1156 | (make-term-check-op tm vars dst-mod)) | |
| 1157 | mappings)) | |
| 1158 | ;; | |
| 1159 | (with-output-chaos-error ('modexp-eval) | |
| 1160 | (format t "Operator mapping is not injective, the declaration") | |
| 1161 | (print-next) | |
| 1162 | (print-method sm src-mod) | |
| 1163 | (print-next) | |
| 1164 | (princ "has no proper image in the target,") | |
| 1165 | (print-next) | |
| 1166 | (princ "wrt the sort mappings:") | |
| 1167 | (let ((*print-indent* (+ 2 *print-indent*))) | |
| 1168 | (dolist (smap sort-maps) | |
| 1169 | (print-next) | |
| 1170 | (print-sort-name (car smap) src-mod) | |
| 1171 | (princ " --> ") | |
| 1172 | (print-sort-name (cdr smap) dst-mod))) | |
| 1173 | ))))))) | |
| 1174 | ((and src-pat dst-pat) | |
| 1175 | ;; must check rank is properly mapped. | |
| 1176 | (let ((src-method (if (term-is-applform? src-pat) | |
| 1177 | (term-head src-pat) | |
| 1178 | nil)) | |
| 1179 | (dst-method (if (term-is-applform? dst-pat) | |
| 1180 | (term-head dst-pat) | |
| 1181 | nil))) | |
| 1182 | (declare (ignore dst-method)) | |
| 1183 | (let ((coarity-mapped (*image-rename-sort sort-maps | |
| 1184 | (term-sort src-pat))) | |
| 1185 | (arity-mapped (if src-method | |
| 1186 | (*image-rename-sorts sort-maps | |
| 1187 | (method-arity | |
| 1188 | src-method)) | |
| 1189 | nil))) | |
| 1190 | (declare (ignore arity-mapped)) | |
| 1191 | (unless (sort= coarity-mapped (term-sort dst-pat)) | |
| 1192 | (with-output-chaos-warning () | |
| 1193 | (princ "operator mapping is not strict wrt sort map:") | |
| 1194 | (print-next) | |
| 1195 | (princ "* sort map") | |
| 1196 | (print-next) | |
| 1197 | (princ "- ") | |
| 1198 | (print-sort-name (term-sort src-pat) src-mod) | |
| 1199 | (princ " --> ") | |
| 1200 | (print-sort-name coarity-mapped dst-mod) | |
| 1201 | (print-next) | |
| 1202 | (princ "* operator map") | |
| 1203 | (print-next) | |
| 1204 | (princ "- source: ") | |
| 1205 | (with-in-module (src-mod) | |
| 1206 | (cond ((term-is-applform? src-pat) | |
| 1207 | (print-chaos-object (term-head src-pat))) | |
| 1208 | ((term-is-builtin-constant? src-pat) | |
| 1209 | (print-chaos-object src-pat) | |
| 1210 | (princ " : ") | |
| 1211 | (print-sort-name (term-sort src-pat))) | |
| 1212 | (t (print-chaos-object src-pat)))) | |
| 1213 | (print-next) | |
| 1214 | (princ "- target: ") | |
| 1215 | (with-in-module (dst-mod) | |
| 1216 | (cond ((term-is-applform? dst-pat) | |
| 1217 | (print-chaos-object (term-head dst-pat))) | |
| 1218 | ((term-is-builtin-constant? dst-pat) | |
| 1219 | (print-chaos-object dst-pat) | |
| 1220 | (princ " : ") | |
| 1221 | (print-sort-name (term-sort dst-pat))) | |
| 1222 | (t (print-chaos-object dst-pat))))))) | |
| 1223 | ) | |
| 1224 | ;; construct complex pattern mapping | |
| 1225 | (push (list src-pat dst-pat) mappings)) | |
| 1226 | ;;; ************* | |
| 1227 | (t (with-output-chaos-error ('modexp-eval) | |
| 1228 | ;; some useful message will going here.... | |
| 1229 | (princ "source and target of operator mapping must be the same type:") | |
| 1230 | (print-next) | |
| 1231 | (format t "- source type: ~a, target type: ~a" | |
| 1232 | (if (eq source-map-type :term) | |
| 1233 | 'term | |
| 1234 | "operator name") | |
| 1235 | (if (eq target-map-type :term) | |
| 1236 | 'term | |
| 1237 | "operator name")) | |
| 1238 | ) | |
| 1239 | )))) | |
| 1111 | (if src-pat | |
| 1112 | (resolve-op-pattern-as-term dst-mod dst-opex dst-vars) | |
| 1113 | nil) | |
| 1114 | (declare (ignore dst-method dst-p-vars)) | |
| 1115 | (when dst-pat | |
| 1116 | ;; construct generic target pattern: | |
| 1117 | ;; replaces | |
| 1118 | (let ((subst nil) | |
| 1119 | (src-vn (mapcar #'(lambda (x) (variable-name x)) | |
| 1120 | src-varbs))) | |
| 1121 | (dolist (dv dst-varbs) | |
| 1122 | (let* ((vm (variable-name dv)) | |
| 1123 | (vpos (position-if #'(lambda (x) (equal vm x)) src-vn))) | |
| 1124 | (if vpos (push (cons dv (nth vpos src-p-vars)) subst)))) | |
| 1125 | (setq dst-pat | |
| 1126 | (substitution-simple-image subst dst-pat)) | |
| 1127 | (setq target-map-type :term))) | |
| 1128 | ;; | |
| 1129 | (when src-opinfo | |
| 1130 | (setq dst-opinfo (resolve-op-pattern-as-reference dst-mod dst-opex)) | |
| 1131 | (if dst-opinfo | |
| 1132 | (setq target-map-type :op-ref) | |
| 1133 | (unless dst-pat | |
| 1134 | (with-output-chaos-error ('invalid-map) | |
| 1135 | (format t "could not resolve operator target pattern : ~a" | |
| 1136 | dst-opex) | |
| 1137 | )))) | |
| 1138 | ;; | |
| 1139 | ;; make mapping | |
| 1140 | ;; | |
| 1141 | (cond ((and src-opinfo dst-opinfo) | |
| 1142 | ;; construct mappings, target must be always a term. | |
| 1143 | (let ((tm-list (opinfo-methods dst-opinfo))) | |
| 1144 | (dolist (sm (opinfo-methods src-opinfo)) | |
| 1145 | (when (or (method-is-user-defined-error-method sm) | |
| 1146 | (not (method-is-error-method sm))) | |
| 1147 | (let ((tm (find-method-mapped sm | |
| 1148 | sort-maps | |
| 1149 | tm-list | |
| 1150 | src-mod | |
| 1151 | dst-mod))) | |
| 1152 | (if tm | |
| 1153 | (let ((vars (make-psuedo-vars-from-sorts | |
| 1154 | (method-arity sm)))) | |
| 1155 | (push (list (make-term-check-op sm vars src-mod) | |
| 1156 | (make-term-check-op tm vars dst-mod)) | |
| 1157 | mappings)) | |
| 1158 | ;; | |
| 1159 | (with-output-chaos-error ('modexp-eval) | |
| 1160 | (format t "Operator mapping is not injective, the declaration") | |
| 1161 | (print-next) | |
| 1162 | (print-method sm src-mod) | |
| 1163 | (print-next) | |
| 1164 | (princ "has no proper image in the target,") | |
| 1165 | (print-next) | |
| 1166 | (princ "wrt the sort mappings:") | |
| 1167 | (let ((*print-indent* (+ 2 *print-indent*))) | |
| 1168 | (dolist (smap sort-maps) | |
| 1169 | (print-next) | |
| 1170 | (print-sort-name (car smap) src-mod) | |
| 1171 | (princ " --> ") | |
| 1172 | (print-sort-name (cdr smap) dst-mod))) | |
| 1173 | ))))))) | |
| 1174 | ((and src-pat dst-pat) | |
| 1175 | ;; must check rank is properly mapped. | |
| 1176 | (let ((src-method (if (term-is-applform? src-pat) | |
| 1177 | (term-head src-pat) | |
| 1178 | nil)) | |
| 1179 | (dst-method (if (term-is-applform? dst-pat) | |
| 1180 | (term-head dst-pat) | |
| 1181 | nil))) | |
| 1182 | (declare (ignore dst-method)) | |
| 1183 | (let ((coarity-mapped (*image-rename-sort sort-maps | |
| 1184 | (term-sort src-pat))) | |
| 1185 | (arity-mapped (if src-method | |
| 1186 | (*image-rename-sorts sort-maps | |
| 1187 | (method-arity | |
| 1188 | src-method)) | |
| 1189 | nil))) | |
| 1190 | (declare (ignore arity-mapped)) | |
| 1191 | (unless (sort<= (term-sort dst-pat) coarity-mapped | |
| 1192 | (module-sort-order dst-mod)) | |
| 1193 | (with-output-chaos-warning () | |
| 1194 | (princ "operator mapping is not strict wrt sort map:") | |
| 1195 | (print-next) | |
| 1196 | (princ "* sort map") | |
| 1197 | (print-next) | |
| 1198 | (princ "- ") | |
| 1199 | (print-sort-name (term-sort src-pat) src-mod) | |
| 1200 | (princ " --> ") | |
| 1201 | (print-sort-name coarity-mapped dst-mod) | |
| 1202 | (print-next) | |
| 1203 | (princ "* operator map") | |
| 1204 | (print-next) | |
| 1205 | (princ "- source: ") | |
| 1206 | (with-in-module (src-mod) | |
| 1207 | (cond ((term-is-applform? src-pat) | |
| 1208 | (print-chaos-object (term-head src-pat))) | |
| 1209 | ((term-is-builtin-constant? src-pat) | |
| 1210 | (print-chaos-object src-pat) | |
| 1211 | (princ " : ") | |
| 1212 | (print-sort-name (term-sort src-pat))) | |
| 1213 | (t (print-chaos-object src-pat)))) | |
| 1214 | (print-next) | |
| 1215 | (princ "- target: ") | |
| 1216 | (with-in-module (dst-mod) | |
| 1217 | (cond ((term-is-applform? dst-pat) | |
| 1218 | (print-chaos-object (term-head dst-pat))) | |
| 1219 | ((term-is-builtin-constant? dst-pat) | |
| 1220 | (print-chaos-object dst-pat) | |
| 1221 | (princ " : ") | |
| 1222 | (print-sort-name (term-sort dst-pat))) | |
| 1223 | (t (print-chaos-object dst-pat))))))) | |
| 1224 | ) | |
| 1225 | ;; construct complex pattern mapping | |
| 1226 | (push (list src-pat dst-pat) mappings)) | |
| 1227 | ;;; ************* | |
| 1228 | (t (with-output-chaos-error ('modexp-eval) | |
| 1229 | ;; some useful message will going here.... | |
| 1230 | (princ "source and target of operator mapping must be the same type:") | |
| 1231 | (print-next) | |
| 1232 | (format t "- source type: ~a, target type: ~a" | |
| 1233 | (if (eq source-map-type :term) | |
| 1234 | 'term | |
| 1235 | "operator name") | |
| 1236 | (if (eq target-map-type :term) | |
| 1237 | 'term | |
| 1238 | "operator name")) | |
| 1239 | ) | |
| 1240 | )))) | |
| 1240 | 1241 | (when *on-view-debug* |
| 1241 | (format t "~&[compute op mapping]:") | |
| 1242 | (format t "~%[compute op mapping]:") | |
| 1242 | 1243 | (let* ((*print-indent* (+ *print-indent* 2)) |
| 1243 | (map (car mappings)) | |
| 1244 | (src (first map)) | |
| 1245 | (pvars (term-subterms src)) | |
| 1246 | (dst (second map))) | |
| 1247 | (with-in-module (src-mod) | |
| 1248 | (print-next) | |
| 1249 | (princ "src-pattern : ") | |
| 1250 | (if (term-is-builtin-constant? src) | |
| 1251 | (progn (term-print src) | |
| 1252 | (format t " of built-in sort ") | |
| 1253 | (print-sort-name (term-sort src))) | |
| 1254 | (print-method (term-head src))) | |
| 1255 | (print-next) | |
| 1256 | (princ "p-vars : ") | |
| 1257 | (print-chaos-object pvars)) | |
| 1258 | (with-in-module (dst-mod) | |
| 1259 | (print-next) | |
| 1260 | (princ "tgt-pattern : ") | |
| 1261 | (if (term-is-builtin-constant? dst) | |
| 1262 | (progn (term-print dst) | |
| 1263 | (format t " of built-in sort ") | |
| 1264 | (print-sort-name (term-sort dst))) | |
| 1265 | (print-method (term-head dst))) | |
| 1266 | (princ "(") (princ dst) (princ ")")) | |
| 1267 | )) | |
| 1244 | (map (car mappings)) | |
| 1245 | (src (first map)) | |
| 1246 | (pvars (term-subterms src)) | |
| 1247 | (dst (second map))) | |
| 1248 | (with-in-module (src-mod) | |
| 1249 | (print-next) | |
| 1250 | (princ "src-pattern : ") | |
| 1251 | (if (term-is-builtin-constant? src) | |
| 1252 | (progn (term-print src) | |
| 1253 | (format t " of built-in sort ") | |
| 1254 | (print-sort-name (term-sort src))) | |
| 1255 | (print-method (term-head src))) | |
| 1256 | (print-next) | |
| 1257 | (princ "p-vars : ") | |
| 1258 | (print-chaos-object pvars)) | |
| 1259 | (with-in-module (dst-mod) | |
| 1260 | (print-next) | |
| 1261 | (princ "tgt-pattern : ") | |
| 1262 | (if (term-is-builtin-constant? dst) | |
| 1263 | (progn (term-print dst) | |
| 1264 | (format t " of built-in sort ") | |
| 1265 | (print-sort-name (term-sort dst))) | |
| 1266 | (print-method (term-head dst))) | |
| 1267 | (princ "(") (princ dst) (princ ")")) | |
| 1268 | )) | |
| 1268 | 1269 | ;; check all at once |
| 1269 | 1270 | (let ((error nil)) |
| 1270 | 1271 | (dolist (map mappings) |
| 1271 | (let ((src (first map)) | |
| 1272 | (dst (second map))) | |
| 1273 | (case type | |
| 1274 | (:functional ; both should be functional operators | |
| 1275 | (unless (and (term-is-of-functional? src) | |
| 1276 | (term-is-of-functional? dst)) | |
| 1277 | (with-output-simple-msg () | |
| 1278 | (format t "[Error] source and target must be non-behavioural for `op' map:") | |
| 1279 | (format t "~&- source ") (print-term-method src src-mod) | |
| 1280 | (format t "~&- target ") (print-term-method dst dst-mod) | |
| 1281 | (setq error t)))) | |
| 1282 | (otherwise | |
| 1283 | (unless (and (term-is-of-behavioural*? src (module-opinfo-table | |
| 1284 | src-mod)) | |
| 1285 | (term-is-of-behavioural*? dst (module-opinfo-table | |
| 1286 | dst-mod))) | |
| 1287 | (with-output-simple-msg () | |
| 1288 | (format t "[Error] source and target must be behavioural for `bop' map:") | |
| 1289 | (format t "~&- source ") (print-term-method src src-mod) | |
| 1290 | (format t "~&- target ") (print-term-method dst dst-mod) | |
| 1291 | (setq error t))))))) | |
| 1272 | (let ((src (first map)) | |
| 1273 | (dst (second map))) | |
| 1274 | (case type | |
| 1275 | (:functional ; both should be functional operators | |
| 1276 | (unless (and (term-is-of-functional? src) | |
| 1277 | (term-is-of-functional? dst)) | |
| 1278 | (with-output-simple-msg () | |
| 1279 | (format t "[Error] source and target must be non-behavioural for `op' map:") | |
| 1280 | (format t "~&- source ") (print-term-method src src-mod) | |
| 1281 | (format t "~&- target ") (print-term-method dst dst-mod) | |
| 1282 | (setq error t)))) | |
| 1283 | (otherwise | |
| 1284 | (unless (and (term-is-of-behavioural*? src (module-opinfo-table | |
| 1285 | src-mod)) | |
| 1286 | (term-is-of-behavioural*? dst (module-opinfo-table | |
| 1287 | dst-mod))) | |
| 1288 | (with-output-simple-msg () | |
| 1289 | (format t "[Error] source and target must be behavioural for `bop' map:") | |
| 1290 | (format t "~&- source ") (print-term-method src src-mod) | |
| 1291 | (format t "~&- target ") (print-term-method dst dst-mod) | |
| 1292 | (setq error t))))))) | |
| 1292 | 1293 | (when error (chaos-to-top))) |
| 1293 | 1294 | ;; |
| 1294 | 1295 | mappings)) |
| 1297 | 1298 | |
| 1298 | 1299 | (defun find-method-mapped (src-method sort-maps method-list src-mod dst-mod) |
| 1299 | 1300 | (macrolet ((is-similar-theory? (th1_? th2_?) |
| 1300 | (once-only (th1_? th2_?) | |
| 1301 | ` (and (if (theory-contains-associativity ,th1_?) | |
| 1302 | (theory-contains-associativity ,th2_?) | |
| 1303 | t) | |
| 1304 | (if (theory-contains-commutativity ,th1_?) | |
| 1305 | (theory-contains-commutativity ,th2_?) | |
| 1306 | t) | |
| 1307 | (if (theory-contains-identity ,th1_?) | |
| 1308 | (theory-contains-identity ,th2_?) | |
| 1309 | t))))) | |
| 1301 | (once-only (th1_? th2_?) | |
| 1302 | ` (and (if (theory-contains-associativity ,th1_?) | |
| 1303 | (theory-contains-associativity ,th2_?) | |
| 1304 | t) | |
| 1305 | (if (theory-contains-commutativity ,th1_?) | |
| 1306 | (theory-contains-commutativity ,th2_?) | |
| 1307 | t) | |
| 1308 | (if (theory-contains-identity ,th1_?) | |
| 1309 | (theory-contains-identity ,th2_?) | |
| 1310 | t))))) | |
| 1310 | 1311 | (flet ((filter-method (arity coarity theory so) |
| 1311 | (declare (ignore theory)) | |
| 1312 | (remove-if-not | |
| 1313 | #'(lambda (method) | |
| 1314 | (and (if *view-map-operator-strictly* | |
| 1315 | (sort= (method-coarity method) coarity) | |
| 1316 | (sort<= (method-coarity method) coarity so)) | |
| 1317 | (if *view-map-operator-strictly* | |
| 1318 | (sort-list= (method-arity method) arity) | |
| 1319 | (sort-list<= (method-arity method) arity so)) | |
| 1320 | #|| ignore operator theory now. | |
| 1321 | (is-similar-theory? theory | |
| 1322 | (method-theory method | |
| 1323 | (module-opinfo-table | |
| 1324 | dst-mod))) | |
| 1325 | ||# | |
| 1326 | )) | |
| 1327 | method-list)) | |
| 1328 | (most-general-method (methods sort-order) | |
| 1329 | (when *on-view-debug* | |
| 1330 | (format t "~&[most-general-method]") | |
| 1331 | (dolist (x methods) | |
| 1332 | (print-next) | |
| 1333 | (princ "- ") | |
| 1334 | (print-chaos-object x))) | |
| 1335 | (let ((res (car methods))) | |
| 1336 | (dolist (x (cdr methods)) | |
| 1337 | (when (method< x res sort-order) | |
| 1338 | (setq res x))) | |
| 1339 | (when *on-view-debug* | |
| 1340 | (format t "~&* result = ") | |
| 1341 | (print-chaos-object res)) | |
| 1342 | res)) | |
| 1343 | ) | |
| 1312 | (declare (ignore theory)) | |
| 1313 | (remove-if-not | |
| 1314 | #'(lambda (method) | |
| 1315 | (and (if *view-map-operator-strictly* | |
| 1316 | (sort= (method-coarity method) coarity) | |
| 1317 | (sort<= (method-coarity method) coarity so)) | |
| 1318 | (if *view-map-operator-strictly* | |
| 1319 | (sort-list= (method-arity method) arity) | |
| 1320 | (sort-list<= (method-arity method) arity so)) | |
| 1321 | #|| ignore operator theory now. | |
| 1322 | (is-similar-theory? theory | |
| 1323 | (method-theory method | |
| 1324 | (module-opinfo-table | |
| 1325 | dst-mod))) | |
| 1326 | ||# | |
| 1327 | )) | |
| 1328 | method-list)) | |
| 1329 | (most-general-method (methods sort-order) | |
| 1330 | (when *on-view-debug* | |
| 1331 | (format t "~&[most-general-method]") | |
| 1332 | (dolist (x methods) | |
| 1333 | (print-next) | |
| 1334 | (princ "- ") | |
| 1335 | (print-chaos-object x))) | |
| 1336 | (let ((res (car methods))) | |
| 1337 | (dolist (x (cdr methods)) | |
| 1338 | (when (method< x res sort-order) | |
| 1339 | (setq res x))) | |
| 1340 | (when *on-view-debug* | |
| 1341 | (format t "~%* result = ") | |
| 1342 | (print-chaos-object res)) | |
| 1343 | res))) | |
| 1344 | 1344 | ;; |
| 1345 | 1345 | (let ((coarity (*image-rename-sort sort-maps (method-coarity src-method))) |
| 1346 | (arity (*image-rename-sorts sort-maps (method-arity src-method))) | |
| 1347 | (theory (method-theory src-method (module-opinfo-table src-mod))) | |
| 1348 | (sort-order (module-sort-order dst-mod))) | |
| 1349 | (let ((val (filter-method arity coarity theory sort-order)) | |
| 1350 | (result nil)) | |
| 1351 | (if (and val (null (cdr val))) | |
| 1352 | (setq result (car val)) | |
| 1353 | (if val | |
| 1354 | (setq result (most-general-method val sort-order)) | |
| 1355 | (progn | |
| 1356 | (setq arity (find-sorts-image* (method-arity src-method) | |
| 1357 | sort-maps | |
| 1358 | dst-mod)) | |
| 1359 | (setq coarity (find-sort-image* | |
| 1360 | (method-coarity src-method) | |
| 1361 | sort-maps | |
| 1362 | dst-mod)) | |
| 1363 | (setq val (filter-method arity coarity theory sort-order)) | |
| 1364 | (if (and val (null (cdr val))) | |
| 1365 | (setq result (car val)) | |
| 1366 | (if (cdr val) | |
| 1367 | (setq result (most-general-method val sort-order)) | |
| 1368 | (setq result nil)))))) | |
| 1369 | ;; | |
| 1370 | (when result | |
| 1371 | (unless (and (sort= (method-coarity result) coarity) | |
| 1372 | (sort-list= (method-arity result) arity)) | |
| 1373 | (with-output-chaos-warning () | |
| 1374 | (princ "operator mapping is not strict wrt sort map:") | |
| 1375 | (print-next) | |
| 1376 | (princ "* sort map") | |
| 1377 | (dotimes (x (length arity)) | |
| 1378 | (print-next) | |
| 1379 | (princ "- ") | |
| 1380 | (print-sort-name (nth x (method-arity src-method)) | |
| 1381 | src-mod) | |
| 1382 | (princ " --> ") | |
| 1383 | (print-sort-name (nth x arity) dst-mod)) | |
| 1384 | (print-next) | |
| 1385 | (princ "- ") | |
| 1386 | (print-sort-name (method-coarity src-method) src-mod) | |
| 1387 | (princ " --> ") | |
| 1388 | (print-sort-name coarity dst-mod) | |
| 1389 | (print-next) | |
| 1390 | (princ "* operator map") | |
| 1391 | (print-next) | |
| 1392 | (princ "- source: ") | |
| 1393 | (with-in-module (src-mod) | |
| 1394 | (print-chaos-object src-method)) | |
| 1395 | (print-next) | |
| 1396 | (princ "- target: ") | |
| 1397 | (with-in-module (dst-mod) | |
| 1398 | (print-chaos-object result)) | |
| 1399 | (fresh-line)))) | |
| 1400 | ;; | |
| 1401 | result))))) | |
| 1346 | (arity (*image-rename-sorts sort-maps (method-arity src-method))) | |
| 1347 | (theory (method-theory src-method (module-opinfo-table src-mod))) | |
| 1348 | (sort-order (module-sort-order dst-mod))) | |
| 1349 | (let ((val (filter-method arity coarity theory sort-order)) | |
| 1350 | (result nil)) | |
| 1351 | (if (and val (null (cdr val))) | |
| 1352 | (setq result (car val)) | |
| 1353 | (if val | |
| 1354 | (setq result (most-general-method val sort-order)) | |
| 1355 | (progn | |
| 1356 | (setq arity (find-sorts-image* (method-arity src-method) | |
| 1357 | sort-maps | |
| 1358 | dst-mod)) | |
| 1359 | (setq coarity (find-sort-image* | |
| 1360 | (method-coarity src-method) | |
| 1361 | sort-maps | |
| 1362 | dst-mod)) | |
| 1363 | (setq val (filter-method arity coarity theory sort-order)) | |
| 1364 | (if (and val (null (cdr val))) | |
| 1365 | (setq result (car val)) | |
| 1366 | (if (cdr val) | |
| 1367 | (setq result (most-general-method val sort-order)) | |
| 1368 | (setq result nil)))))) | |
| 1369 | ;; | |
| 1370 | (when result | |
| 1371 | (unless (and (sort= (method-coarity result) coarity) | |
| 1372 | (sort-list= (method-arity result) arity)) | |
| 1373 | (with-output-chaos-warning () | |
| 1374 | (princ "operator mapping is not strict wrt sort map:") | |
| 1375 | (print-next) | |
| 1376 | (princ "* sort map") | |
| 1377 | (dotimes (x (length arity)) | |
| 1378 | (print-next) | |
| 1379 | (princ "- ") | |
| 1380 | (print-sort-name (nth x (method-arity src-method)) | |
| 1381 | src-mod) | |
| 1382 | (princ " --> ") | |
| 1383 | (print-sort-name (nth x arity) dst-mod)) | |
| 1384 | (print-next) | |
| 1385 | (princ "- ") | |
| 1386 | (print-sort-name (method-coarity src-method) src-mod) | |
| 1387 | (princ " --> ") | |
| 1388 | (print-sort-name coarity dst-mod) | |
| 1389 | (print-next) | |
| 1390 | (princ "* operator map") | |
| 1391 | (print-next) | |
| 1392 | (princ "- source: ") | |
| 1393 | (with-in-module (src-mod) | |
| 1394 | (print-chaos-object src-method)) | |
| 1395 | (print-next) | |
| 1396 | (princ "- target: ") | |
| 1397 | (with-in-module (dst-mod) | |
| 1398 | (print-chaos-object result)) | |
| 1399 | (fresh-line)))) | |
| 1400 | ;; | |
| 1401 | result))))) | |
| 1402 | 1402 | |
| 1403 | 1403 | (defun find-sorts-image* (sorts sort-map mod) |
| 1404 | 1404 | (mapcar #'(lambda (s) (find-sort-image* s sort-map mod)) sorts)) |
| 1406 | 1406 | (defun find-sort-image* (sort sort-map mod) |
| 1407 | 1407 | (let ((imap (find-if #'(lambda (x) (sort= sort (car x))) sort-map))) |
| 1408 | 1408 | (if imap |
| 1409 | (cdr imap) | |
| 1410 | (find-sort-in mod (sort-id sort))))) | |
| 1409 | (cdr imap) | |
| 1410 | (find-sort-in mod (sort-id sort))))) | |
| 1411 | 1411 | |
| 1412 | 1412 | #|| |
| 1413 | 1413 | ;;; MODEXP-REPLACE-MAPPING view mapping |
| 1415 | 1415 | (defun modexp-replace-mapping (vm map) |
| 1416 | 1416 | (if (memq (ast-type vm) '(%view-from '%view-mapping)) |
| 1417 | 1417 | (progn (setf (ast-type vm) '%view-mapping) |
| 1418 | (setf (%view-mapping-map vm) map)) | |
| 1418 | (setf (%view-mapping-map vm) map)) | |
| 1419 | 1419 | (break "Internal Error : Misuse of modexp-replace-mapping."))) |
| 1420 | 1420 | ||# |
| 1421 | 1421 | |
| 0 | 0 | ;;;-*- Mode: Lisp; Syntax: CommonLisp Package: CHAOS -*- |
| 1 | 1 | ;;; |
| 2 | ;;; Copyright (c) 2000-2014, Toshimi Sawada. All rights reserved. | |
| 2 | ;;; Copyright (c) 2000-2015, Toshimi Sawada. All rights reserved. | |
| 3 | 3 | ;;; |
| 4 | 4 | ;;; Redistribution and use in source and binary forms, with or without |
| 5 | 5 | ;;; modification, are permitted provided that the following conditions |
| 27 | 27 | ;;; |
| 28 | 28 | (in-package :chaos) |
| 29 | 29 | #|============================================================================== |
| 30 | System:Chaos | |
| 31 | Module:e-match | |
| 32 | File:match-a.lisp | |
| 30 | System:Chaos | |
| 31 | Module:e-match | |
| 32 | File:match-a.lisp | |
| 33 | 33 | ==============================================================================|# |
| 34 | 34 | #-:chaos-debug |
| 35 | 35 | (declaim (optimize (speed 3) (safety 0) #-GCL (debug 0))) |
| 122 | 122 | (#-GCL defun #+GCL si:define-inline-function |
| 123 | 123 | match-associative-simplify (sub1 sub2) |
| 124 | 124 | (declare (type list sub1 sub2) |
| 125 | (values (or null t))) | |
| 125 | (values (or null t))) | |
| 126 | 126 | ;; |
| 127 | 127 | (do ((t1 (car sub1) (car sub1)) |
| 128 | 128 | (t2 (car sub2) (car sub2))) |
| 129 | 129 | ((or (null sub1) |
| 130 | (null sub2) | |
| 131 | (term-is-variable? t1) | |
| 132 | (not (term-equational-equal t1 t2)))) | |
| 130 | (null sub2) | |
| 131 | (term-is-variable? t1) | |
| 132 | (not (term-equational-equal t1 t2)))) | |
| 133 | 133 | (declare (type term t1 t2)) |
| 134 | 134 | (pop sub1) |
| 135 | 135 | (pop sub2)) |
| 136 | 136 | ;; |
| 137 | 137 | (setq sub1 (nreverse sub1) |
| 138 | sub2 (nreverse sub2)) | |
| 138 | sub2 (nreverse sub2)) | |
| 139 | 139 | (do ((t1 (car sub1) (car sub1)) |
| 140 | 140 | (t2 (car sub2) (car sub2))) |
| 141 | 141 | ((or (null sub1) |
| 142 | (null sub2) | |
| 143 | (term-is-variable? t1) | |
| 144 | (not (term-equational-equal t1 t2)))) | |
| 142 | (null sub2) | |
| 143 | (term-is-variable? t1) | |
| 144 | (not (term-equational-equal t1 t2)))) | |
| 145 | 145 | (declare (type term t1 t2)) |
| 146 | 146 | (pop sub1) |
| 147 | 147 | (pop sub2)) |
| 152 | 152 | (declare (type term x1)) |
| 153 | 153 | (when (term-is-variable? x1) (incf numvars))) |
| 154 | 154 | (if (and (<= 2 numvars) |
| 155 | (<= 3 (the fixnum (length sub1))) | |
| 156 | (<= 5 (the fixnum (length sub2)))) | |
| 157 | (if (block test1 | |
| 158 | (dolist (x1 sub1 nil) | |
| 159 | (declare (type term x1)) | |
| 160 | (unless (term-is-variable? x1) | |
| 161 | (dolist (x2 sub2 (return-from test1 t)) | |
| 162 | (declare (type term x2)) | |
| 163 | (when (and (not (term-is-variable? x2)) | |
| 164 | (possibly-matches-nonvar x1 x2)) | |
| 165 | (return)))))) | |
| 166 | (values nil nil t) | |
| 167 | (values (nreverse sub1) (nreverse sub2) nil)) | |
| 168 | (values (nreverse sub1) (nreverse sub2) nil)))) | |
| 155 | (<= 3 (the fixnum (length sub1))) | |
| 156 | (<= 5 (the fixnum (length sub2)))) | |
| 157 | (if (block test1 | |
| 158 | (dolist (x1 sub1 nil) | |
| 159 | (declare (type term x1)) | |
| 160 | (unless (term-is-variable? x1) | |
| 161 | (dolist (x2 sub2 (return-from test1 t)) | |
| 162 | (declare (type term x2)) | |
| 163 | (when (and (not (term-is-variable? x2)) | |
| 164 | (possibly-matches-nonvar x1 x2)) | |
| 165 | (return)))))) | |
| 166 | (values nil nil t) | |
| 167 | (values (nreverse sub1) (nreverse sub2) nil)) | |
| 168 | (values (nreverse sub1) (nreverse sub2) nil)))) | |
| 169 | 169 | |
| 170 | 170 | (declaim (inline match-associativity-set-eq-state)) |
| 171 | ||
| 171 | ||
| 172 | 172 | (#-GCL defun #+GCL si:define-inline-function |
| 173 | 173 | match-associativity-set-eq-state (sub1 sub2) |
| 174 | 174 | (declare (type list sub1 sub2)) |
| 175 | 175 | (let* ((sz1 (length sub1)) |
| 176 | (comp (alloc-svec-fixnum (if (= 0 sz1) 0 (- sz1 1))))) | |
| 176 | (comp (alloc-svec-fixnum (if (= 0 sz1) 0 (- sz1 1))))) | |
| 177 | 177 | (declare (type #+GCL vector #-GCL simple-vector comp) |
| 178 | (type fixnum sz1)) | |
| 178 | (type fixnum sz1)) | |
| 179 | 179 | (dotimes (x (- sz1 1)) |
| 180 | 180 | (declare (type fixnum x)) |
| 181 | 181 | ;; x = 0,...,sz1-2 |
| 182 | 182 | ;;built the array (1, 2, 3, 4) if sz1 = 5 |
| 183 | 183 | (setf (svref comp x) (1+ x))) |
| 184 | 184 | (make-match-equation-comp sz1 |
| 185 | (apply #'vector sub1) | |
| 186 | (apply #'vector sub2) | |
| 187 | comp))) | |
| 185 | (apply #'vector sub1) | |
| 186 | (apply #'vector sub2) | |
| 187 | comp))) | |
| 188 | 188 | |
| 189 | 189 | ;;; Create a single term from a collection of terms |
| 190 | 190 | ;;; |
| 193 | 193 | (#-GCL defun #+GCL si:define-inline-function |
| 194 | 194 | match-A-make-term (method vect first last) |
| 195 | 195 | (declare (type fixnum first last) |
| 196 | (type #+GCL vector #-GCL simple-vector vect)) | |
| 196 | (type #+GCL vector #-GCL simple-vector vect)) | |
| 197 | 197 | (if (= first last) |
| 198 | 198 | (svref vect first) |
| 199 | 199 | (let ((res (svref vect last))) |
| 200 | 200 | (if (and (< 1 (the fixnum (- last first))) |
| 201 | (null (cdr (method-lower-methods method)))) | |
| 202 | (do ((i (1- last) (1- i))) | |
| 203 | ((< i first) res) | |
| 204 | (declare (type fixnum i)) | |
| 205 | (setq res (make-term-with-sort-check method | |
| 206 | (list (svref vect i) res)))) | |
| 207 | (do ((i (1- last) (1- i))) | |
| 208 | ((< i first) res) | |
| 209 | (declare (type fixnum i)) | |
| 210 | (setq res (make-term-with-sort-check-bin method | |
| 211 | (list (svref vect i) res)))))))) | |
| 201 | (null (cdr (method-lower-methods method)))) | |
| 202 | (do ((i (1- last) (1- i))) | |
| 203 | ((< i first) res) | |
| 204 | (declare (type fixnum i)) | |
| 205 | (setq res (make-term-with-sort-check method | |
| 206 | (list (svref vect i) res)))) | |
| 207 | (do ((i (1- last) (1- i))) | |
| 208 | ((< i first) res) | |
| 209 | (declare (type fixnum i)) | |
| 210 | (setq res (make-term-with-sort-check-bin method | |
| 211 | (list (svref vect i) res)))))))) | |
| 212 | 212 | |
| 213 | 213 | ;;; Returns the list of terms contained in the array of terms "t-arr" |
| 214 | 214 | ;;; between the indices "from" and "to" both included. |
| 220 | 220 | (#-GCL defun #+GCL si:define-inline-function |
| 221 | 221 | match-A-extract-in-from-to (t-arr from to) |
| 222 | 222 | (declare (type fixnum from to) |
| 223 | (type #+GCL vector #-GCL simple-vector t-arr)) | |
| 223 | (type #+GCL vector #-GCL simple-vector t-arr)) | |
| 224 | 224 | (let ((t-list nil)) |
| 225 | 225 | (do ((i to (1- i))) |
| 226 | ((< i from) t-list) | |
| 226 | ((< i from) t-list) | |
| 227 | 227 | (declare (type fixnum i)) |
| 228 | 228 | (push (svref t-arr i) t-list)))) |
| 229 | 229 | |
| 236 | 236 | increment-the-match-A-state (A-st) |
| 237 | 237 | (block the-end |
| 238 | 238 | (let ((sz (match-A-state-size A-st)) |
| 239 | (sys (match-A-state-sys A-st))) | |
| 239 | (sys (match-A-state-sys A-st))) | |
| 240 | 240 | (declare (type fixnum sz) |
| 241 | (type #+GCL vector #-GCL simple-vector sys)) | |
| 241 | (type #+GCL vector #-GCL simple-vector sys)) | |
| 242 | 242 | (let ((k 0) |
| 243 | eq-comp) | |
| 244 | (declare (type fixnum k)) | |
| 245 | (while (> sz k) | |
| 246 | (setq eq-comp (svref sys k)) | |
| 247 | (when (match-A-try-increase-lexico | |
| 248 | (match-equation-comp-comp eq-comp) | |
| 249 | (1- (the fixnum | |
| 250 | (length (match-equation-comp-right eq-comp))))) | |
| 251 | ;; note that match-A-try-increase-lexico modify in this case | |
| 252 | ;; the "comp" of the current equation. | |
| 253 | ;; After that the previous composant are reset like in | |
| 254 | ;; 599 -> 600 | |
| 255 | (match-A-reset-match-equation-comp sys k) | |
| 256 | (return-from the-end (values nil))) | |
| 257 | ;;otherwise, try to increase the next equation | |
| 258 | (setq k (1+ k)) | |
| 259 | )) | |
| 243 | eq-comp) | |
| 244 | (declare (type fixnum k)) | |
| 245 | (while (> sz k) | |
| 246 | (setq eq-comp (svref sys k)) | |
| 247 | (when (match-A-try-increase-lexico | |
| 248 | (match-equation-comp-comp eq-comp) | |
| 249 | (1- (the fixnum | |
| 250 | (length (match-equation-comp-right eq-comp))))) | |
| 251 | ;; note that match-A-try-increase-lexico modify in this case | |
| 252 | ;; the "comp" of the current equation. | |
| 253 | ;; After that the previous composant are reset like in | |
| 254 | ;; 599 -> 600 | |
| 255 | (match-A-reset-match-equation-comp sys k) | |
| 256 | (return-from the-end (values nil))) | |
| 257 | ;;otherwise, try to increase the next equation | |
| 258 | (setq k (1+ k)) | |
| 259 | )) | |
| 260 | 260 | ;; this "normal" exit of the loop means that none of the |
| 261 | 261 | ;; state has been increased so there is no more state |
| 262 | 262 | (setf (match-A-state-no-more A-st) t) |
| 275 | 275 | (#-GCL defun #+GCL si:define-inline-function |
| 276 | 276 | match-A-try-increase-lexico (comp max) |
| 277 | 277 | (declare (type fixnum max) |
| 278 | (type #+GCL vector #-GCL simple-vector comp)) | |
| 278 | (type #+GCL vector #-GCL simple-vector comp)) | |
| 279 | 279 | (let ((lim (1- (length comp)))) |
| 280 | 280 | (declare (type fixnum lim)) |
| 281 | 281 | (do ((i lim (- i 1))) |
| 282 | ((< i 0) nil) | |
| 282 | ((< i 0) nil) | |
| 283 | 283 | (declare (type fixnum i)) |
| 284 | 284 | (let ((x (svref comp i))) |
| 285 | (declare (type fixnum x)) | |
| 286 | (when (< x max) | |
| 287 | (setf (svref comp i) (1+ x)) | |
| 288 | (do ((j (1+ i) (1+ j)) | |
| 289 | (v (+ x 2) (1+ v))) | |
| 290 | ((< lim j)) | |
| 291 | (declare (type fixnum j v)) | |
| 292 | (setf (svref comp j) v)) | |
| 293 | (return t))) | |
| 285 | (declare (type fixnum x)) | |
| 286 | (when (< x max) | |
| 287 | (setf (svref comp i) (1+ x)) | |
| 288 | (do ((j (1+ i) (1+ j)) | |
| 289 | (v (+ x 2) (1+ v))) | |
| 290 | ((< lim j)) | |
| 291 | (declare (type fixnum j v)) | |
| 292 | (setf (svref comp j) v)) | |
| 293 | (return t))) | |
| 294 | 294 | (setq max (1- max))))) |
| 295 | 295 | |
| 296 | 296 | ;;; Reset the comp of "eq-comp" to his initial value i.e. (1,2,3,4,5) |
| 314 | 314 | (#-GCL defun #+GCL si:define-inline-function |
| 315 | 315 | match-A-reset-match-equation-comp (sys K) |
| 316 | 316 | (declare (type #+GCL vector #-GCL simple-vector sys) |
| 317 | (type fixnum k)) | |
| 318 | (dotimes (i K) ; i = 0,...,K-1 | |
| 317 | (type fixnum k)) | |
| 318 | (dotimes (i K) ; i = 0,...,K-1 | |
| 319 | 319 | (declare (type fixnum i)) |
| 320 | 320 | (match-A-reset-comp (svref sys i)))) |
| 321 | 321 | |
| 337 | 337 | (defun match-A-state-initialize (sys env) |
| 338 | 338 | (block no-match |
| 339 | 339 | (let* ((dim nil) |
| 340 | (assoc-sys nil) | |
| 341 | (method nil) | |
| 342 | (i 0)) | |
| 340 | (assoc-sys nil) | |
| 341 | (method nil) | |
| 342 | (i 0)) | |
| 343 | 343 | (declare (type fixnum i) |
| 344 | (type (or null fixnum) dim) | |
| 345 | (type #+GCL (or null vector) | |
| 346 | #-GCL (or null simple-vector) | |
| 347 | assoc-sys) | |
| 348 | ) | |
| 344 | (type (or null fixnum) dim) | |
| 345 | (type #+GCL (or null vector) | |
| 346 | #-GCL (or null simple-vector) | |
| 347 | assoc-sys) | |
| 348 | ) | |
| 349 | 349 | (dolist (equation (m-system-to-list sys)) |
| 350 | (let ((t1 (equation-t1 equation)) | |
| 351 | (t2 (equation-t2 equation))) | |
| 352 | (unless (and (term-is-application-form? t2) | |
| 353 | (method-is-of-same-operator+ (term-method t1) | |
| 354 | (term-method t2)) | |
| 355 | (setq method (term-method t1))) | |
| 356 | (return-from no-match (values nil t))) | |
| 357 | ;; | |
| 358 | (let* ((sub1 (list-assoc-subterms t1 method)) | |
| 359 | (sub1add nil) | |
| 360 | (sub2 (list-assoc-subterms t2 method)) | |
| 361 | (sub2-len (length sub2)) | |
| 362 | (fail nil)) | |
| 363 | (declare (type list sub1 sub2) | |
| 364 | (type fixnum sub2-len)) | |
| 365 | ;; | |
| 366 | ;;(when (> (the fixnum (length sub1)) sub2-len) | |
| 367 | ;; (return-from no-match (values nil t))) | |
| 368 | ;; | |
| 369 | ;; add the additional information contained in "env" into "sub1". | |
| 370 | (dolist (val sub1) | |
| 371 | (declare (type term val)) | |
| 372 | (if (term-is-variable? val) | |
| 373 | (let ((image (environment-image env val)) | |
| 374 | (head nil)) | |
| 375 | (declare (type (or null term) image)) | |
| 376 | (if (null image) | |
| 377 | (push val sub1add) | |
| 378 | (if (term-is-variable? image) | |
| 379 | (push image sub1add) | |
| 380 | (if (eq method (setf head (term-method image))) | |
| 381 | (setq sub1add | |
| 382 | (nconc | |
| 383 | (reverse | |
| 384 | (list-assoc-subterms image head)) | |
| 385 | sub1add)) | |
| 386 | (push image sub1add))))) | |
| 387 | (push val sub1add))) | |
| 388 | ;; | |
| 389 | (setq sub1 (nreverse sub1add)) | |
| 390 | ;; | |
| 391 | (when (> (the fixnum (length sub1)) sub2-len) | |
| 392 | (return-from no-match (values nil t))) | |
| 393 | (multiple-value-setq (sub1 sub2 fail) | |
| 394 | (match-associative-simplify sub1 sub2)) | |
| 395 | (when (or fail | |
| 396 | (and (null sub1) sub2) | |
| 397 | (and (null sub2) sub1)) | |
| 398 | (return-from no-match (values nil t))) | |
| 399 | ;; sub1 may be nil but have modified match-A-..set-eq-state | |
| 400 | (unless assoc-sys | |
| 401 | (setq dim (size-of-m-system sys)) | |
| 402 | (setq assoc-sys (alloc-svec (the fixnum dim)))) | |
| 403 | (setf (svref assoc-sys i) | |
| 404 | (match-associativity-set-eq-state sub1 sub2)))) | |
| 405 | (setq i (1+ i))) | |
| 350 | (let ((t1 (equation-t1 equation)) | |
| 351 | (t2 (equation-t2 equation))) | |
| 352 | (unless (and (term-is-application-form? t2) | |
| 353 | (method-is-of-same-operator+ (term-method t1) | |
| 354 | (term-method t2)) | |
| 355 | (setq method (term-method t1))) | |
| 356 | (return-from no-match (values nil t))) | |
| 357 | ;; | |
| 358 | (let* ((sub1 (list-assoc-subterms t1 method)) | |
| 359 | (sub1add nil) | |
| 360 | (sub2 (list-assoc-subterms t2 method)) | |
| 361 | (sub2-len (length sub2)) | |
| 362 | (fail nil)) | |
| 363 | (declare (type list sub1 sub2) | |
| 364 | (type fixnum sub2-len)) | |
| 365 | ;; | |
| 366 | ;;(when (> (the fixnum (length sub1)) sub2-len) | |
| 367 | ;; (return-from no-match (values nil t))) | |
| 368 | ;; | |
| 369 | ;; add the additional information contained in "env" into "sub1". | |
| 370 | (dolist (val sub1) | |
| 371 | (declare (type term val)) | |
| 372 | (if (term-is-variable? val) | |
| 373 | (let ((image (environment-image env val)) | |
| 374 | (head nil)) | |
| 375 | (declare (type (or null term) image)) | |
| 376 | (if (null image) | |
| 377 | (push val sub1add) | |
| 378 | (if (term-is-variable? image) | |
| 379 | (push image sub1add) | |
| 380 | (if (eq method (setf head (term-method image))) | |
| 381 | (setq sub1add | |
| 382 | (nconc | |
| 383 | (reverse | |
| 384 | (list-assoc-subterms image head)) | |
| 385 | sub1add)) | |
| 386 | (push image sub1add))))) | |
| 387 | (push val sub1add))) | |
| 388 | ;; | |
| 389 | (setq sub1 (nreverse sub1add)) | |
| 390 | ;; | |
| 391 | (when (> (the fixnum (length sub1)) sub2-len) | |
| 392 | (return-from no-match (values nil t))) | |
| 393 | (multiple-value-setq (sub1 sub2 fail) | |
| 394 | (match-associative-simplify sub1 sub2)) | |
| 395 | (when (or fail | |
| 396 | (and (null sub1) sub2) | |
| 397 | (and (null sub2) sub1)) | |
| 398 | (return-from no-match (values nil t))) | |
| 399 | ;; sub1 may be nil but have modified match-A-..set-eq-state | |
| 400 | (unless assoc-sys | |
| 401 | (setq dim (size-of-m-system sys)) | |
| 402 | (setq assoc-sys (alloc-svec (the fixnum dim)))) | |
| 403 | (setf (svref assoc-sys i) | |
| 404 | (match-associativity-set-eq-state sub1 sub2)))) | |
| 405 | (setq i (1+ i))) | |
| 406 | 406 | (values (make-match-A-state dim method assoc-sys) |
| 407 | nil)))) | |
| 407 | nil)))) | |
| 408 | 408 | |
| 409 | 409 | ;;; ASSOCITIVITY NEXT STATE ---------------------------------------------------- |
| 410 | 410 | |
| 411 | 411 | (defun match-A-next-state (A-st) |
| 412 | 412 | (declare (type match-a-state a-st) |
| 413 | (values list (or null match-a-state) (or null t))) | |
| 413 | (values list (or null match-a-state) (or null t))) | |
| 414 | 414 | (let* ((new-sys (new-m-system)) |
| 415 | (sz (match-A-state-size A-st)) | |
| 416 | (sys (match-A-state-sys A-st)) | |
| 417 | (method (match-A-state-method A-st))) | |
| 415 | (sz (match-A-state-size A-st)) | |
| 416 | (sys (match-A-state-sys A-st)) | |
| 417 | (method (match-A-state-method A-st))) | |
| 418 | 418 | (declare (type fixnum sz) |
| 419 | (type vector sys)) | |
| 420 | (if (match-A-state-no-more A-st) | |
| 421 | ;; there is no more match-A-state. | |
| 422 | (values nil nil t) | |
| 419 | (type vector sys)) | |
| 420 | (if (match-A-state-no-more A-st) | |
| 421 | ;; there is no more match-A-state. | |
| 422 | (values nil nil t) | |
| 423 | 423 | (progn |
| 424 | (dotimes (k sz) | |
| 425 | (declare (type fixnum k)) | |
| 426 | ;; for each equation of the system | |
| 427 | (let* ((eq-comp (svref sys k)) | |
| 428 | (sz-left (match-equation-comp-sz-left eq-comp)) | |
| 429 | (left (match-equation-comp-left eq-comp)) | |
| 430 | (right (match-equation-comp-right eq-comp)) | |
| 431 | (sz-right (1- (the fixnum (length right)))) | |
| 432 | (comp (match-equation-comp-comp eq-comp))) | |
| 433 | (declare (type fixnum sz-left sz-right) | |
| 434 | (type #+GCL vector #-GCL simple-vector left right) | |
| 435 | (type #+GCL vector #-GCL simple-vector comp)) | |
| 436 | (dotimes (l sz-left) | |
| 437 | (declare (type fixnum l)) | |
| 438 | ;; i.e. for each term of the left hand | |
| 439 | ;; side of the equation | |
| 440 | (let ((deb (if (= l 0) | |
| 441 | 0 | |
| 442 | (svref comp (the fixnum (1- l))))) | |
| 443 | (fin (if (= l (the fixnum (1- sz-left))) | |
| 444 | sz-right | |
| 445 | (1- (the fixnum (svref comp l)))))) | |
| 446 | (declare (type fixnum deb fin)) | |
| 447 | (add-equation-to-m-system | |
| 448 | new-sys | |
| 449 | (make-equation | |
| 450 | (svref left l) | |
| 451 | (match-A-make-term method right deb fin))))) | |
| 452 | )) | |
| 453 | (increment-the-match-A-state A-st) ; A-st is modified | |
| 454 | (values new-sys A-st nil))))) | |
| 424 | (dotimes (k sz) | |
| 425 | (declare (type fixnum k)) | |
| 426 | ;; for each equation of the system | |
| 427 | (let* ((eq-comp (svref sys k)) | |
| 428 | (sz-left (match-equation-comp-sz-left eq-comp)) | |
| 429 | (left (match-equation-comp-left eq-comp)) | |
| 430 | (right (match-equation-comp-right eq-comp)) | |
| 431 | (sz-right (1- (the fixnum (length right)))) | |
| 432 | (comp (match-equation-comp-comp eq-comp))) | |
| 433 | (declare (type fixnum sz-left sz-right) | |
| 434 | (type #+GCL vector #-GCL simple-vector left right) | |
| 435 | (type #+GCL vector #-GCL simple-vector comp)) | |
| 436 | (dotimes (l sz-left) | |
| 437 | (declare (type fixnum l)) | |
| 438 | ;; i.e. for each term of the left hand | |
| 439 | ;; side of the equation | |
| 440 | (let ((deb (if (= l 0) | |
| 441 | 0 | |
| 442 | (svref comp (the fixnum (1- l))))) | |
| 443 | (fin (if (= l (the fixnum (1- sz-left))) | |
| 444 | sz-right | |
| 445 | (1- (the fixnum (svref comp l)))))) | |
| 446 | (declare (type fixnum deb fin)) | |
| 447 | (add-equation-to-m-system | |
| 448 | new-sys | |
| 449 | (make-equation | |
| 450 | (svref left l) | |
| 451 | (match-A-make-term method right deb fin))))) | |
| 452 | )) | |
| 453 | (increment-the-match-A-state A-st) ; A-st is modified | |
| 454 | (values new-sys A-st nil))))) | |
| 455 | 455 | |
| 456 | 456 | |
| 457 | 457 | ;;; Associative Equational Equal ------------------------------------------------ |
| 460 | 460 | ;;; |
| 461 | 461 | (defun match-A-equal (t1 t2) |
| 462 | 462 | (declare (type term t1 t2) |
| 463 | (values (or null t))) | |
| 463 | (values (or null t))) | |
| 464 | 464 | (if (term-is-application-form? t2) |
| 465 | 465 | (let ((hd2 (term-method t2))) |
| 466 | (if (method-is-of-same-operator (term-head t1) | |
| 467 | hd2) | |
| 468 | (let ((l1 (list-assoc-subterms t1 (term-method t1))) | |
| 469 | (l2 (list-assoc-subterms t2 hd2))) | |
| 470 | (declare (type list l1 l2)) | |
| 471 | (and (= (the fixnum (length l1)) (the fixnum (length l2))) | |
| 472 | (loop (when (null l1) (return (null l2))) | |
| 473 | (unless (term-equational-equal (car l1) (car l2)) | |
| 474 | (return nil)) | |
| 475 | (setq l1 (cdr l1) l2 (cdr l2))))) | |
| 476 | nil)) | |
| 466 | (if (method-is-of-same-operator (term-head t1) | |
| 467 | hd2) | |
| 468 | (let ((l1 (list-assoc-subterms t1 (term-method t1))) | |
| 469 | (l2 (list-assoc-subterms t2 hd2))) | |
| 470 | (declare (type list l1 l2)) | |
| 471 | (and (= (the fixnum (length l1)) (the fixnum (length l2))) | |
| 472 | (loop (when (null l1) (return (null l2))) | |
| 473 | (unless (term-equational-equal (car l1) (car l2)) | |
| 474 | (return nil)) | |
| 475 | (setq l1 (cdr l1) l2 (cdr l2))))) | |
| 476 | nil)) | |
| 477 | 477 | nil)) |
| 478 | 478 | |
| 479 | 479 | ;;; EOF |
| 0 | 0 | ;;;-*- Mode:Lisp; Syntax:CommonLisp; Package: CHAOS -*- |
| 1 | 1 | ;;; |
| 2 | ;;; Copyright (c) 2000-2014, Toshimi Sawada. All rights reserved. | |
| 2 | ;;; Copyright (c) 2000-2015, Toshimi Sawada. All rights reserved. | |
| 3 | 3 | ;;; |
| 4 | 4 | ;;; Redistribution and use in source and binary forms, with or without |
| 5 | 5 | ;;; modification, are permitted provided that the following conditions |
| 27 | 27 | ;;; |
| 28 | 28 | (in-package :chaos) |
| 29 | 29 | #|============================================================================== |
| 30 | System:Chaos | |
| 31 | Module:e-match | |
| 32 | File:match-ac.lisp | |
| 30 | System:Chaos | |
| 31 | Module:e-match | |
| 32 | File:match-ac.lisp | |
| 33 | 33 | ==============================================================================|# |
| 34 | 34 | |
| 35 | 35 | #-:chaos-debug |
| 37 | 37 | |
| 38 | 38 | #+:chaos-debug |
| 39 | 39 | (declaim (optimize (speed 1) (safety 3) #-(or GCL EXCL) (debug 3) |
| 40 | #+EXCL (debug 2))) | |
| 40 | #+EXCL (debug 2))) | |
| 41 | 41 | |
| 42 | 42 | ;;; PROCEDURES for AC Matching ================================================ |
| 43 | 43 | |
| 201 | 201 | ;;; Thus PDL implements AC-state on his own. |
| 202 | 202 | #| |
| 203 | 203 | (defstruct AC-state |
| 204 | operators ; array[op] | |
| 205 | ; the top level operators of each eqn in the system | |
| 206 | LHS-f ; array[term] functional terms | |
| 207 | LHS-v ; array[term] variables | |
| 208 | RHS-c ; array[term] constants | |
| 209 | RHS-f ; array[term] functional terms | |
| 210 | LHS-f-r ; array[bool] notes repeated functional terms | |
| 211 | LHS-v-r ; array[bool] notes repeated variables | |
| 212 | RHS-c-r ; array[bool] notes repeated constants | |
| 213 | RHS-f-r ; array[bool] notes repeated functional terms | |
| 214 | (LHS-mask 0) ; long int variables and funs accounted | |
| 215 | ; for by RHS-c-sol | |
| 216 | (LHS-f-mask 0) ; long int funs accounted for by RHS-c-sol | |
| 217 | (LHS-r-mask 0) ; long int bitvector of all repeated (>0) | |
| 218 | ; terms on lhs | |
| 219 | RHS-c-sol ; array[int] solution matrix; constants | |
| 220 | RHS-c-max ; int ; max value of elements of RHS-c-sol | |
| 221 | RHS-f-sol ; array[int] solution matrix; functional terms | |
| 222 | RHS-f-max ; int max value of elements of RHS-f-sol | |
| 223 | RHS-full-bits ; int 11111...111 | |
| 224 | RHS-c-compat ; array[int] array of compatibility bitvectors | |
| 225 | RHS-f-compat ; array[int] array of compatibility bitvectors | |
| 226 | LHS-c-count ; int number of constants on LHS | |
| 227 | ; after simplification | |
| 228 | LHS-f-count ; int number of functions on LHS | |
| 229 | ; after simplification | |
| 230 | LHS-v-count ; int number of variables on LHS | |
| 231 | ; after simplification | |
| 232 | RHS-c-count ; int number of constants on RHS | |
| 233 | ; after simplification | |
| 234 | RHS-f-count ; int number of functions on RHS | |
| 235 | ; after simplification | |
| 236 | RHS-f-match-top-ac ; array[bool] can that term match the top op? (nil) | |
| 237 | (no-more nil) ; when true implies that all solutions | |
| 238 | ; have been reported | |
| 204 | operators ; array[op] | |
| 205 | ; the top level operators of each eqn in the system | |
| 206 | LHS-f ; array[term] functional terms | |
| 207 | LHS-v ; array[term] variables | |
| 208 | RHS-c ; array[term] constants | |
| 209 | RHS-f ; array[term] functional terms | |
| 210 | LHS-f-r ; array[bool] notes repeated functional terms | |
| 211 | LHS-v-r ; array[bool] notes repeated variables | |
| 212 | RHS-c-r ; array[bool] notes repeated constants | |
| 213 | RHS-f-r ; array[bool] notes repeated functional terms | |
| 214 | (LHS-mask 0) ; long int variables and funs accounted | |
| 215 | ; for by RHS-c-sol | |
| 216 | (LHS-f-mask 0) ; long int funs accounted for by RHS-c-sol | |
| 217 | (LHS-r-mask 0) ; long int bitvector of all repeated (>0) | |
| 218 | ; terms on lhs | |
| 219 | RHS-c-sol ; array[int] solution matrix; constants | |
| 220 | RHS-c-max ; int ; max value of elements of RHS-c-sol | |
| 221 | RHS-f-sol ; array[int] solution matrix; functional terms | |
| 222 | RHS-f-max ; int max value of elements of RHS-f-sol | |
| 223 | RHS-full-bits ; int 11111...111 | |
| 224 | RHS-c-compat ; array[int] array of compatibility bitvectors | |
| 225 | RHS-f-compat ; array[int] array of compatibility bitvectors | |
| 226 | LHS-c-count ; int number of constants on LHS | |
| 227 | ; after simplification | |
| 228 | LHS-f-count ; int number of functions on LHS | |
| 229 | ; after simplification | |
| 230 | LHS-v-count ; int number of variables on LHS | |
| 231 | ; after simplification | |
| 232 | RHS-c-count ; int number of constants on RHS | |
| 233 | ; after simplification | |
| 234 | RHS-f-count ; int number of functions on RHS | |
| 235 | ; after simplification | |
| 236 | RHS-f-match-top-ac ; array[bool] can that term match the top op? (nil) | |
| 237 | (no-more nil) ; when true implies that all solutions | |
| 238 | ; have been reported | |
| 239 | 239 | ) |
| 240 | 240 | |# |
| 241 | 241 | (defmacro make-AC-state () `(alloc-svec 26)) |
| 352 | 352 | (defmacro AC-Rotate-Left (_*_*_array *_*_*m) |
| 353 | 353 | " shifts the element one bit to the left" |
| 354 | 354 | ` (setf (svref ,_*_*_array ,*_*_*m) |
| 355 | (* 2 (svref ,_*_*_array ,*_*_*m)))) | |
| 355 | (* 2 (svref ,_*_*_array ,*_*_*m)))) | |
| 356 | 356 | |
| 357 | 357 | (defmacro AC-note-repeats (_??mset _??array _??max _??gcd) |
| 358 | 358 | "; puts all repeated terms together in the list, and bashes the array |
| 361 | 361 | ; e.g. for input (a b c c c d d e f f) and #(0 0 0 0 0 0 0 0 0), |
| 362 | 362 | ; this should make the array into #(0 0 3 2 1 2 1 0 2 1)." |
| 363 | 363 | ` (let* ((list2 nil) |
| 364 | (counter (length (the #+GCL vector #-GCL simple-vector ,_??array)))) | |
| 364 | (counter (length (the #+GCL vector #-GCL simple-vector ,_??array)))) | |
| 365 | 365 | (declare (type fixnum counter)) |
| 366 | 366 | (dolist (element ,_??mset) |
| 367 | (declare (type list element)) | |
| 368 | (let ((n (cdr element))) | |
| 369 | (declare (type fixnum n)) | |
| 370 | (when (> n (the fixnum ,_??max)) | |
| 371 | (setq ,_??max n)) | |
| 372 | (setq ,_??gcd (gcd ,_??gcd n)) | |
| 373 | (if (> n 1) ; if it is repeated at all | |
| 374 | (dotimes (x n) | |
| 375 | (declare (type fixnum x)) | |
| 376 | (push (first element) list2) | |
| 377 | (setq counter (1- counter)) | |
| 378 | (setf (svref ,_??array counter) | |
| 379 | (1+ x))) | |
| 380 | (progn (push (first element) list2) | |
| 381 | (setq counter (1- counter)) | |
| 382 | ;; this line optional if 0'd array is guaranteed. | |
| 383 | (setf (svref ,_??array counter) 0))))) | |
| 367 | (declare (type list element)) | |
| 368 | (let ((n (cdr element))) | |
| 369 | (declare (type fixnum n)) | |
| 370 | (when (> n (the fixnum ,_??max)) | |
| 371 | (setq ,_??max n)) | |
| 372 | (setq ,_??gcd (gcd ,_??gcd n)) | |
| 373 | (if (> n 1) ; if it is repeated at all | |
| 374 | (dotimes (x n) | |
| 375 | (declare (type fixnum x)) | |
| 376 | (push (first element) list2) | |
| 377 | (setq counter (1- counter)) | |
| 378 | (setf (svref ,_??array counter) | |
| 379 | (1+ x))) | |
| 380 | (progn (push (first element) list2) | |
| 381 | (setq counter (1- counter)) | |
| 382 | ;; this line optional if 0'd array is guaranteed. | |
| 383 | (setf (svref ,_??array counter) 0))))) | |
| 384 | 384 | list2)) |
| 385 | 385 | |
| 386 | 386 | #+CMU(declaim (ext:start-block match-ac-state-initialize |
| 387 | match-ac-next-state | |
| 388 | match-ac-equal)) | |
| 387 | match-ac-next-state | |
| 388 | match-ac-equal)) | |
| 389 | 389 | |
| 390 | 390 | ;;; x = term |
| 391 | 391 | ;;; y = ((term . eqn-num) ... ) |
| 392 | 392 | #|| |
| 393 | (defun delete-one-term | |
| 394 | (x y) | |
| 393 | (defun delete-one-term (x y) | |
| 395 | 394 | (block exit |
| 396 | 395 | (if (null y) |
| 397 | 'none | |
| 398 | (if (term-is-applform? x) | |
| 399 | ;; application form | |
| 400 | (let ((head (term-head x)) | |
| 401 | (pos nil)) | |
| 402 | (setq pos | |
| 403 | (position-if | |
| 404 | #'(lambda (tv) | |
| 405 | (let ((term (car tv))) | |
| 406 | (and (term-is-applform? term) | |
| 407 | (method-is-of-same-operator head | |
| 408 | (term-head term))))) | |
| 409 | (the list y))) | |
| 410 | ;; (break "0") | |
| 411 | (unless pos | |
| 412 | (return-from exit :never-match)) | |
| 413 | (if (zerop pos) | |
| 414 | (if (term-equational-equal x (caar y)) | |
| 415 | (return-from exit (cdr y)) | |
| 416 | (return-from exit 'none)) | |
| 417 | (let ((last y) | |
| 418 | (rest (cdr y)) | |
| 419 | (cur-pos 1)) | |
| 420 | (declare (type fixnum cur-pos)) | |
| 421 | (loop | |
| 422 | (when (= cur-pos pos) | |
| 423 | (if (term-equational-equal x | |
| 424 | (caar rest)) | |
| 425 | (progn | |
| 426 | ;; delete pattern | |
| 427 | (rplacd last (cdr rest)) | |
| 428 | (return-from exit y)) | |
| 429 | (return-from exit 'none))) | |
| 430 | (incf cur-pos) | |
| 431 | (setq last rest rest (cdr rest)))) | |
| 432 | )) | |
| 433 | ;; | |
| 434 | (if (term-equational-equal x (caar y)) | |
| 435 | (cdr y) | |
| 436 | (let ((last y) (rest (cdr y))) | |
| 437 | (loop (when (null rest) (return 'none)) | |
| 438 | (when (term-equational-equal x (caar rest)) | |
| 439 | ;; delete pattern | |
| 440 | (rplacd last (cdr rest)) | |
| 441 | ;; new | |
| 442 | (return y)) | |
| 443 | (setq last rest rest (cdr rest)))) | |
| 444 | )) | |
| 445 | ))) | |
| 396 | 'none | |
| 397 | (if (term-is-applform? x) | |
| 398 | ;; application form | |
| 399 | (let ((head (term-head x)) | |
| 400 | (pos nil)) | |
| 401 | (setq pos (position-if #'(lambda (tv) | |
| 402 | (let ((term (car tv))) | |
| 403 | (and (term-is-applform? term) | |
| 404 | (method-is-of-same-operator head | |
| 405 | (term-head term))))) | |
| 406 | (the list y))) | |
| 407 | ;; (break "0") | |
| 408 | (unless pos | |
| 409 | (return-from exit :never-match)) | |
| 410 | (if (zerop pos) | |
| 411 | (if (term-equational-equal x (caar y)) | |
| 412 | (return-from exit (cdr y)) | |
| 413 | (return-from exit 'none)) | |
| 414 | (let ((last y) | |
| 415 | (rest (cdr y)) | |
| 416 | (cur-pos 1)) | |
| 417 | (declare (type fixnum cur-pos)) | |
| 418 | (loop | |
| 419 | (when (= cur-pos pos) | |
| 420 | (if (term-equational-equal x (caar rest)) | |
| 421 | (progn | |
| 422 | ;; delete pattern | |
| 423 | (rplacd last (cdr rest)) | |
| 424 | (return-from exit y)) | |
| 425 | (return-from exit 'none))) | |
| 426 | (incf cur-pos) | |
| 427 | (setq last rest rest (cdr rest)))))) | |
| 428 | ;; term is not application form | |
| 429 | (if (term-equational-equal x (caar y)) | |
| 430 | (cdr y) | |
| 431 | (let ((last y) (rest (cdr y))) | |
| 432 | (loop (when (null rest) (return 'none)) | |
| 433 | (when (term-equational-equal x (caar rest)) | |
| 434 | ;; delete pattern | |
| 435 | (rplacd last (cdr rest)) | |
| 436 | ;; new | |
| 437 | (return y)) | |
| 438 | (setq last rest rest (cdr rest))))))) | |
| 439 | )) | |
| 446 | 440 | ||# |
| 447 | 441 | |
| 448 | ;; #|| | |
| 449 | 442 | (defun delete-one-term |
| 450 | 443 | (x y) |
| 451 | 444 | (if (null y) |
| 452 | 445 | 'none |
| 453 | 446 | (if (term-equational-equal x (caar y)) |
| 454 | (cdr y) | |
| 455 | (let ((last y) (rest (cdr y))) | |
| 456 | (loop (when (null rest) (return 'none)) | |
| 457 | (when (term-equational-equal x (caar rest)) | |
| 458 | ;; delete pattern | |
| 459 | (rplacd last (cdr rest)) | |
| 460 | ;; new | |
| 461 | (return y)) | |
| 462 | (setq last rest rest (cdr rest)))) | |
| 463 | )) | |
| 447 | (cdr y) | |
| 448 | (let ((last y) (rest (cdr y))) | |
| 449 | (loop (when (null rest) (return 'none)) | |
| 450 | (when (term-equational-equal x (caar rest)) | |
| 451 | ;; delete pattern | |
| 452 | (rplacd last (cdr rest)) | |
| 453 | ;; new | |
| 454 | (return y)) | |
| 455 | (setq last rest rest (cdr rest)))) | |
| 456 | )) | |
| 464 | 457 | ) |
| 465 | ;; ||# | |
| 466 | 458 | |
| 467 | 459 | (defvar *ac-failure-eq* nil) |
| 468 | 460 | |
| 471 | 463 | which, if true, imply the original AC equation true) from |
| 472 | 464 | the matrix of 'state'" |
| 473 | 465 | (let* ((ops (AC-state-operators state)) |
| 474 | (lhs-f (AC-state-lhs-f state)) | |
| 475 | (lhs-v (AC-state-lhs-v state)) | |
| 476 | (rhs-c (AC-state-rhs-c state)) | |
| 477 | (rhs-f (AC-state-rhs-f state)) | |
| 478 | (rhs-c-sol (AC-state-rhs-c-sol state)) | |
| 479 | (rhs-f-sol (AC-state-rhs-f-sol state)) | |
| 480 | (new-sys (new-m-system)) | |
| 481 | (term-code 1) | |
| 482 | (rhs-subterms nil) | |
| 483 | (new-eqns nil)) | |
| 466 | (lhs-f (AC-state-lhs-f state)) | |
| 467 | (lhs-v (AC-state-lhs-v state)) | |
| 468 | (rhs-c (AC-state-rhs-c state)) | |
| 469 | (rhs-f (AC-state-rhs-f state)) | |
| 470 | (rhs-c-sol (AC-state-rhs-c-sol state)) | |
| 471 | (rhs-f-sol (AC-state-rhs-f-sol state)) | |
| 472 | (new-sys (new-m-system)) | |
| 473 | (term-code 1) | |
| 474 | (rhs-subterms nil) | |
| 475 | (new-eqns nil)) | |
| 484 | 476 | (declare (type fixnum term-code) |
| 485 | (type #+GCL vector | |
| 486 | #-GCL simple-vector | |
| 487 | ops | |
| 488 | lhs-f lhs-v rhs-c rhs-f rhs-c-sol rhs-f-sol) | |
| 489 | (type list new-sys rhs-subterms new-eqns)) | |
| 477 | (type #+GCL vector | |
| 478 | #-GCL simple-vector | |
| 479 | ops | |
| 480 | lhs-f lhs-v rhs-c rhs-f rhs-c-sol rhs-f-sol) | |
| 481 | (type list new-sys rhs-subterms new-eqns)) | |
| 490 | 482 | (setq *ac-failure-eq* nil) |
| 491 | 483 | ;; (AC-collapse-arrays-internal lhs-v 1) |
| 492 | 484 | (dotimes (i (length lhs-v)) |
| 493 | 485 | (declare (type fixnum i)) |
| 494 | 486 | (if (< i 1) |
| 495 | nil | |
| 496 | (progn | |
| 497 | (setq rhs-subterms nil) | |
| 498 | (setq term-code (* 2 term-code)) | |
| 499 | ;; (AC-collapse-one-array-internal rhs-c-sol rhs-c) | |
| 500 | (dotimes (j (length rhs-c-sol)) | |
| 501 | (declare (type fixnum j)) | |
| 487 | nil | |
| 488 | (progn | |
| 489 | (setq rhs-subterms nil) | |
| 490 | (setq term-code (* 2 term-code)) | |
| 491 | ;; (AC-collapse-one-array-internal rhs-c-sol rhs-c) | |
| 492 | (dotimes (j (length rhs-c-sol)) | |
| 493 | (declare (type fixnum j)) | |
| 502 | 494 | (when (> (the fixnum (make-and (svref rhs-c-sol j) |
| 503 | term-code)) | |
| 504 | 0) | |
| 505 | (push (car (svref rhs-c j)) rhs-subterms))) | |
| 506 | ;; (AC-collapse-one-array-internal rhs-f-sol rhs-f) | |
| 507 | (dotimes (j (length rhs-f-sol)) | |
| 508 | (declare (type fixnum j)) | |
| 495 | term-code)) | |
| 496 | 0) | |
| 497 | (push (car (svref rhs-c j)) rhs-subterms))) | |
| 498 | ;; (AC-collapse-one-array-internal rhs-f-sol rhs-f) | |
| 499 | (dotimes (j (length rhs-f-sol)) | |
| 500 | (declare (type fixnum j)) | |
| 509 | 501 | (when (> (the fixnum (make-and (svref rhs-f-sol j) term-code)) |
| 510 | 0) | |
| 511 | (push (car (svref rhs-f j)) rhs-subterms))) | |
| 512 | (when rhs-subterms | |
| 513 | (push | |
| 514 | (make-equation (car (svref lhs-v i)) | |
| 515 | (if (cdr rhs-subterms) | |
| 516 | (make-right-assoc-normal-form-with-sort-check | |
| 517 | (svref ops (cdr (svref lhs-v i))) | |
| 518 | rhs-subterms) | |
| 519 | (first rhs-subterms))) | |
| 520 | new-eqns))))) | |
| 502 | 0) | |
| 503 | (push (car (svref rhs-f j)) rhs-subterms))) | |
| 504 | (when rhs-subterms | |
| 505 | (push | |
| 506 | (make-equation (car (svref lhs-v i)) | |
| 507 | (if (cdr rhs-subterms) | |
| 508 | (make-right-assoc-normal-form-with-sort-check | |
| 509 | (svref ops (cdr (svref lhs-v i))) | |
| 510 | rhs-subterms) | |
| 511 | (first rhs-subterms))) | |
| 512 | new-eqns))))) | |
| 521 | 513 | ;; |
| 522 | 514 | ;; note term-code is now the right thing. |
| 523 | 515 | ;; (AC-collapse-arrays-internal lhs-f 0) |
| 527 | 519 | (setq term-code (* 2 term-code)) |
| 528 | 520 | ;; (AC-collapse-one-array-internal rhs-c-sol rhs-c) |
| 529 | 521 | (dotimes (j (length rhs-c-sol)) |
| 530 | (declare (type fixnum j)) | |
| 531 | (when (> (the fixnum (make-and (svref rhs-c-sol j) term-code)) | |
| 532 | 0) | |
| 533 | (push (car (svref rhs-c j)) rhs-subterms))) | |
| 522 | (declare (type fixnum j)) | |
| 523 | (when (> (the fixnum (make-and (svref rhs-c-sol j) term-code)) | |
| 524 | 0) | |
| 525 | (push (car (svref rhs-c j)) rhs-subterms))) | |
| 534 | 526 | ;; (AC-collapse-one-array-internal rhs-f-sol rhs-f) |
| 535 | 527 | (dotimes (j (length rhs-f-sol)) |
| 536 | (declare (type fixnum j)) | |
| 537 | (when (> (the fixnum (make-and (svref rhs-f-sol j) term-code)) | |
| 538 | 0) | |
| 539 | (push (car (svref rhs-f j)) rhs-subterms))) | |
| 528 | (declare (type fixnum j)) | |
| 529 | (when (> (the fixnum (make-and (svref rhs-f-sol j) term-code)) | |
| 530 | 0) | |
| 531 | (push (car (svref rhs-f j)) rhs-subterms))) | |
| 540 | 532 | (when rhs-subterms |
| 541 | (let ((t1 (car (svref lhs-f i))) | |
| 542 | (t2 (if (cdr rhs-subterms) | |
| 543 | (make-right-assoc-normal-form-with-sort-check | |
| 544 | (svref ops (cdr (svref lhs-f i))) | |
| 545 | rhs-subterms) | |
| 546 | (first rhs-subterms)))) | |
| 547 | (let ((t1-head (term-head t1)) | |
| 548 | (t2-head (term-head t2))) | |
| 549 | (if (method-is-of-same-operator+ t1-head t2-head) | |
| 550 | (push (make-equation t1 t2) new-eqns) | |
| 551 | (let ((minfo-1 (method-theory-info-for-matching | |
| 552 | t1-head)) | |
| 553 | (minfo-2 (method-theory-info-for-matching | |
| 554 | t2-head))) | |
| 555 | (if (or (test-theory | |
| 556 | .z. (theory-info-code minfo-1)) | |
| 557 | (test-theory | |
| 558 | .z. (theory-info-code minfo-2))) | |
| 559 | (push (make-equation t1 t2) new-eqns) | |
| 560 | (progn | |
| 561 | (when *match-debug* | |
| 562 | (setq *ac-failure-eq* (cons t1 t2))) | |
| 563 | (setq new-eqns nil) | |
| 564 | (return nil)) ))))))) | |
| 533 | (let ((t1 (car (svref lhs-f i))) | |
| 534 | (t2 (if (cdr rhs-subterms) | |
| 535 | (make-right-assoc-normal-form-with-sort-check | |
| 536 | (svref ops (cdr (svref lhs-f i))) | |
| 537 | rhs-subterms) | |
| 538 | (first rhs-subterms)))) | |
| 539 | (let ((t1-head (term-head t1)) | |
| 540 | (t2-head (term-head t2))) | |
| 541 | (if (method-is-of-same-operator+ t1-head t2-head) | |
| 542 | (push (make-equation t1 t2) new-eqns) | |
| 543 | (let ((minfo-1 (method-theory-info-for-matching | |
| 544 | t1-head)) | |
| 545 | (minfo-2 (method-theory-info-for-matching | |
| 546 | t2-head))) | |
| 547 | (if (or (test-theory | |
| 548 | .z. (theory-info-code minfo-1)) | |
| 549 | (test-theory | |
| 550 | .z. (theory-info-code minfo-2))) | |
| 551 | (push (make-equation t1 t2) new-eqns) | |
| 552 | (progn | |
| 553 | (with-match-debug () | |
| 554 | (setq *ac-failure-eq* (cons t1 t2))) | |
| 555 | (setq new-eqns nil) | |
| 556 | (return nil)) ))))))) | |
| 565 | 557 | ;; |
| 566 | 558 | (if new-eqns |
| 567 | (progn | |
| 568 | (dolist (eq (nreverse new-eqns)) | |
| 569 | (add-equation-to-m-system new-sys eq)) | |
| 570 | (when *match-debug* | |
| 571 | (format t "~%** ac-solution-from-state") | |
| 572 | (print-m-system new-sys)) | |
| 573 | new-sys) | |
| 574 | (progn | |
| 575 | (when *match-debug* | |
| 576 | (format t "~%** no ac solution") | |
| 577 | (print-next) | |
| 578 | (princ " - t1 = ") (term-print (car *ac-failure-eq*)) | |
| 579 | (print-next) | |
| 580 | (princ " - t2 = ") (term-print (cdr *ac-failure-eq*)) | |
| 581 | ) | |
| 582 | nil)))) | |
| 559 | (progn | |
| 560 | (dolist (eq (nreverse new-eqns)) | |
| 561 | (add-equation-to-m-system new-sys eq)) | |
| 562 | (with-match-debug () | |
| 563 | (format t "~%** ac-solution-from-state") | |
| 564 | (print-m-system new-sys)) | |
| 565 | new-sys) | |
| 566 | (progn | |
| 567 | (with-match-debug () | |
| 568 | (format t "~%** no ac solution") | |
| 569 | (print-next) | |
| 570 | (princ " - t1 = ") (term-print (car *ac-failure-eq*)) | |
| 571 | (print-next) | |
| 572 | (princ " - t2 = ") (term-print (cdr *ac-failure-eq*))) | |
| 573 | nil)))) | |
| 583 | 574 | |
| 584 | 575 | (#+GCL si:define-inline-function #-GCL defun test_same_term_list (x y) |
| 585 | 576 | (declare (type list x y)) |
| 586 | 577 | (loop (when (null x) (return (null y))) |
| 587 | 578 | (unless (eq (car x) (car y)) |
| 588 | (return nil)) | |
| 579 | (return nil)) | |
| 589 | 580 | (setq x (cdr x)) |
| 590 | 581 | (setq y (cdr y)))) |
| 591 | 582 | |
| 606 | 597 | (dolist (x list) |
| 607 | 598 | ;; (declare (type term x)) |
| 608 | 599 | (let ((ms-x (dolist (pr ms-list nil) |
| 609 | (when (term-equational-equal x (car pr)) | |
| 610 | (return pr))))) | |
| 611 | (if ms-x | |
| 600 | (when (term-equational-equal x (car pr)) | |
| 601 | (return pr))))) | |
| 602 | (if ms-x | |
| 612 | 603 | (incf (the fixnum (cdr ms-x))) ; (setf (cdr ms-x) (1+ (the fixnum (cdr ms-x)))) |
| 613 | (push (cons x 1) ms-list)))) | |
| 604 | (push (cons x 1) ms-list)))) | |
| 614 | 605 | ms-list)) |
| 615 | 606 | |
| 616 | 607 | ;;; Assume that t1 is NOT a variable |
| 623 | 614 | (if (and l2msla1 (test_same_term_list list l2msla1)) |
| 624 | 615 | (copy-alist l2mslv1) |
| 625 | 616 | (if (and l2msla2 (test_same_term_list list l2msla2)) |
| 626 | (progn | |
| 627 | (rotatef l2msla1 l2msla2) | |
| 628 | (rotatef l2mslv1 l2mslv2) | |
| 629 | (copy-alist l2mslv1)) | |
| 617 | (progn | |
| 618 | (rotatef l2msla1 l2msla2) | |
| 619 | (rotatef l2mslv1 l2mslv2) | |
| 620 | (copy-alist l2mslv1)) | |
| 630 | 621 | (let ((res (list2multi-set-list-direct list))) |
| 631 | (setq l2msla2 l2msla1 l2mslv2 l2mslv1) | |
| 632 | (setq l2msla1 list l2mslv1 res) | |
| 633 | (copy-alist res))))) | |
| 622 | (setq l2msla2 l2msla1 l2mslv2 l2mslv1) | |
| 623 | (setq l2msla1 list l2mslv1 res) | |
| 624 | (copy-alist res))))) | |
| 634 | 625 | |
| 635 | 626 | ;;; NOTE this is a version for AC-internal use only. |
| 636 | 627 | ;;; it simply takes care of the "from which equation" info. |
| 643 | 634 | (declare (type list list)) |
| 644 | 635 | (let ((ms-list nil)) |
| 645 | 636 | (declare (type list ms-list)) |
| 646 | #|| | |
| 647 | (when *match-debug* | |
| 648 | (mapc #'(lambda (x) (format t "~&,,,~s" x)) list)) | |
| 649 | ||# | |
| 650 | 637 | (dolist (x list) ;;(copy-tree list) |
| 651 | 638 | (declare (type list x)) |
| 652 | 639 | (let ((ms-elt (assoc-if #'(lambda (y) |
| 653 | (declare (type list y)) | |
| 654 | #|| | |
| 655 | (when *match-debug* | |
| 656 | (format t "~&..x|~d| " (cdr x)) | |
| 657 | (term-print (car x)) | |
| 658 | (format t "~&..y|~d| " (cdr y)) | |
| 659 | (term-print (car y)) | |
| 660 | (trace term-equational-equal)) | |
| 661 | ||# | |
| 662 | (and (= (the fixnum (cdr x)) | |
| 663 | (the fixnum (cdr y))) | |
| 664 | (term-equational-equal (car y) (car x)))) | |
| 665 | ms-list))) | |
| 666 | (if ms-elt | |
| 667 | (progn | |
| 668 | #|| | |
| 669 | (when *match-debug* | |
| 670 | (format t "~&..inc: ~s" ms-elt)) | |
| 671 | ||# | |
| 672 | (incf (the fixnum (cdr ms-elt)))) | |
| 673 | (progn | |
| 674 | #|| | |
| 675 | (when *match-debug* | |
| 676 | (format t "~&..add: ~s" x)) | |
| 677 | ||# | |
| 678 | (push (cons x 1) ms-list))))) | |
| 679 | #|| | |
| 680 | (when *match-debug* | |
| 681 | (untrace term-equational-equal)) | |
| 682 | ||# | |
| 640 | (declare (type list y)) | |
| 641 | (and (= (the fixnum (cdr x)) | |
| 642 | (the fixnum (cdr y))) | |
| 643 | (term-equational-equal (car y) (car x)))) | |
| 644 | ms-list))) | |
| 645 | (if ms-elt | |
| 646 | (progn | |
| 647 | (incf (the fixnum (cdr ms-elt)))) | |
| 648 | (progn | |
| 649 | (push (cons x 1) ms-list))))) | |
| 683 | 650 | ms-list)) |
| 684 | 651 | |
| 685 | 652 | ;;; check for multi-set equality |
| 687 | 654 | (defun match-AC-ms-equal (x y) |
| 688 | 655 | (declare (type list x y)) |
| 689 | 656 | (let ((lenx (length x)) |
| 690 | (leny (length y))) | |
| 657 | (leny (length y))) | |
| 691 | 658 | ;; |
| 692 | 659 | (declare (type fixnum lenx leny)) |
| 693 | 660 | (unless (= lenx leny) |
| 695 | 662 | ;; |
| 696 | 663 | (block the-end |
| 697 | 664 | (let ((ydone 0)) |
| 698 | (declare (type fixnum ydone)) | |
| 699 | (dolist (xe x) | |
| 700 | (declare (type list xe)) | |
| 701 | (let ((xterm (car xe)) (xval (cdr xe))) | |
| 702 | (declare (type term xterm) | |
| 703 | (type fixnum xval)) | |
| 704 | (dolist (ye y (return-from the-end nil)) ; didn't find xe in y | |
| 705 | (declare (type list ye)) | |
| 706 | (when (term-equational-equal xterm (car ye)) | |
| 707 | (unless (= xval (the fixnum (cdr ye))) | |
| 708 | (return-from the-end nil)) | |
| 709 | (setq ydone (1+ ydone)) | |
| 710 | (return))))) ; quit the inner do-list | |
| 711 | (unless (= ydone leny) | |
| 712 | (return-from the-end nil))) | |
| 665 | (declare (type fixnum ydone)) | |
| 666 | (dolist (xe x) | |
| 667 | (declare (type list xe)) | |
| 668 | (let ((xterm (car xe)) (xval (cdr xe))) | |
| 669 | (declare (type term xterm) | |
| 670 | (type fixnum xval)) | |
| 671 | (dolist (ye y (return-from the-end nil)) ; didn't find xe in y | |
| 672 | (declare (type list ye)) | |
| 673 | (when (term-equational-equal xterm (car ye)) | |
| 674 | (unless (= xval (the fixnum (cdr ye))) | |
| 675 | (return-from the-end nil)) | |
| 676 | (setq ydone (1+ ydone)) | |
| 677 | (return))))) ; quit the inner do-list | |
| 678 | (unless (= ydone leny) | |
| 679 | (return-from the-end nil))) | |
| 713 | 680 | t))) |
| 714 | 681 | |
| 715 | 682 | (defun AC-next-state-sub (state) |
| 716 | (do* ((m 0) ; only initialize these vars | |
| 717 | (rhs-c-sol (AC-state-rhs-c-sol state)) | |
| 718 | (rhs-c-max (AC-state-rhs-c-max state)) | |
| 719 | (rhs-c-count (AC-state-rhs-c-count state)) | |
| 720 | (rhs-c-compat (AC-state-rhs-c-compat state)) | |
| 721 | (lhs-r-mask (AC-state-lhs-r-mask state))) | |
| 722 | (nil) ; forever | |
| 683 | (do* ((m 0) ; only initialize these vars | |
| 684 | (rhs-c-sol (AC-state-rhs-c-sol state)) | |
| 685 | (rhs-c-max (AC-state-rhs-c-max state)) | |
| 686 | (rhs-c-count (AC-state-rhs-c-count state)) | |
| 687 | (rhs-c-compat (AC-state-rhs-c-compat state)) | |
| 688 | (lhs-r-mask (AC-state-lhs-r-mask state))) | |
| 689 | (nil) ; forever | |
| 723 | 690 | (declare (type #+GCL vector #-GCL simple-vector rhs-c-compat) |
| 724 | (type fixnum m lhs-r-mask rhs-c-count rhs-c-max)) | |
| 725 | (cond ((>= m rhs-c-count) ; no next row | |
| 726 | (setf (AC-state-no-more state) T) | |
| 727 | (return)) | |
| 728 | ((< m 0) ; no tests up here - could cut search here | |
| 729 | (let ((temp 0)) ; the empty bitvector | |
| 730 | (declare (type fixnum temp)) | |
| 731 | (dotimes (s rhs-c-count) | |
| 732 | (declare (type fixnum s)) | |
| 733 | (setq temp (make-or temp (svref rhs-c-sol s)))) | |
| 734 | (setf (AC-state-LHS-mask state) temp) | |
| 735 | (return))) | |
| 736 | ((< (the fixnum (svref rhs-c-sol m)) rhs-c-max) | |
| 737 | (AC-Rotate-Left rhs-c-sol m) | |
| 738 | (when (and ; this is a compatible position for this bit | |
| 739 | (> (the fixnum (make-and (svref rhs-c-sol m) | |
| 740 | (svref rhs-c-compat m))) | |
| 741 | 0) | |
| 742 | ;; either this isnt a repeated term | |
| 743 | (or (zerop (the fixnum | |
| 744 | (make-and (svref rhs-c-sol m) lhs-r-mask))) | |
| 745 | ;; or it is, and its upper neighbor is home | |
| 746 | (and (< (1+ m) rhs-c-count) | |
| 747 | (= (* 2 (the fixnum (svref rhs-c-sol m))) | |
| 748 | (the fixnum (svref rhs-c-sol (1+ m))))))) | |
| 749 | (setq m (1- m)))) ; then this row is ok, else redo this row | |
| 750 | (t ; this row (m) is already maxed | |
| 751 | (setf (svref rhs-c-sol m) 1) ; reset this row | |
| 752 | (setq m (1+ m)))))) | |
| 691 | (type fixnum m lhs-r-mask rhs-c-count rhs-c-max)) | |
| 692 | (cond ((>= m rhs-c-count) ; no next row | |
| 693 | (setf (AC-state-no-more state) T) | |
| 694 | (return)) | |
| 695 | ((< m 0) ; no tests up here - could cut search here | |
| 696 | (let ((temp 0)) ; the empty bitvector | |
| 697 | (declare (type fixnum temp)) | |
| 698 | (dotimes (s rhs-c-count) | |
| 699 | (declare (type fixnum s)) | |
| 700 | (setq temp (make-or temp (svref rhs-c-sol s)))) | |
| 701 | (setf (AC-state-LHS-mask state) temp) | |
| 702 | (return))) | |
| 703 | ((< (the fixnum (svref rhs-c-sol m)) rhs-c-max) | |
| 704 | (AC-Rotate-Left rhs-c-sol m) | |
| 705 | (when (and ; this is a compatible position for this bit | |
| 706 | (> (the fixnum (make-and (svref rhs-c-sol m) | |
| 707 | (svref rhs-c-compat m))) | |
| 708 | 0) | |
| 709 | ;; either this isnt a repeated term | |
| 710 | (or (zerop (the fixnum | |
| 711 | (make-and (svref rhs-c-sol m) lhs-r-mask))) | |
| 712 | ;; or it is, and its upper neighbor is home | |
| 713 | (and (< (1+ m) rhs-c-count) | |
| 714 | (= (* 2 (the fixnum (svref rhs-c-sol m))) | |
| 715 | (the fixnum (svref rhs-c-sol (1+ m))))))) | |
| 716 | (setq m (1- m)))) ; then this row is ok, else redo this row | |
| 717 | (t ; this row (m) is already maxed | |
| 718 | (setf (svref rhs-c-sol m) 1) ; reset this row | |
| 719 | (setq m (1+ m)))))) | |
| 753 | 720 | |
| 754 | 721 | #|| |
| 755 | 722 | (match-AC-ms-equal |
| 761 | 728 | (defun match-AC-equal (t1 t2) |
| 762 | 729 | (if (term-is-applform? t2) |
| 763 | 730 | (let ((op (term-head t1)) |
| 764 | (op2 (term-head t2))) | |
| 765 | (declare (type method op)) | |
| 766 | (if (method-is-of-same-operator op op2) | |
| 767 | (let ((sub1 (list-AC-subterms t1 op)) | |
| 768 | (sub2 (list-AC-subterms t2 op2))) | |
| 769 | (declare (type list sub1 sub2)) | |
| 770 | (if (= (the fixnum (length sub1)) | |
| 771 | (the fixnum (length sub2))) | |
| 772 | (dolist (s sub1 t) | |
| 773 | (unless (member s sub2 :test #'term-equational-equal) | |
| 774 | (return nil))) | |
| 775 | nil)) | |
| 776 | nil)) | |
| 731 | (op2 (term-head t2))) | |
| 732 | (declare (type method op)) | |
| 733 | (if (method-is-of-same-operator op op2) | |
| 734 | (let ((sub1 (list-AC-subterms t1 op)) | |
| 735 | (sub2 (list-AC-subterms t2 op2))) | |
| 736 | (declare (type list sub1 sub2)) | |
| 737 | (if (= (the fixnum (length sub1)) | |
| 738 | (the fixnum (length sub2))) | |
| 739 | (dolist (s sub1 t) | |
| 740 | (unless (member s sub2 :test #'term-equational-equal) | |
| 741 | (return nil))) | |
| 742 | nil)) | |
| 743 | nil)) | |
| 777 | 744 | nil)) |
| 778 | 745 | ||# |
| 779 | 746 | |
| 780 | 747 | (defun match-AC-equal (t1 t2) |
| 781 | 748 | (if (term-is-applform? t2) |
| 782 | 749 | (let ((op (term-head t1)) |
| 783 | (op2 (term-head t2))) | |
| 784 | (declare (type method op)) | |
| 785 | (if (method-is-of-same-operator op op2) | |
| 786 | (let ((sub1 (list-AC-subterms t1 op)) | |
| 787 | (sub2 (list-AC-subterms t2 op2))) | |
| 788 | (declare (type list sub1 sub2)) | |
| 789 | (match-ac-ms-equal (list2multi-set-list sub1) | |
| 790 | (list2multi-set-list sub2))) | |
| 791 | nil)) | |
| 750 | (op2 (term-head t2))) | |
| 751 | (declare (type method op)) | |
| 752 | (if (method-is-of-same-operator op op2) | |
| 753 | (let ((sub1 (list-AC-subterms t1 op)) | |
| 754 | (sub2 (list-AC-subterms t2 op2))) | |
| 755 | (declare (type list sub1 sub2)) | |
| 756 | (match-ac-ms-equal (list2multi-set-list sub1) | |
| 757 | (list2multi-set-list sub2))) | |
| 758 | nil)) | |
| 792 | 759 | nil)) |
| 793 | 760 | |
| 794 | 761 | ;;; *********************** |
| 796 | 763 | ;;; (defvar .ac-state-pool. nil) |
| 797 | 764 | ;;;(defmacro allocate-ac-state () |
| 798 | 765 | ;;; ` (if .ac-state-pool. (pop .ac-state-pool.) |
| 799 | ;;; (make-AC-state))) | |
| 766 | ;;; (make-AC-state))) | |
| 800 | 767 | ;;;(defmacro deallocate-ac-state (ac-state) |
| 801 | 768 | ;;; `(push ,ac-state .ac-state-pool.)) |
| 802 | 769 | ;;;(eval-when (eval load) |
| 807 | 774 | returns an AC-state, which is suitable for framing |
| 808 | 775 | or passing to 'AC-next-state'" |
| 809 | 776 | (declare (type list sys env)) |
| 810 | (when *match-debug* | |
| 811 | (format t "~&** match-ac-state-initialize -------------------------------------") | |
| 777 | (with-match-debug () | |
| 778 | (format t "~%** match-ac-state-initialize -------------------------------------") | |
| 812 | 779 | (print-next) |
| 813 | 780 | (print-match-system-sys sys) |
| 814 | 781 | (print-next) |
| 816 | 783 | ;; |
| 817 | 784 | (block fail |
| 818 | 785 | (let ((eqn-number -1) |
| 819 | (sys-operators nil) | |
| 820 | (all-lhs-vars nil) | |
| 821 | (all-lhs-funs nil) | |
| 822 | (all-rhs-constants nil) | |
| 823 | (all-rhs-funs nil) | |
| 824 | (*print-circle* nil)) | |
| 786 | (sys-operators nil) | |
| 787 | (all-lhs-vars nil) | |
| 788 | (all-lhs-funs nil) | |
| 789 | (all-rhs-constants nil) | |
| 790 | (all-rhs-funs nil) | |
| 791 | (*print-circle* nil)) | |
| 825 | 792 | (declare (type (or null #-GCL simple-vector |
| 826 | #+GCL vector) | |
| 827 | sys-operators) | |
| 828 | (type list | |
| 829 | all-lhs-vars all-lhs-funs all-rhs-constants all-rhs-funs) | |
| 830 | (type fixnum eqn-number)) | |
| 793 | #+GCL vector) | |
| 794 | sys-operators) | |
| 795 | (type list | |
| 796 | all-lhs-vars all-lhs-funs all-rhs-constants all-rhs-funs) | |
| 797 | (type fixnum eqn-number)) | |
| 831 | 798 | ;; |
| 832 | 799 | (dolist (equation sys) |
| 833 | (incf eqn-number) | |
| 834 | (let* ((lhs-1 (equation-t1 equation)) | |
| 835 | (rhs-1 (equation-t2 equation)) | |
| 836 | (lhs-op (term-head lhs-1)) | |
| 837 | (rhs-op (term-head rhs-1))) | |
| 838 | (declare (type term lhs-1 rhs-1) | |
| 839 | ;; (type method lhs-op rhs-op) | |
| 840 | ) | |
| 841 | ;; quick failure cases. | |
| 842 | (unless (and (theory-contains-AC (method-theory lhs-op)) | |
| 843 | (not (term-is-builtin-constant? rhs-1)) | |
| 844 | (method-p rhs-op) | |
| 845 | (method-is-ac-restriction-of rhs-op lhs-op)) | |
| 846 | ;; is the first condition really need? | |
| 847 | ;; (format t "~&failure case #1") | |
| 848 | (return-from FAIL (values nil t))) | |
| 849 | ;; | |
| 850 | (let ((lhs-subs (list-AC-subterms lhs-1 lhs-op)) | |
| 851 | (rhs-subs (list-AC-subterms rhs-1 rhs-op)) | |
| 852 | (lhs-vars nil) | |
| 853 | (lhs-constants nil) | |
| 854 | (lhs-funs nil) | |
| 855 | (rhs-constants nil) | |
| 856 | (rhs-funs nil)) | |
| 857 | (declare (type list lhs-subs rhs-subs lhs-vars lhs-constants | |
| 858 | lhs-funs rhs-constants rhs-funs)) | |
| 859 | ;; quick failure cases | |
| 860 | ;; #|| | |
| 861 | (when (> (the fixnum (length lhs-subs)) | |
| 862 | (the fixnum (length rhs-subs))) | |
| 863 | ;; (format t "~&failure case #2") | |
| 864 | (return-from FAIL (values nil t))) ; no possible match | |
| 865 | ;; ||# | |
| 866 | ;; | |
| 867 | (unless sys-operators | |
| 868 | (setq sys-operators (alloc-svec (the fixnum (length sys))))) | |
| 869 | (setf (svref sys-operators eqn-number) lhs-op) | |
| 870 | ;; build lhs- vars/funs/constants | |
| 871 | (dolist (term lhs-subs) | |
| 872 | (cond ((term-is-variable? term) | |
| 873 | (let ((image (if env (environment-image env term) term))) | |
| 874 | (cond ((null image) | |
| 875 | (push (cons term eqn-number) lhs-vars)) | |
| 876 | ((term-is-variable? image) | |
| 877 | (push (cons image eqn-number) lhs-vars)) | |
| 878 | ((term-is-constant? image) | |
| 879 | (push (cons image eqn-number) lhs-constants)) | |
| 880 | ((method-is-AC-restriction-of lhs-op | |
| 881 | (term-head image)) | |
| 882 | (dolist (term2 (list-AC-subterms image | |
| 883 | (term-head image))) | |
| 884 | (cond ((term-is-variable? term2) | |
| 885 | (push (cons term2 eqn-number) | |
| 886 | lhs-vars)) | |
| 887 | ((term-is-constant? term2) | |
| 888 | (push (cons term2 eqn-number) | |
| 889 | lhs-constants)) | |
| 890 | (t (push (cons term2 eqn-number) | |
| 891 | lhs-funs))))) | |
| 892 | (t (push (cons image eqn-number) lhs-funs))))) | |
| 893 | ((term-is-constant? term) | |
| 894 | (push (cons term eqn-number) lhs-constants)) | |
| 895 | (t (push (cons term eqn-number) lhs-funs)))) | |
| 896 | ;; now that the lhs is partitioned - lets play with the rhs | |
| 897 | (dolist (term rhs-subs) | |
| 898 | (cond ((term-is-variable? term) | |
| 899 | (push (cons term eqn-number) rhs-constants)) | |
| 900 | ((term-is-constant? term) | |
| 901 | (let ((new (delete-one-term term lhs-constants))) | |
| 902 | (if (eq 'none new) | |
| 903 | (push (cons term eqn-number) rhs-constants) | |
| 904 | (if (eq :never-match new) | |
| 905 | (if lhs-vars | |
| 906 | (push (cons term eqn-number) | |
| 907 | rhs-constants) | |
| 908 | (progn | |
| 909 | (when *match-debug* | |
| 910 | (format t "~&- :never-match : lhs-vars ") | |
| 911 | (print-chaos-object lhs-vars)) | |
| 912 | ;; (format t "~&failure case #3") | |
| 913 | (return-from FAIL (values nil t)))) | |
| 914 | (setq lhs-constants new))))) | |
| 915 | (t (let ((new (delete-one-term term lhs-funs))) | |
| 916 | (if (eq 'none new) | |
| 917 | (push (cons term eqn-number) rhs-funs) | |
| 918 | (if (eq :never-match new) | |
| 919 | (if lhs-vars | |
| 920 | (push (cons term eqn-number) | |
| 921 | rhs-funs) | |
| 922 | (progn | |
| 923 | (when *match-debug* | |
| 924 | (format t "~&- :never-match : lhs-vars ") | |
| 925 | (print-chaos-object lhs-vars)) | |
| 926 | ;; (format t "~&failure case #4") | |
| 927 | (return-from FAIL (values nil t)))) | |
| 928 | (setq lhs-funs new))))))) | |
| 929 | ;; now there are no duplicates (things appearing on both sides) | |
| 930 | (let ((lhs-c-count (length lhs-constants)) | |
| 931 | (lhs-f-count (length lhs-funs)) | |
| 932 | (lhs-v-count (length lhs-vars)) | |
| 933 | (rhs-c-count (length rhs-constants)) | |
| 934 | (rhs-f-count (length rhs-funs))) | |
| 935 | (declare (type fixnum lhs-c-count lhs-f-count lhs-v-count | |
| 936 | rhs-c-count rhs-f-count)) | |
| 937 | ;; check trivial failure conditions | |
| 938 | (when (or (> lhs-c-count 0) ; there ain't nothin to match it | |
| 939 | (and (< lhs-v-count 1) ; no variables remain on lhs | |
| 940 | (> rhs-c-count 0)) ; and constants remain on rhs | |
| 941 | (> lhs-f-count rhs-f-count)) ; too many funs to match | |
| 942 | ;; (break "1") | |
| 943 | ;; (format t "~&failure case #5") | |
| 944 | (return-from FAIL (values nil t))) ; FAIL most miserably | |
| 945 | ;; | |
| 946 | (setq all-lhs-funs (nconc lhs-funs all-lhs-funs)) | |
| 947 | (setq all-lhs-vars (nconc lhs-vars all-lhs-vars)) | |
| 948 | (setq all-rhs-constants (nconc rhs-constants all-rhs-constants)) | |
| 949 | (setq all-rhs-funs (nconc rhs-funs all-rhs-funs)))))) | |
| 800 | (incf eqn-number) | |
| 801 | (let* ((lhs-1 (equation-t1 equation)) | |
| 802 | (rhs-1 (equation-t2 equation)) | |
| 803 | (lhs-op (term-head lhs-1)) | |
| 804 | (rhs-op (term-head rhs-1))) | |
| 805 | (declare (type term lhs-1 rhs-1)) | |
| 806 | ;; quick failure cases. | |
| 807 | (unless (and (theory-contains-AC (method-theory lhs-op)) | |
| 808 | (not (term-is-builtin-constant? rhs-1)) | |
| 809 | (method-p rhs-op) | |
| 810 | (method-is-ac-restriction-of rhs-op lhs-op)) | |
| 811 | ;; is the first condition really need? | |
| 812 | ;; (format t "~&failure case #1") | |
| 813 | (return-from FAIL (values nil t))) | |
| 814 | ;; | |
| 815 | (let ((lhs-subs (list-AC-subterms lhs-1 lhs-op)) | |
| 816 | (rhs-subs (list-AC-subterms rhs-1 rhs-op)) | |
| 817 | (lhs-vars nil) | |
| 818 | (lhs-constants nil) | |
| 819 | (lhs-funs nil) | |
| 820 | (rhs-constants nil) | |
| 821 | (rhs-funs nil)) | |
| 822 | (declare (type list lhs-subs rhs-subs lhs-vars lhs-constants | |
| 823 | lhs-funs rhs-constants rhs-funs)) | |
| 824 | ;; quick failure cases | |
| 825 | (when (> (the fixnum (length lhs-subs)) | |
| 826 | (the fixnum (length rhs-subs))) | |
| 827 | (return-from FAIL (values nil t))) ; no possible match | |
| 828 | (unless sys-operators | |
| 829 | (setq sys-operators (alloc-svec (the fixnum (length sys))))) | |
| 830 | (setf (svref sys-operators eqn-number) lhs-op) | |
| 831 | ;; build lhs- vars/funs/constants | |
| 832 | (dolist (term lhs-subs) | |
| 833 | (cond ((term-is-variable? term) | |
| 834 | (let ((image (if env (environment-image env term) term))) | |
| 835 | (cond ((null image) | |
| 836 | (push (cons term eqn-number) lhs-vars)) | |
| 837 | ((term-is-variable? image) | |
| 838 | (push (cons image eqn-number) lhs-vars)) | |
| 839 | ((term-is-constant? image) | |
| 840 | (push (cons image eqn-number) lhs-constants)) | |
| 841 | ((method-is-AC-restriction-of lhs-op | |
| 842 | (term-head image)) | |
| 843 | (dolist (term2 (list-AC-subterms image | |
| 844 | (term-head image))) | |
| 845 | (cond ((term-is-variable? term2) | |
| 846 | (push (cons term2 eqn-number) | |
| 847 | lhs-vars)) | |
| 848 | ((term-is-constant? term2) | |
| 849 | (push (cons term2 eqn-number) | |
| 850 | lhs-constants)) | |
| 851 | (t (push (cons term2 eqn-number) | |
| 852 | lhs-funs))))) | |
| 853 | (t (push (cons image eqn-number) lhs-funs))))) | |
| 854 | ((term-is-constant? term) | |
| 855 | (push (cons term eqn-number) lhs-constants)) | |
| 856 | (t (push (cons term eqn-number) lhs-funs)))) | |
| 857 | ;; now that the lhs is partitioned - lets play with the rhs | |
| 858 | (dolist (term rhs-subs) | |
| 859 | (cond ((term-is-variable? term) | |
| 860 | (push (cons term eqn-number) rhs-constants)) | |
| 861 | ((term-is-constant? term) | |
| 862 | (let ((new (delete-one-term term lhs-constants))) | |
| 863 | (if (eq 'none new) | |
| 864 | (push (cons term eqn-number) rhs-constants) | |
| 865 | (if (eq :never-match new) | |
| 866 | (if lhs-vars | |
| 867 | (push (cons term eqn-number) | |
| 868 | rhs-constants) | |
| 869 | (progn | |
| 870 | (with-match-debug () | |
| 871 | (format t "~%- :never-match : lhs-vars ") | |
| 872 | (print-chaos-object lhs-vars)) | |
| 873 | ;; (format t "~&failure case #3") | |
| 874 | (return-from FAIL (values nil t)))) | |
| 875 | (setq lhs-constants new))))) | |
| 876 | (t (let ((new (delete-one-term term lhs-funs))) | |
| 877 | (if (eq 'none new) | |
| 878 | (push (cons term eqn-number) rhs-funs) | |
| 879 | (if (eq :never-match new) | |
| 880 | (if lhs-vars | |
| 881 | (push (cons term eqn-number) | |
| 882 | rhs-funs) | |
| 883 | (progn | |
| 884 | (with-match-debug () | |
| 885 | (format t "~%- :never-match : lhs-vars ") | |
| 886 | (print-chaos-object lhs-vars)) | |
| 887 | ;; (format t "~&failure case #4") | |
| 888 | (return-from FAIL (values nil t)))) | |
| 889 | (setq lhs-funs new))))))) | |
| 890 | ;; now there are no duplicates (things appearing on both sides) | |
| 891 | (let ((lhs-c-count (length lhs-constants)) | |
| 892 | (lhs-f-count (length lhs-funs)) | |
| 893 | (lhs-v-count (length lhs-vars)) | |
| 894 | (rhs-c-count (length rhs-constants)) | |
| 895 | (rhs-f-count (length rhs-funs))) | |
| 896 | (declare (type fixnum lhs-c-count lhs-f-count lhs-v-count | |
| 897 | rhs-c-count rhs-f-count)) | |
| 898 | ;; check trivial failure conditions | |
| 899 | (when (or (> lhs-c-count 0) ; there ain't nothin to match it | |
| 900 | (and (< lhs-v-count 1) ; no variables remain on lhs | |
| 901 | (> rhs-c-count 0)) ; and constants remain on rhs | |
| 902 | (> lhs-f-count rhs-f-count)) ; too many funs to match | |
| 903 | (return-from FAIL (values nil t))) ; FAIL most miserably | |
| 904 | (setq all-lhs-funs (nconc lhs-funs all-lhs-funs)) | |
| 905 | (setq all-lhs-vars (nconc lhs-vars all-lhs-vars)) | |
| 906 | (setq all-rhs-constants (nconc rhs-constants all-rhs-constants)) | |
| 907 | (setq all-rhs-funs (nconc rhs-funs all-rhs-funs)))))) | |
| 950 | 908 | ;; |
| 951 | 909 | ;; done for all equations. |
| 952 | 910 | ;; |
| 953 | 911 | (let ((lhs-f-count (length all-lhs-funs)) |
| 954 | (lhs-v-count (1+ (the fixnum (length all-lhs-vars)))) | |
| 955 | ; note this is "wrong" | |
| 956 | (rhs-c-count (length all-rhs-constants)) | |
| 957 | (rhs-f-count (length all-rhs-funs))) | |
| 958 | (declare (type fixnum lhs-f-count lhs-v-count rhs-c-count rhs-f-count)) | |
| 959 | (let ((lhs-f-r (alloc-svec-fixnum lhs-f-count)) | |
| 960 | (lhs-v-r (alloc-svec-fixnum lhs-v-count)) | |
| 961 | (rhs-c-r (alloc-svec-fixnum rhs-c-count)) | |
| 962 | (rhs-f-r (alloc-svec-fixnum rhs-f-count)) | |
| 963 | (lhs-f-ms (AC-list2multi-set all-lhs-funs)) | |
| 964 | (lhs-v-ms (AC-list2multi-set all-lhs-vars)) | |
| 965 | (rhs-c-ms (AC-list2multi-set all-rhs-constants)) | |
| 966 | (rhs-f-ms (AC-list2multi-set all-rhs-funs)) | |
| 967 | (l-m 0) | |
| 968 | (r-m 0)) | |
| 969 | (declare (type #-GCL simple-vector | |
| 970 | #+GCL vector | |
| 971 | lhs-f-r lhs-v-r rhs-c-r rhs-f-r) | |
| 972 | (type fixnum l-m r-m) | |
| 973 | (type list lhs-f-ms lhs-v-ms rhs-c-ms rhs-f-ms)) | |
| 974 | (let* ((l-gcd (or (cdar lhs-f-ms) (cdar lhs-v-ms) 1)) | |
| 975 | (r-gcd (or (cdar rhs-f-ms) (cdar rhs-c-ms) 1)) | |
| 976 | (LHS-f-list (AC-note-repeats lhs-f-ms lhs-f-r l-m l-gcd)) | |
| 977 | (LHS-v-list (cons (cons 'dummy 13) | |
| 978 | (AC-note-repeats lhs-v-ms lhs-v-r l-m l-gcd))) | |
| 979 | (RHS-c-list (AC-note-repeats rhs-c-ms rhs-c-r r-m r-gcd)) | |
| 980 | (RHS-f-list (AC-note-repeats rhs-f-ms rhs-f-r r-m r-gcd))) | |
| 981 | (declare (type fixnum l-gcd r-gcd) | |
| 982 | (type list lhs-f-list lhs-v-list rhs-c-list rhs-f-list)) | |
| 983 | (let ((LHS-f (make-array lhs-f-count :initial-contents lhs-f-list)) | |
| 984 | (LHS-v (make-array lhs-v-count :initial-contents lhs-v-list)) | |
| 985 | (RHS-c (make-array rhs-c-count :initial-contents rhs-c-list)) | |
| 986 | (RHS-f (make-array rhs-f-count :initial-contents rhs-f-list)) | |
| 987 | (RHS-c-max (expt2 (1- lhs-v-count))) | |
| 988 | (RHS-f-max (expt2 (+ -1 lhs-v-count lhs-f-count))) | |
| 989 | (RHS-full-bits (- (the fixnum | |
| 990 | (expt2 (+ lhs-v-count lhs-f-count))) 2)) | |
| 991 | (rhs-c-sol (alloc-svec-fixnum rhs-c-count)) | |
| 992 | (rhs-f-sol (alloc-svec-fixnum rhs-f-count)) | |
| 993 | (rhs-c-compat (alloc-svec-fixnum rhs-c-count)) | |
| 994 | (rhs-f-compat (alloc-svec-fixnum rhs-f-count)) | |
| 995 | (dummy-bit 1) ; to save a whole bunch of expt'ing | |
| 996 | (lhs-r-mask 0) | |
| 997 | (state (make-ac-state)) | |
| 998 | ) | |
| 999 | (declare (type #-GCL simple-vector | |
| 1000 | #+GCL vector | |
| 1001 | lhs-f lhs-v rhs-c rhs-f | |
| 1002 | rhs-c-sol rhs-f-sol rhs-c-compat rhs-f-compat) | |
| 1003 | (type fixnum rhs-c-max rhs-f-max rhs-full-bits | |
| 1004 | dummy-bit lhs-r-mask)) | |
| 1005 | ;; | |
| 1006 | (when *match-debug* | |
| 1007 | (format t "~&..lhs-f-ms=~s, lhs-f-r=~s lhs-v-ms=~s, lhs-v-r=~s, l-m=~d l-gcd=~d" lhs-f-ms lhs-f-r lhs-v-ms lhs-v-r l-m l-gcd) | |
| 1008 | (format t "~&..all-rhs-funs=~s, rhs-c-ms=~s, rhs-c-r=~s, rhs-f-ms=~s, rhs-f-r=~s, r-m=~d, r-gcd=~d" all-rhs-funs rhs-c-ms rhs-c-r rhs-f-ms rhs-f-r r-m r-gcd)) | |
| 1009 | ;; one more easy failure check | |
| 1010 | (when (or (> l-m r-m) ; a lhs item is repeated more than any rhs | |
| 1011 | (not (integerp (/ r-gcd l-gcd)))) | |
| 1012 | ;; (deallocate-ac-state state) | |
| 1013 | ;; (break "2") | |
| 1014 | (return-from FAIL (values nil t))) ; FAIL most miserably | |
| 1015 | ;; NOW, get down to the real work.... | |
| 1016 | ;; setup the repeat mask (first of v's) | |
| 1017 | (dotimes (j lhs-v-count) | |
| 1018 | (declare (type fixnum j)) | |
| 1019 | (when (> (the fixnum (svref lhs-v-r j)) 1) | |
| 1020 | (setq lhs-r-mask (make-or lhs-r-mask dummy-bit)) | |
| 1021 | (setq dummy-bit (* 2 dummy-bit)))) | |
| 1022 | ;; note dummy-bit might not be 1 here... | |
| 1023 | (dotimes (j lhs-f-count) ; (then of f's) | |
| 1024 | (declare (type fixnum j)) | |
| 1025 | (when (> (the fixnum (svref lhs-f-r j)) 1) | |
| 1026 | (setq lhs-r-mask (make-or lhs-r-mask dummy-bit)) | |
| 1027 | (setq dummy-bit (* 2 dummy-bit)))) | |
| 1028 | ;; now setup the compatibility bitvectors (for rhs-c) | |
| 1029 | (dotimes (i rhs-c-count) | |
| 1030 | (declare (type fixnum i)) | |
| 1031 | (setq dummy-bit 1) | |
| 1032 | (let ((my-repeat-count (svref rhs-c-r i))) | |
| 1033 | (declare (type fixnum my-repeat-count)) | |
| 1034 | (dotimes (j lhs-v-count) | |
| 1035 | (declare (type fixnum j)) | |
| 1036 | (when (and (= (the fixnum (cdr (svref rhs-c i))) | |
| 1037 | (the fixnum (cdr (svref lhs-v j)))) | |
| 1038 | ;; both are from same equation, AND | |
| 1039 | (or (= (the fixnum (svref lhs-v-r j)) | |
| 1040 | my-repeat-count) | |
| 1041 | ;; the right repetition number OR 0 | |
| 1042 | (= (the fixnum (svref lhs-v-r j)) | |
| 1043 | 0))) | |
| 1044 | (setf (svref rhs-c-compat i) | |
| 1045 | (make-or (the fixnum (svref rhs-c-compat i)) | |
| 1046 | dummy-bit))) | |
| 1047 | (setq dummy-bit (* 2 dummy-bit))))) | |
| 1048 | ;; now setup the compatibility bitvectors (for rhs-f) | |
| 1049 | (dotimes (i rhs-f-count) | |
| 1050 | (declare (type fixnum i)) | |
| 1051 | (setq dummy-bit 1) | |
| 1052 | (let ((my-repeat-count (svref rhs-f-r i))) | |
| 1053 | (declare (fixnum my-repeat-count)) | |
| 1054 | (dotimes (j lhs-v-count) | |
| 1055 | (declare (type fixnum j)) | |
| 1056 | (when (and (= (the fixnum (cdr (svref rhs-f i))) | |
| 1057 | (the fixnum (cdr (svref lhs-v j)))) | |
| 1058 | ;; both are from same equation, AND | |
| 1059 | (or (= (the fixnum (svref lhs-v-r j)) | |
| 1060 | my-repeat-count) | |
| 1061 | (= (the fixnum (svref lhs-v-r j)) | |
| 1062 | 0))) | |
| 1063 | (setf (svref rhs-f-compat i) | |
| 1064 | (make-or (the fixnum (svref rhs-f-compat i)) | |
| 1065 | dummy-bit))) | |
| 1066 | (setq dummy-bit (* 2 dummy-bit))) | |
| 1067 | ;; now lhs vars are taken care of, we need to deal with funs | |
| 1068 | (dotimes (j lhs-f-count) | |
| 1069 | (declare (type fixnum j)) | |
| 1070 | ;; for now, ignore repetition of funs (can be slower) | |
| 1071 | (when (and (= (the fixnum (cdr (svref rhs-f i))) | |
| 1072 | (the fixnum (cdr (svref lhs-f j)))) | |
| 1073 | ;; both are from same equation, AND | |
| 1074 | (possibly-matches (car (svref lhs-f j)) | |
| 1075 | (car (svref rhs-f i)))) | |
| 1076 | (setf (svref rhs-f-compat i) | |
| 1077 | (make-or (the fixnum (svref rhs-f-compat i)) | |
| 1078 | dummy-bit))) | |
| 1079 | (setq dummy-bit (* 2 dummy-bit))))) | |
| 1080 | ;; and now set up the initial state to a legal one | |
| 1081 | ;; (the smallest legal one) | |
| 1082 | ;; by just rotating the bit until it make-and's with | |
| 1083 | ;; the compatibility vector | |
| 1084 | (dotimes (i rhs-c-count) | |
| 1085 | (declare (type fixnum i)) | |
| 1086 | (setq dummy-bit 1) | |
| 1087 | (if (and (= i 0) (= rhs-f-count 0)) | |
| 1088 | (setf (svref rhs-c-sol 0) 1) | |
| 1089 | (let ((my-compat (svref rhs-c-compat i))) | |
| 1090 | (declare (type fixnum my-compat)) | |
| 1091 | (do () | |
| 1092 | ((> dummy-bit rhs-c-max) | |
| 1093 | (progn | |
| 1094 | ;; (format t "~&failure case #7") | |
| 1095 | (return-from FAIL (values nil t)))) | |
| 1096 | (unless (zerop (make-and dummy-bit my-compat)) | |
| 1097 | (setf (svref rhs-c-sol i) dummy-bit) | |
| 1098 | (return)) | |
| 1099 | (setq dummy-bit (* 2 dummy-bit)))))) | |
| 1100 | (dotimes (i rhs-f-count) | |
| 1101 | (declare (type fixnum i)) | |
| 1102 | (setq dummy-bit 1) | |
| 1103 | (if (= i 0) | |
| 1104 | (setf (svref rhs-f-sol 0) 1) | |
| 1105 | (let ((my-compat (svref rhs-f-compat i))) | |
| 1106 | (declare (type fixnum my-compat)) | |
| 1107 | (do () | |
| 1108 | ((> dummy-bit rhs-f-max) | |
| 1109 | (progn ;; (deallocate-ac-state state) | |
| 1110 | ;; (format t "~&failure case #8") | |
| 1111 | (return-from FAIL (values nil t)))) | |
| 1112 | (unless (zerop (make-and dummy-bit my-compat)) | |
| 1113 | (setf (svref rhs-f-sol i) dummy-bit) | |
| 1114 | (return)) | |
| 1115 | (setq dummy-bit (* 2 dummy-bit)))))) | |
| 1116 | ;; initialize the mask - | |
| 1117 | (if (= rhs-f-count 0) | |
| 1118 | (setf (AC-state-LHS-mask state) 0) | |
| 1119 | (let ((temp 0)) | |
| 1120 | (declare (type fixnum temp)) | |
| 1121 | (dotimes (s rhs-c-count) | |
| 1122 | (declare (type fixnum s)) | |
| 1123 | (setq temp (make-or temp (svref rhs-c-sol s)))) | |
| 1124 | (setf (AC-state-LHS-mask state) temp))) | |
| 1125 | ;; and now stuff the state full of information, and return it. | |
| 1126 | (setf (ac-state-operators state) sys-operators | |
| 1127 | (ac-state-LHS-f state) lhs-f | |
| 1128 | (ac-state-LHS-v state) lhs-v | |
| 1129 | (ac-state-RHS-c state) rhs-c | |
| 1130 | (ac-state-RHS-f state) rhs-f | |
| 1131 | (ac-state-LHS-f-r state) lhs-f-r | |
| 1132 | (ac-state-LHS-v-r state) lhs-v-r | |
| 1133 | (ac-state-RHS-c-r state) rhs-c-r | |
| 1134 | (ac-state-RHS-f-r state) rhs-f-r | |
| 1135 | ;; (setf (ac-state-LHS-mask state) 0) | |
| 1136 | (ac-state-LHS-f-mask state) 0 | |
| 1137 | (ac-state-LHS-r-mask state) lhs-r-mask | |
| 1138 | (ac-state-RHS-c-sol state) rhs-c-sol | |
| 1139 | (ac-state-RHS-c-max state) rhs-c-max | |
| 1140 | (ac-state-RHS-f-sol state) rhs-f-sol | |
| 1141 | (ac-state-RHS-f-max state) rhs-f-max | |
| 1142 | (ac-state-RHS-full-bits state) rhs-full-bits | |
| 1143 | (ac-state-RHS-c-compat state) rhs-c-compat | |
| 1144 | (ac-state-RHS-f-compat state) rhs-f-compat | |
| 1145 | (ac-state-LHS-c-count state) 0 | |
| 1146 | (ac-state-LHS-f-count state) lhs-f-count | |
| 1147 | (ac-state-LHS-v-count state) lhs-v-count ; off 1+ intentionally | |
| 1148 | (ac-state-RHS-c-count state) rhs-c-count | |
| 1149 | (ac-state-RHS-f-count state) rhs-f-count | |
| 1150 | (ac-state-no-more state) nil | |
| 1151 | (ac-state-ac-state-p state) 'ac-state ) | |
| 1152 | ;; | |
| 1153 | (when *match-debug* (format t "~&*** done initialization")) | |
| 1154 | (values state nil)))))))) | |
| 912 | (lhs-v-count (1+ (the fixnum (length all-lhs-vars)))) | |
| 913 | ; note this is "wrong" | |
| 914 | (rhs-c-count (length all-rhs-constants)) | |
| 915 | (rhs-f-count (length all-rhs-funs))) | |
| 916 | (declare (type fixnum lhs-f-count lhs-v-count rhs-c-count rhs-f-count)) | |
| 917 | (let ((lhs-f-r (alloc-svec-fixnum lhs-f-count)) | |
| 918 | (lhs-v-r (alloc-svec-fixnum lhs-v-count)) | |
| 919 | (rhs-c-r (alloc-svec-fixnum rhs-c-count)) | |
| 920 | (rhs-f-r (alloc-svec-fixnum rhs-f-count)) | |
| 921 | (lhs-f-ms (AC-list2multi-set all-lhs-funs)) | |
| 922 | (lhs-v-ms (AC-list2multi-set all-lhs-vars)) | |
| 923 | (rhs-c-ms (AC-list2multi-set all-rhs-constants)) | |
| 924 | (rhs-f-ms (AC-list2multi-set all-rhs-funs)) | |
| 925 | (l-m 0) | |
| 926 | (r-m 0)) | |
| 927 | (declare (type #-GCL simple-vector | |
| 928 | #+GCL vector | |
| 929 | lhs-f-r lhs-v-r rhs-c-r rhs-f-r) | |
| 930 | (type fixnum l-m r-m) | |
| 931 | (type list lhs-f-ms lhs-v-ms rhs-c-ms rhs-f-ms)) | |
| 932 | (let* ((l-gcd (or (cdar lhs-f-ms) (cdar lhs-v-ms) 1)) | |
| 933 | (r-gcd (or (cdar rhs-f-ms) (cdar rhs-c-ms) 1)) | |
| 934 | (LHS-f-list (AC-note-repeats lhs-f-ms lhs-f-r l-m l-gcd)) | |
| 935 | (LHS-v-list (cons (cons 'dummy 13) | |
| 936 | (AC-note-repeats lhs-v-ms lhs-v-r l-m l-gcd))) | |
| 937 | (RHS-c-list (AC-note-repeats rhs-c-ms rhs-c-r r-m r-gcd)) | |
| 938 | (RHS-f-list (AC-note-repeats rhs-f-ms rhs-f-r r-m r-gcd))) | |
| 939 | (declare (type fixnum l-gcd r-gcd) | |
| 940 | (type list lhs-f-list lhs-v-list rhs-c-list rhs-f-list)) | |
| 941 | (let ((LHS-f (make-array lhs-f-count :initial-contents lhs-f-list)) | |
| 942 | (LHS-v (make-array lhs-v-count :initial-contents lhs-v-list)) | |
| 943 | (RHS-c (make-array rhs-c-count :initial-contents rhs-c-list)) | |
| 944 | (RHS-f (make-array rhs-f-count :initial-contents rhs-f-list)) | |
| 945 | (RHS-c-max (expt2 (1- lhs-v-count))) | |
| 946 | (RHS-f-max (expt2 (+ -1 lhs-v-count lhs-f-count))) | |
| 947 | (RHS-full-bits (- (the fixnum | |
| 948 | (expt2 (+ lhs-v-count lhs-f-count))) 2)) | |
| 949 | (rhs-c-sol (alloc-svec-fixnum rhs-c-count)) | |
| 950 | (rhs-f-sol (alloc-svec-fixnum rhs-f-count)) | |
| 951 | (rhs-c-compat (alloc-svec-fixnum rhs-c-count)) | |
| 952 | (rhs-f-compat (alloc-svec-fixnum rhs-f-count)) | |
| 953 | (dummy-bit 1) ; to save a whole bunch of expt'ing | |
| 954 | (lhs-r-mask 0) | |
| 955 | (state (make-ac-state)) | |
| 956 | ) | |
| 957 | (declare (type #-GCL simple-vector | |
| 958 | #+GCL vector | |
| 959 | lhs-f lhs-v rhs-c rhs-f | |
| 960 | rhs-c-sol rhs-f-sol rhs-c-compat rhs-f-compat) | |
| 961 | (type fixnum rhs-c-max rhs-f-max rhs-full-bits | |
| 962 | dummy-bit lhs-r-mask)) | |
| 963 | ;; | |
| 964 | ;; (when *match-debug* | |
| 965 | ;; (format t "~%..lhs-f-ms=~s, lhs-f-r=~s lhs-v-ms=~s, lhs-v-r=~s, l-m=~d l-gcd=~d" lhs-f-ms lhs-f-r lhs-v-ms lhs-v-r l-m l-gcd) | |
| 966 | ;; (format t "~&..all-rhs-funs=~s, rhs-c-ms=~s, rhs-c-r=~s, rhs-f-ms=~s, rhs-f-r=~s, r-m=~d, r-gcd=~d" all-rhs-funs rhs-c-ms rhs-c-r rhs-f-ms rhs-f-r r-m r-gcd)) | |
| 967 | ;; one more easy failure check | |
| 968 | (when (or (> l-m r-m) ; a lhs item is repeated more than any rhs | |
| 969 | (not (integerp (/ r-gcd l-gcd)))) | |
| 970 | (return-from FAIL (values nil t))) ; FAIL most miserably | |
| 971 | ;; NOW, get down to the real work.... | |
| 972 | ;; setup the repeat mask (first of v's) | |
| 973 | (dotimes (j lhs-v-count) | |
| 974 | (declare (type fixnum j)) | |
| 975 | (when (> (the fixnum (svref lhs-v-r j)) 1) | |
| 976 | (setq lhs-r-mask (make-or lhs-r-mask dummy-bit)) | |
| 977 | (setq dummy-bit (* 2 dummy-bit)))) | |
| 978 | ;; note dummy-bit might not be 1 here... | |
| 979 | (dotimes (j lhs-f-count) ; (then of f's) | |
| 980 | (declare (type fixnum j)) | |
| 981 | (when (> (the fixnum (svref lhs-f-r j)) 1) | |
| 982 | (setq lhs-r-mask (make-or lhs-r-mask dummy-bit)) | |
| 983 | (setq dummy-bit (* 2 dummy-bit)))) | |
| 984 | ;; now setup the compatibility bitvectors (for rhs-c) | |
| 985 | (dotimes (i rhs-c-count) | |
| 986 | (declare (type fixnum i)) | |
| 987 | (setq dummy-bit 1) | |
| 988 | (let ((my-repeat-count (svref rhs-c-r i))) | |
| 989 | (declare (type fixnum my-repeat-count)) | |
| 990 | (dotimes (j lhs-v-count) | |
| 991 | (declare (type fixnum j)) | |
| 992 | (when (and (= (the fixnum (cdr (svref rhs-c i))) | |
| 993 | (the fixnum (cdr (svref lhs-v j)))) | |
| 994 | ;; both are from same equation, AND | |
| 995 | (or (= (the fixnum (svref lhs-v-r j)) | |
| 996 | my-repeat-count) | |
| 997 | ;; the right repetition number OR 0 | |
| 998 | (= (the fixnum (svref lhs-v-r j)) | |
| 999 | 0))) | |
| 1000 | (setf (svref rhs-c-compat i) | |
| 1001 | (make-or (the fixnum (svref rhs-c-compat i)) | |
| 1002 | dummy-bit))) | |
| 1003 | (setq dummy-bit (* 2 dummy-bit))))) | |
| 1004 | ;; now setup the compatibility bitvectors (for rhs-f) | |
| 1005 | (dotimes (i rhs-f-count) | |
| 1006 | (declare (type fixnum i)) | |
| 1007 | (setq dummy-bit 1) | |
| 1008 | (let ((my-repeat-count (svref rhs-f-r i))) | |
| 1009 | (declare (fixnum my-repeat-count)) | |
| 1010 | (dotimes (j lhs-v-count) | |
| 1011 | (declare (type fixnum j)) | |
| 1012 | (when (and (= (the fixnum (cdr (svref rhs-f i))) | |
| 1013 | (the fixnum (cdr (svref lhs-v j)))) | |
| 1014 | ;; both are from same equation, AND | |
| 1015 | (or (= (the fixnum (svref lhs-v-r j)) | |
| 1016 | my-repeat-count) | |
| 1017 | (= (the fixnum (svref lhs-v-r j)) | |
| 1018 | 0))) | |
| 1019 | (setf (svref rhs-f-compat i) | |
| 1020 | (make-or (the fixnum (svref rhs-f-compat i)) | |
| 1021 | dummy-bit))) | |
| 1022 | (setq dummy-bit (* 2 dummy-bit))) | |
| 1023 | ;; now lhs vars are taken care of, we need to deal with funs | |
| 1024 | (dotimes (j lhs-f-count) | |
| 1025 | (declare (type fixnum j)) | |
| 1026 | ;; for now, ignore repetition of funs (can be slower) | |
| 1027 | (when (and (= (the fixnum (cdr (svref rhs-f i))) | |
| 1028 | (the fixnum (cdr (svref lhs-f j)))) | |
| 1029 | ;; both are from same equation, AND | |
| 1030 | (possibly-matches (car (svref lhs-f j)) | |
| 1031 | (car (svref rhs-f i)))) | |
| 1032 | (setf (svref rhs-f-compat i) | |
| 1033 | (make-or (the fixnum (svref rhs-f-compat i)) | |
| 1034 | dummy-bit))) | |
| 1035 | (setq dummy-bit (* 2 dummy-bit))))) | |
| 1036 | ;; and now set up the initial state to a legal one | |
| 1037 | ;; (the smallest legal one) | |
| 1038 | ;; by just rotating the bit until it make-and's with | |
| 1039 | ;; the compatibility vector | |
| 1040 | (dotimes (i rhs-c-count) | |
| 1041 | (declare (type fixnum i)) | |
| 1042 | (setq dummy-bit 1) | |
| 1043 | (if (and (= i 0) (= rhs-f-count 0)) | |
| 1044 | (setf (svref rhs-c-sol 0) 1) | |
| 1045 | (let ((my-compat (svref rhs-c-compat i))) | |
| 1046 | (declare (type fixnum my-compat)) | |
| 1047 | (do () | |
| 1048 | ((> dummy-bit rhs-c-max) | |
| 1049 | (progn | |
| 1050 | ;; (format t "~&failure case #7") | |
| 1051 | (return-from FAIL (values nil t)))) | |
| 1052 | (unless (zerop (make-and dummy-bit my-compat)) | |
| 1053 | (setf (svref rhs-c-sol i) dummy-bit) | |
| 1054 | (return)) | |
| 1055 | (setq dummy-bit (* 2 dummy-bit)))))) | |
| 1056 | (dotimes (i rhs-f-count) | |
| 1057 | (declare (type fixnum i)) | |
| 1058 | (setq dummy-bit 1) | |
| 1059 | (if (= i 0) | |
| 1060 | (setf (svref rhs-f-sol 0) 1) | |
| 1061 | (let ((my-compat (svref rhs-f-compat i))) | |
| 1062 | (declare (type fixnum my-compat)) | |
| 1063 | (do () | |
| 1064 | ((> dummy-bit rhs-f-max) | |
| 1065 | (progn ;; (deallocate-ac-state state) | |
| 1066 | ;; (format t "~&failure case #8") | |
| 1067 | (return-from FAIL (values nil t)))) | |
| 1068 | (unless (zerop (make-and dummy-bit my-compat)) | |
| 1069 | (setf (svref rhs-f-sol i) dummy-bit) | |
| 1070 | (return)) | |
| 1071 | (setq dummy-bit (* 2 dummy-bit)))))) | |
| 1072 | ;; initialize the mask - | |
| 1073 | (if (= rhs-f-count 0) | |
| 1074 | (setf (AC-state-LHS-mask state) 0) | |
| 1075 | (let ((temp 0)) | |
| 1076 | (declare (type fixnum temp)) | |
| 1077 | (dotimes (s rhs-c-count) | |
| 1078 | (declare (type fixnum s)) | |
| 1079 | (setq temp (make-or temp (svref rhs-c-sol s)))) | |
| 1080 | (setf (AC-state-LHS-mask state) temp))) | |
| 1081 | ;; and now stuff the state full of information, and return it. | |
| 1082 | (setf (ac-state-operators state) sys-operators | |
| 1083 | (ac-state-LHS-f state) lhs-f | |
| 1084 | (ac-state-LHS-v state) lhs-v | |
| 1085 | (ac-state-RHS-c state) rhs-c | |
| 1086 | (ac-state-RHS-f state) rhs-f | |
| 1087 | (ac-state-LHS-f-r state) lhs-f-r | |
| 1088 | (ac-state-LHS-v-r state) lhs-v-r | |
| 1089 | (ac-state-RHS-c-r state) rhs-c-r | |
| 1090 | (ac-state-RHS-f-r state) rhs-f-r | |
| 1091 | ;; (setf (ac-state-LHS-mask state) 0) | |
| 1092 | (ac-state-LHS-f-mask state) 0 | |
| 1093 | (ac-state-LHS-r-mask state) lhs-r-mask | |
| 1094 | (ac-state-RHS-c-sol state) rhs-c-sol | |
| 1095 | (ac-state-RHS-c-max state) rhs-c-max | |
| 1096 | (ac-state-RHS-f-sol state) rhs-f-sol | |
| 1097 | (ac-state-RHS-f-max state) rhs-f-max | |
| 1098 | (ac-state-RHS-full-bits state) rhs-full-bits | |
| 1099 | (ac-state-RHS-c-compat state) rhs-c-compat | |
| 1100 | (ac-state-RHS-f-compat state) rhs-f-compat | |
| 1101 | (ac-state-LHS-c-count state) 0 | |
| 1102 | (ac-state-LHS-f-count state) lhs-f-count | |
| 1103 | (ac-state-LHS-v-count state) lhs-v-count ; off 1+ intentionally | |
| 1104 | (ac-state-RHS-c-count state) rhs-c-count | |
| 1105 | (ac-state-RHS-f-count state) rhs-f-count | |
| 1106 | (ac-state-no-more state) nil | |
| 1107 | (ac-state-ac-state-p state) 'ac-state ) | |
| 1108 | ;; | |
| 1109 | (with-match-debug () (format t "~%*** done initialization")) | |
| 1110 | (values state nil)))))))) | |
| 1155 | 1111 | |
| 1156 | 1112 | (defun match-AC-next-state (state) |
| 1157 | 1113 | (declare (type #+GCL vector #-GCL simple-vector state)) |
| 1158 | ;; #|| | |
| 1159 | (when *match-debug* | |
| 1160 | (format t "~&match-ac-next-state ---------------------------------------------") | |
| 1161 | (ac-unparse-ac-state state)) | |
| 1162 | ;; ||# | |
| 1163 | 1114 | (if (not (AC-state-p state)) |
| 1164 | (progn (format t "~& AC-Next-State given non-ac-state:~A~&" state) | |
| 1165 | (values nil nil t)) ; failing is default behavior... | |
| 1115 | (progn (format t "~% AC-Next-State given non-ac-state:~A~%" state) | |
| 1116 | (values nil nil t)) ; failing is default behavior... | |
| 1166 | 1117 | (if (AC-state-no-more state) |
| 1167 | (progn | |
| 1168 | ;; (deallocate-ac-state state) | |
| 1169 | (values nil nil t) ; there are no more solutions - fail | |
| 1170 | ) | |
| 1171 | (do* ((n 0) | |
| 1172 | (rhs-f-sol (AC-state-rhs-f-sol state)) | |
| 1173 | (rhs-f-max (AC-state-rhs-f-max state)) | |
| 1174 | (rhs-f-compat (AC-state-rhs-f-compat state)) | |
| 1175 | (rhs-f-count (AC-state-rhs-f-count state)) | |
| 1176 | (rhs-full-bits (AC-state-rhs-full-bits state)) | |
| 1177 | (lhs-r-mask (AC-state-lhs-r-mask state)) | |
| 1178 | ) | |
| 1179 | (nil) ; forever | |
| 1180 | (declare (type fixnum | |
| 1181 | n rhs-f-count rhs-f-max lhs-r-mask rhs-full-bits) | |
| 1182 | (type #+GCL vector #-GCL simple-vector | |
| 1183 | rhs-f-sol rhs-f-compat)) | |
| 1184 | (cond ((>= n rhs-f-count) ; no next row | |
| 1185 | (AC-next-state-sub state) | |
| 1186 | (if (AC-state-no-more state) | |
| 1187 | (if (and (= 0 (the fixnum (ac-state-LHS-f-count state))) | |
| 1188 | (= 1 (the fixnum (ac-state-LHS-v-count state))) | |
| 1189 | (= 0 (the fixnum (ac-state-RHS-c-count state))) | |
| 1190 | (= 0 (the fixnum (ac-state-RHS-f-count state)))) | |
| 1191 | (let ((sol (AC-solution-from-state state))) | |
| 1192 | (if sol | |
| 1193 | (return (values sol state nil)) | |
| 1194 | (if (= n 0) | |
| 1195 | (return (values nil state nil)) | |
| 1196 | (return (values nil nil t))))) | |
| 1197 | (progn | |
| 1198 | ;; failed at f-level | |
| 1199 | ;; (deallocate-ac-state state) | |
| 1200 | (return (values nil nil t))) | |
| 1201 | ) | |
| 1202 | (setq n (1- n)))) | |
| 1203 | ((< n 0) | |
| 1204 | (let ((temp (AC-state-LHS-mask state))) | |
| 1205 | (declare (type fixnum temp)) | |
| 1206 | (dotimes (s rhs-f-count) | |
| 1207 | (declare (type fixnum s)) | |
| 1208 | (setq temp (make-or temp (svref rhs-f-sol s)))) | |
| 1209 | (if (= rhs-full-bits temp) | |
| 1210 | (let ((sol (AC-solution-from-state state))) | |
| 1211 | (if sol | |
| 1212 | (return (values sol state nil)) | |
| 1213 | (return (match-ac-next-state state)))) | |
| 1214 | (setq n 0)))) | |
| 1215 | ((< (the fixnum (svref rhs-f-sol n)) rhs-f-max) | |
| 1216 | (AC-Rotate-Left rhs-f-sol n) | |
| 1217 | (when (and ; this is a compatible position for this bit | |
| 1218 | (> (the fixnum (make-and (svref rhs-f-sol n) | |
| 1219 | (svref rhs-f-compat n))) | |
| 1220 | 0) | |
| 1221 | ;; either this isnt a repeated term | |
| 1222 | (or (zerop (the fixnum | |
| 1223 | (make-and (svref rhs-f-sol n) lhs-r-mask))) | |
| 1224 | ;; or it is, and its upper neighbor is home | |
| 1225 | (and (< (1+ n) rhs-f-count) | |
| 1226 | (= (* 2 (the fixnum (svref rhs-f-sol n))) | |
| 1227 | (the fixnum (svref rhs-f-sol (1+ n))))))) | |
| 1228 | (setq n (1- n)))) ; then this row is ok, else redo | |
| 1229 | (t ; this row (n) is already maxed | |
| 1230 | (setf (svref rhs-f-sol n) 1) ; reset this row to one | |
| 1231 | (setq n (1+ n)))))))) | |
| 1118 | (progn | |
| 1119 | ;; (deallocate-ac-state state) | |
| 1120 | (values nil nil t) ; there are no more solutions - fail | |
| 1121 | ) | |
| 1122 | (do* ((n 0) | |
| 1123 | (rhs-f-sol (AC-state-rhs-f-sol state)) | |
| 1124 | (rhs-f-max (AC-state-rhs-f-max state)) | |
| 1125 | (rhs-f-compat (AC-state-rhs-f-compat state)) | |
| 1126 | (rhs-f-count (AC-state-rhs-f-count state)) | |
| 1127 | (rhs-full-bits (AC-state-rhs-full-bits state)) | |
| 1128 | (lhs-r-mask (AC-state-lhs-r-mask state))) | |
| 1129 | (nil) ; forever | |
| 1130 | (declare (type fixnum | |
| 1131 | n rhs-f-count rhs-f-max lhs-r-mask rhs-full-bits) | |
| 1132 | (type #+GCL vector #-GCL simple-vector | |
| 1133 | rhs-f-sol rhs-f-compat)) | |
| 1134 | (cond ((>= n rhs-f-count) ; no next row | |
| 1135 | (AC-next-state-sub state) | |
| 1136 | (if (AC-state-no-more state) | |
| 1137 | (if (and (= 0 (the fixnum (ac-state-LHS-f-count state))) | |
| 1138 | (= 1 (the fixnum (ac-state-LHS-v-count state))) | |
| 1139 | (= 0 (the fixnum (ac-state-RHS-c-count state))) | |
| 1140 | (= 0 (the fixnum (ac-state-RHS-f-count state)))) | |
| 1141 | (let ((sol (AC-solution-from-state state))) | |
| 1142 | (if sol | |
| 1143 | (return (values sol state nil)) | |
| 1144 | (if (= n 0) | |
| 1145 | (return (values nil state nil)) | |
| 1146 | (return (values nil nil t))))) | |
| 1147 | (progn | |
| 1148 | ;; failed at f-level | |
| 1149 | ;; (deallocate-ac-state state) | |
| 1150 | (return (values nil nil t)))) | |
| 1151 | (setq n (1- n)))) | |
| 1152 | ((< n 0) | |
| 1153 | (let ((temp (AC-state-LHS-mask state))) | |
| 1154 | (declare (type fixnum temp)) | |
| 1155 | (dotimes (s rhs-f-count) | |
| 1156 | (declare (type fixnum s)) | |
| 1157 | (setq temp (make-or temp (svref rhs-f-sol s)))) | |
| 1158 | (if (= rhs-full-bits temp) | |
| 1159 | (let ((sol (AC-solution-from-state state))) | |
| 1160 | (if sol | |
| 1161 | (return (values sol state nil)) | |
| 1162 | (return (match-ac-next-state state)))) | |
| 1163 | (setq n 0)))) | |
| 1164 | ((< (the fixnum (svref rhs-f-sol n)) rhs-f-max) | |
| 1165 | (AC-Rotate-Left rhs-f-sol n) | |
| 1166 | (when (and ; this is a compatible position for this bit | |
| 1167 | (> (the fixnum (make-and (svref rhs-f-sol n) | |
| 1168 | (svref rhs-f-compat n))) | |
| 1169 | 0) | |
| 1170 | ;; either this isnt a repeated term | |
| 1171 | (or (zerop (the fixnum | |
| 1172 | (make-and (svref rhs-f-sol n) lhs-r-mask))) | |
| 1173 | ;; or it is, and its upper neighbor is home | |
| 1174 | (and (< (1+ n) rhs-f-count) | |
| 1175 | (= (* 2 (the fixnum (svref rhs-f-sol n))) | |
| 1176 | (the fixnum (svref rhs-f-sol (1+ n))))))) | |
| 1177 | (setq n (1- n)))) ; then this row is ok, else redo | |
| 1178 | (t ; this row (n) is already maxed | |
| 1179 | (setf (svref rhs-f-sol n) 1) ; reset this row to one | |
| 1180 | (setq n (1+ n)))))))) | |
| 1232 | 1181 | |
| 1233 | 1182 | #+CMU (declaim (ext:end-block)) |
| 1234 | 1183 | |
| 1235 | 1184 | ;; not all that useful printout of parts of AC state. |
| 1236 | 1185 | (defun AC-unparse-AC-state (AC-st) |
| 1237 | (format t "~&-- no more=~A~%" (AC-state-no-more AC-st)) | |
| 1238 | (format t "~&-- operators: ~&") | |
| 1186 | (format t "~%-- no more=~A~%" (AC-state-no-more AC-st)) | |
| 1187 | (format t "-- operators: ~%") | |
| 1239 | 1188 | (map nil #'print-chaos-object (AC-state-operators AC-st)) |
| 1240 | (format t "~&-- RHS-f: ~&") | |
| 1189 | (format t "-- RHS-f: ~%") | |
| 1241 | 1190 | (map nil #'print-chaos-object (AC-state-RHS-f AC-st)) |
| 1242 | (format t "~&-- RHS-c: ~&") | |
| 1191 | (format t "-- RHS-c: ~%") | |
| 1243 | 1192 | (map nil #'print-chaos-object (AC-state-RHS-c AC-st)) |
| 1244 | (format t "~&-- LHS-v: ~&") | |
| 1193 | (format t "-- LHS-v: ~%") | |
| 1245 | 1194 | (map nil #'print-chaos-object (AC-state-LHS-v AC-st)) |
| 1246 | (format t "~&-- LHS-f: ~&") | |
| 1195 | (format t "-- LHS-f: ~%") | |
| 1247 | 1196 | (map nil #'print-chaos-object (AC-state-LHS-f AC-st)) |
| 1248 | (format t "~&-- rhs-c-count=~A, rhs-f-count=~A~&" | |
| 1249 | (AC-state-RHS-c-count AC-st) | |
| 1250 | (AC-state-RHS-f-count AC-st)) | |
| 1251 | (format t "~&-- lhs-c-count=~A, lhs-f-count=~A, lhs-v-count=~A~%" | |
| 1252 | (AC-state-LHS-c-count AC-st) | |
| 1253 | (AC-state-LHS-f-count AC-st) | |
| 1254 | (AC-state-LHS-v-count AC-st)) | |
| 1197 | (format t "-- rhs-c-count=~A, rhs-f-count=~A~%" | |
| 1198 | (AC-state-RHS-c-count AC-st) | |
| 1199 | (AC-state-RHS-f-count AC-st)) | |
| 1200 | (format t "-- lhs-c-count=~A, lhs-f-count=~A, lhs-v-count=~A~%" | |
| 1201 | (AC-state-LHS-c-count AC-st) | |
| 1202 | (AC-state-LHS-f-count AC-st) | |
| 1203 | (AC-state-LHS-v-count AC-st)) | |
| 1255 | 1204 | (let ((*print-base* 2) |
| 1256 | (*print-array* t)) ; these be bitvectors, print them as such | |
| 1205 | (*print-array* t)) ; these be bitvectors, print them as such | |
| 1257 | 1206 | (format t "----------~%-- rhs-c-sol= ~A~&rhs-f-sol=~A~&" |
| 1258 | (AC-state-RHS-c-sol AC-st) (AC-state-RHS-f-sol AC-st)) | |
| 1259 | (format t "~&-- rhs-c-max=~A, rhs-f-max=~A, rhs-full-bits=~A~&" | |
| 1260 | (AC-state-RHS-c-max AC-st) | |
| 1261 | (AC-state-RHS-f-max AC-st) | |
| 1262 | (AC-state-RHS-full-bits AC-st)) | |
| 1263 | (format t "~&-- rhs-c-compat=~A, rhs-f-compat=~A~&" | |
| 1264 | (AC-state-RHS-c-compat AC-st) | |
| 1265 | (AC-state-RHS-f-compat AC-st)) | |
| 1266 | (format t "~&-- rhs-c-r=~A, rhs-f-r=~A~&" | |
| 1267 | (AC-state-RHS-c-r AC-st) | |
| 1268 | (AC-state-RHS-f-r AC-st)) | |
| 1269 | (format t "~&-- lhs-f-r=~A, lhs-v-r=~A~&" | |
| 1270 | (AC-state-LHS-f-r AC-st) | |
| 1271 | (AC-state-LHS-v-r AC-st)) | |
| 1272 | (format t "~&-- lhs-mask=~A~%" | |
| 1273 | (AC-state-LHS-mask AC-st)) | |
| 1207 | (AC-state-RHS-c-sol AC-st) (AC-state-RHS-f-sol AC-st)) | |
| 1208 | (format t "-- rhs-c-max=~A, rhs-f-max=~A, rhs-full-bits=~A~%" | |
| 1209 | (AC-state-RHS-c-max AC-st) | |
| 1210 | (AC-state-RHS-f-max AC-st) | |
| 1211 | (AC-state-RHS-full-bits AC-st)) | |
| 1212 | (format t "-- rhs-c-compat=~A, rhs-f-compat=~A~%" | |
| 1213 | (AC-state-RHS-c-compat AC-st) | |
| 1214 | (AC-state-RHS-f-compat AC-st)) | |
| 1215 | (format t "-- rhs-c-r=~A, rhs-f-r=~A~%" | |
| 1216 | (AC-state-RHS-c-r AC-st) | |
| 1217 | (AC-state-RHS-f-r AC-st)) | |
| 1218 | (format t "-- lhs-f-r=~A, lhs-v-r=~A~%" | |
| 1219 | (AC-state-LHS-f-r AC-st) | |
| 1220 | (AC-state-LHS-v-r AC-st)) | |
| 1221 | (format t "-- lhs-mask=~A~%" | |
| 1222 | (AC-state-LHS-mask AC-st)) | |
| 1274 | 1223 | (terpri) |
| 1275 | (format t "~&-- lhs-f-mask=~A~%" | |
| 1276 | (AC-state-LHS-f-mask AC-st)) | |
| 1277 | (format t "~&-- lhs-r-mask=~A~%" | |
| 1278 | (AC-state-LHS-r-mask AC-st)))) | |
| 1224 | (format t "-- lhs-f-mask=~A~%" | |
| 1225 | (AC-state-LHS-f-mask AC-st)) | |
| 1226 | (format t "-- lhs-r-mask=~A~%" | |
| 1227 | (AC-state-LHS-r-mask AC-st)))) | |
| 1279 | 1228 | |
| 1280 | 1229 | (defun ac-args-nss (x) (AC-unparse-AC-state (car x)) (terpri)) |
| 1281 | 1230 | |
| 0 | 0 | ;;;-*- Mode:Lisp; Syntax:CommonLisp; Package: CHAOS -*- |
| 1 | 1 | ;;; |
| 2 | ;;; Copyright (c) 2000-2014, Toshimi Sawada. All rights reserved. | |
| 2 | ;;; Copyright (c) 2000-2015, Toshimi Sawada. All rights reserved. | |
| 3 | 3 | ;;; |
| 4 | 4 | ;;; Redistribution and use in source and binary forms, with or without |
| 5 | 5 | ;;; modification, are permitted provided that the following conditions |
| 27 | 27 | ;;; |
| 28 | 28 | (in-package :chaos) |
| 29 | 29 | #|============================================================================== |
| 30 | System:Chaos | |
| 31 | Module:e-match | |
| 32 | File:match-ac.lisp | |
| 30 | System:Chaos | |
| 31 | Module:e-match | |
| 32 | File:match-ac.lisp | |
| 33 | 33 | ==============================================================================|# |
| 34 | 34 | |
| 35 | 35 | #-:chaos-debug |
| 37 | 37 | |
| 38 | 38 | #+:chaos-debug |
| 39 | 39 | (declaim (optimize (speed 1) (safety 3) #-(or GCL EXCL) (debug 3) |
| 40 | #+EXCL (debug 2))) | |
| 40 | #+EXCL (debug 2))) | |
| 41 | 41 | |
| 42 | 42 | ;;; PROCEDURES for AC Matching ================================================ |
| 43 | 43 | |
| 201 | 201 | ;;; Thus PDL implements AC-state on his own. |
| 202 | 202 | #| |
| 203 | 203 | (defstruct AC-state |
| 204 | operators ; array[op] | |
| 205 | ; the top level operators of each eqn in the system | |
| 206 | LHS-f ; array[term] functional terms | |
| 207 | LHS-v ; array[term] variables | |
| 208 | RHS-c ; array[term] constants | |
| 209 | RHS-f ; array[term] functional terms | |
| 210 | LHS-f-r ; array[bool] notes repeated functional terms | |
| 211 | LHS-v-r ; array[bool] notes repeated variables | |
| 212 | RHS-c-r ; array[bool] notes repeated constants | |
| 213 | RHS-f-r ; array[bool] notes repeated functional terms | |
| 214 | (LHS-mask 0) ; long int variables and funs accounted | |
| 215 | ; for by RHS-c-sol | |
| 216 | (LHS-f-mask 0) ; long int funs accounted for by RHS-c-sol | |
| 217 | (LHS-r-mask 0) ; long int bitvector of all repeated (>0) | |
| 218 | ; terms on lhs | |
| 219 | RHS-c-sol ; array[int] solution matrix; constants | |
| 220 | RHS-c-max ; int ; max value of elements of RHS-c-sol | |
| 221 | RHS-f-sol ; array[int] solution matrix; functional terms | |
| 222 | RHS-f-max ; int max value of elements of RHS-f-sol | |
| 223 | RHS-full-bits ; int 11111...111 | |
| 224 | RHS-c-compat ; array[int] array of compatibility bitvectors | |
| 225 | RHS-f-compat ; array[int] array of compatibility bitvectors | |
| 226 | LHS-c-count ; int number of constants on LHS | |
| 227 | ; after simplification | |
| 228 | LHS-f-count ; int number of functions on LHS | |
| 229 | ; after simplification | |
| 230 | LHS-v-count ; int number of variables on LHS | |
| 231 | ; after simplification | |
| 232 | RHS-c-count ; int number of constants on RHS | |
| 233 | ; after simplification | |
| 234 | RHS-f-count ; int number of functions on RHS | |
| 235 | ; after simplification | |
| 236 | RHS-f-match-top-ac ; array[bool] can that term match the top op? (nil) | |
| 237 | (no-more nil) ; when true implies that all solutions | |
| 238 | ; have been reported | |
| 204 | operators ; array[op] | |
| 205 | ; the top level operators of each eqn in the system | |
| 206 | LHS-f ; array[term] functional terms | |
| 207 | LHS-v ; array[term] variables | |
| 208 | RHS-c ; array[term] constants | |
| 209 | RHS-f ; array[term] functional terms | |
| 210 | LHS-f-r ; array[bool] notes repeated functional terms | |
| 211 | LHS-v-r ; array[bool] notes repeated variables | |
| 212 | RHS-c-r ; array[bool] notes repeated constants | |
| 213 | RHS-f-r ; array[bool] notes repeated functional terms | |
| 214 | (LHS-mask 0) ; long int variables and funs accounted | |
| 215 | ; for by RHS-c-sol | |
| 216 | (LHS-f-mask 0) ; long int funs accounted for by RHS-c-sol | |
| 217 | (LHS-r-mask 0) ; long int bitvector of all repeated (>0) | |
| 218 | ; terms on lhs | |
| 219 | RHS-c-sol ; array[int] solution matrix; constants | |
| 220 | RHS-c-max ; int ; max value of elements of RHS-c-sol | |
| 221 | RHS-f-sol ; array[int] solution matrix; functional terms | |
| 222 | RHS-f-max ; int max value of elements of RHS-f-sol | |
| 223 | RHS-full-bits ; int 11111...111 | |
| 224 | RHS-c-compat ; array[int] array of compatibility bitvectors | |
| 225 | RHS-f-compat ; array[int] array of compatibility bitvectors | |
| 226 | LHS-c-count ; int number of constants on LHS | |
| 227 | ; after simplification | |
| 228 | LHS-f-count ; int number of functions on LHS | |
| 229 | ; after simplification | |
| 230 | LHS-v-count ; int number of variables on LHS | |
| 231 | ; after simplification | |
| 232 | RHS-c-count ; int number of constants on RHS | |
| 233 | ; after simplification | |
| 234 | RHS-f-count ; int number of functions on RHS | |
| 235 | ; after simplification | |
| 236 | RHS-f-match-top-ac ; array[bool] can that term match the top op? (nil) | |
| 237 | (no-more nil) ; when true implies that all solutions | |
| 238 | ; have been reported | |
| 239 | 239 | ) |
| 240 | 240 | |# |
| 241 | 241 | (defmacro make-AC-state () `(alloc-svec 26)) |
| 352 | 352 | (defmacro AC-Rotate-Left (_*_*_array *_*_*m) |
| 353 | 353 | " shifts the element one bit to the left" |
| 354 | 354 | ` (setf (%svref ,_*_*_array ,*_*_*m) |
| 355 | (* 2 (%svref ,_*_*_array ,*_*_*m)))) | |
| 355 | (* 2 (%svref ,_*_*_array ,*_*_*m)))) | |
| 356 | 356 | |
| 357 | 357 | (defmacro AC-note-repeats (_??mset _??array _??max _??gcd) |
| 358 | 358 | "; puts all repeated terms together in the list, and bashes the array |
| 361 | 361 | ; e.g. for input (a b c c c d d e f f) and #(0 0 0 0 0 0 0 0 0), |
| 362 | 362 | ; this should make the array into #(0 0 3 2 1 2 1 0 2 1)." |
| 363 | 363 | ` (let* ((list2 nil) |
| 364 | (counter (length (the #+GCL vector #-GCL simple-vector ,_??array)))) | |
| 364 | (counter (length (the #+GCL vector #-GCL simple-vector ,_??array)))) | |
| 365 | 365 | (declare (type fixnum counter)) |
| 366 | 366 | (dolist (element ,_??mset) |
| 367 | (declare (type list element)) | |
| 368 | (let ((n (cdr element))) | |
| 369 | (declare (type fixnum n)) | |
| 370 | (when (> n (the fixnum ,_??max)) | |
| 371 | (setq ,_??max n)) | |
| 372 | (setq ,_??gcd (gcd ,_??gcd n)) | |
| 373 | (if (> n 1) ; if it is repeated at all | |
| 374 | (dotimes (x n) | |
| 375 | (declare (type fixnum x)) | |
| 376 | (push (first element) list2) | |
| 377 | (setq counter (1- counter)) | |
| 378 | (setf (%svref ,_??array counter) | |
| 379 | (1+ x))) | |
| 380 | (progn (push (first element) list2) | |
| 381 | (setq counter (1- counter)) | |
| 382 | ;; this line optional if 0'd array is guaranteed. | |
| 383 | (setf (%svref ,_??array counter) 0))))) | |
| 367 | (declare (type list element)) | |
| 368 | (let ((n (cdr element))) | |
| 369 | (declare (type fixnum n)) | |
| 370 | (when (> n (the fixnum ,_??max)) | |
| 371 | (setq ,_??max n)) | |
| 372 | (setq ,_??gcd (gcd ,_??gcd n)) | |
| 373 | (if (> n 1) ; if it is repeated at all | |
| 374 | (dotimes (x n) | |
| 375 | (declare (type fixnum x)) | |
| 376 | (push (first element) list2) | |
| 377 | (setq counter (1- counter)) | |
| 378 | (setf (%svref ,_??array counter) | |
| 379 | (1+ x))) | |
| 380 | (progn (push (first element) list2) | |
| 381 | (setq counter (1- counter)) | |
| 382 | ;; this line optional if 0'd array is guaranteed. | |
| 383 | (setf (%svref ,_??array counter) 0))))) | |
| 384 | 384 | list2)) |
| 385 | 385 | |
| 386 | 386 | #+CMU(declaim (ext:start-block match-ac-state-initialize |
| 387 | match-ac-next-state | |
| 388 | match-ac-equal)) | |
| 387 | match-ac-next-state | |
| 388 | match-ac-equal)) | |
| 389 | 389 | |
| 390 | 390 | ;;; x = term |
| 391 | 391 | ;;; y = ((term . eqn-num) ... ) |
| 393 | 393 | (x y) |
| 394 | 394 | (block exit |
| 395 | 395 | (if (null y) |
| 396 | 'none | |
| 397 | (if (term-is-applform? x) | |
| 398 | ;; application form | |
| 399 | (let ((head (term-head x)) | |
| 400 | (pos nil)) | |
| 401 | (setq pos | |
| 402 | (position-if | |
| 403 | #'(lambda (tv) | |
| 404 | (let ((term (car tv))) | |
| 405 | (and (term-is-applform? term) | |
| 406 | (method-is-of-same-operator+ head | |
| 407 | (term-head term))))) | |
| 408 | (the list y))) | |
| 409 | ;; (break "0") | |
| 410 | (unless pos | |
| 411 | (return-from exit :never-match)) | |
| 412 | (if (zerop pos) | |
| 413 | (if (term-equational-equal x (caar y)) | |
| 414 | (return-from exit (cdr y)) | |
| 415 | (return-from exit 'none)) | |
| 416 | (let ((last y) | |
| 417 | (rest (cdr y)) | |
| 418 | (cur-pos 0)) | |
| 419 | (declare (type fixnum cur-pos)) | |
| 420 | (loop | |
| 421 | (when (= cur-pos pos) | |
| 422 | (if (term-equational-equal x | |
| 423 | (caar rest)) | |
| 424 | (progn | |
| 425 | ;; delete pattern | |
| 426 | (rplacd last (cdr rest)) | |
| 427 | (return-from exit y)) | |
| 428 | (return-from exit 'none))) | |
| 429 | (incf cur-pos) | |
| 430 | (setq last rest rest (cdr rest)))) | |
| 431 | )) | |
| 432 | ;; | |
| 433 | (if (term-equational-equal x (caar y)) | |
| 434 | (cdr y) | |
| 435 | (let ((last y) (rest (cdr y))) | |
| 436 | (loop (when (null rest) (return 'none)) | |
| 437 | (when (term-equational-equal x (caar rest)) | |
| 438 | ;; delete pattern | |
| 439 | (rplacd last (cdr rest)) | |
| 440 | ;; new | |
| 441 | (return y)) | |
| 442 | (setq last rest rest (cdr rest)))) | |
| 443 | )) | |
| 444 | ))) | |
| 396 | 'none | |
| 397 | (if (term-is-applform? x) | |
| 398 | ;; application form | |
| 399 | (let ((head (term-head x)) | |
| 400 | (pos nil)) | |
| 401 | (setq pos | |
| 402 | (position-if | |
| 403 | #'(lambda (tv) | |
| 404 | (let ((term (car tv))) | |
| 405 | (and (term-is-applform? term) | |
| 406 | (method-is-of-same-operator+ head | |
| 407 | (term-head term))))) | |
| 408 | (the list y))) | |
| 409 | ;; (break "0") | |
| 410 | (unless pos | |
| 411 | (return-from exit :never-match)) | |
| 412 | (if (zerop pos) | |
| 413 | (if (term-equational-equal x (caar y)) | |
| 414 | (return-from exit (cdr y)) | |
| 415 | (return-from exit 'none)) | |
| 416 | (let ((last y) | |
| 417 | (rest (cdr y)) | |
| 418 | (cur-pos 0)) | |
| 419 | (declare (type fixnum cur-pos)) | |
| 420 | (loop | |
| 421 | (when (= cur-pos pos) | |
| 422 | (if (term-equational-equal x | |
| 423 | (caar rest)) | |
| 424 | (progn | |
| 425 | ;; delete pattern | |
| 426 | (rplacd last (cdr rest)) | |
| 427 | (return-from exit y)) | |
| 428 | (return-from exit 'none))) | |
| 429 | (incf cur-pos) | |
| 430 | (setq last rest rest (cdr rest)))) | |
| 431 | )) | |
| 432 | ;; | |
| 433 | (if (term-equational-equal x (caar y)) | |
| 434 | (cdr y) | |
| 435 | (let ((last y) (rest (cdr y))) | |
| 436 | (loop (when (null rest) (return 'none)) | |
| 437 | (when (term-equational-equal x (caar rest)) | |
| 438 | ;; delete pattern | |
| 439 | (rplacd last (cdr rest)) | |
| 440 | ;; new | |
| 441 | (return y)) | |
| 442 | (setq last rest rest (cdr rest)))) | |
| 443 | )) | |
| 444 | ))) | |
| 445 | 445 | |
| 446 | 446 | (defvar *ac-failure-eq* nil) |
| 447 | 447 | |
| 450 | 450 | which, if true, imply the original AC equation true) from |
| 451 | 451 | the matrix of 'state'" |
| 452 | 452 | (let* ((ops (AC-state-operators state)) |
| 453 | (lhs-f (AC-state-lhs-f state)) | |
| 454 | (lhs-v (AC-state-lhs-v state)) | |
| 455 | (rhs-c (AC-state-rhs-c state)) | |
| 456 | (rhs-f (AC-state-rhs-f state)) | |
| 457 | (rhs-c-sol (AC-state-rhs-c-sol state)) | |
| 458 | (rhs-f-sol (AC-state-rhs-f-sol state)) | |
| 459 | (new-sys (new-m-system)) | |
| 460 | (term-code 1) | |
| 461 | (rhs-subterms nil) | |
| 462 | (new-eqns nil)) | |
| 453 | (lhs-f (AC-state-lhs-f state)) | |
| 454 | (lhs-v (AC-state-lhs-v state)) | |
| 455 | (rhs-c (AC-state-rhs-c state)) | |
| 456 | (rhs-f (AC-state-rhs-f state)) | |
| 457 | (rhs-c-sol (AC-state-rhs-c-sol state)) | |
| 458 | (rhs-f-sol (AC-state-rhs-f-sol state)) | |
| 459 | (new-sys (new-m-system)) | |
| 460 | (term-code 1) | |
| 461 | (rhs-subterms nil) | |
| 462 | (new-eqns nil)) | |
| 463 | 463 | (declare (type fixnum term-code) |
| 464 | (type #+GCL vector | |
| 465 | #-GCL simple-vector | |
| 466 | ops | |
| 467 | lhs-f lhs-v rhs-c rhs-f rhs-c-sol rhs-f-sol) | |
| 468 | (type list new-sys rhs-subterms new-eqns)) | |
| 464 | (type #+GCL vector | |
| 465 | #-GCL simple-vector | |
| 466 | ops | |
| 467 | lhs-f lhs-v rhs-c rhs-f rhs-c-sol rhs-f-sol) | |
| 468 | (type list new-sys rhs-subterms new-eqns)) | |
| 469 | 469 | (setq *ac-failure-eq* nil) |
| 470 | 470 | ;; (AC-collapse-arrays-internal lhs-v 1) |
| 471 | 471 | (dotimes (i (length lhs-v)) |
| 472 | 472 | (declare (type fixnum i)) |
| 473 | 473 | (if (< i 1) |
| 474 | nil | |
| 475 | (progn | |
| 476 | (setq rhs-subterms nil) | |
| 477 | (setq term-code (* 2 term-code)) | |
| 478 | ;; (AC-collapse-one-array-internal rhs-c-sol rhs-c) | |
| 479 | (dotimes (j (length rhs-c-sol)) | |
| 480 | (declare (type fixnum j)) | |
| 474 | nil | |
| 475 | (progn | |
| 476 | (setq rhs-subterms nil) | |
| 477 | (setq term-code (* 2 term-code)) | |
| 478 | ;; (AC-collapse-one-array-internal rhs-c-sol rhs-c) | |
| 479 | (dotimes (j (length rhs-c-sol)) | |
| 480 | (declare (type fixnum j)) | |
| 481 | 481 | (when (> (the fixnum (make-and (%svref rhs-c-sol j) |
| 482 | term-code)) | |
| 483 | 0) | |
| 484 | (push (car (%svref rhs-c j)) rhs-subterms))) | |
| 485 | ;; (AC-collapse-one-array-internal rhs-f-sol rhs-f) | |
| 486 | (dotimes (j (length rhs-f-sol)) | |
| 487 | (declare (type fixnum j)) | |
| 482 | term-code)) | |
| 483 | 0) | |
| 484 | (push (car (%svref rhs-c j)) rhs-subterms))) | |
| 485 | ;; (AC-collapse-one-array-internal rhs-f-sol rhs-f) | |
| 486 | (dotimes (j (length rhs-f-sol)) | |
| 487 | (declare (type fixnum j)) | |
| 488 | 488 | (when (> (the fixnum (make-and (%svref rhs-f-sol j) term-code)) |
| 489 | 0) | |
| 490 | (push (car (%svref rhs-f j)) rhs-subterms))) | |
| 491 | (when rhs-subterms | |
| 492 | (push | |
| 493 | (make-equation (car (%svref lhs-v i)) | |
| 494 | (if (cdr rhs-subterms) | |
| 495 | (make-right-assoc-normal-form-with-sort-check | |
| 496 | (%svref ops (cdr (%svref lhs-v i))) | |
| 497 | rhs-subterms) | |
| 498 | (first rhs-subterms))) | |
| 499 | new-eqns)) | |
| 500 | ))) | |
| 489 | 0) | |
| 490 | (push (car (%svref rhs-f j)) rhs-subterms))) | |
| 491 | (when rhs-subterms | |
| 492 | (push | |
| 493 | (make-equation (car (%svref lhs-v i)) | |
| 494 | (if (cdr rhs-subterms) | |
| 495 | (make-right-assoc-normal-form-with-sort-check | |
| 496 | (%svref ops (cdr (%svref lhs-v i))) | |
| 497 | rhs-subterms) | |
| 498 | (first rhs-subterms))) | |
| 499 | new-eqns)) | |
| 500 | ))) | |
| 501 | 501 | ;; |
| 502 | 502 | ;; note term-code is now the right thing. |
| 503 | 503 | ;; (AC-collapse-arrays-internal lhs-f 0) |
| 507 | 507 | (setq term-code (* 2 term-code)) |
| 508 | 508 | ;; (AC-collapse-one-array-internal rhs-c-sol rhs-c) |
| 509 | 509 | (dotimes (j (length rhs-c-sol)) |
| 510 | (declare (type fixnum j)) | |
| 511 | (when (> (the fixnum (make-and (%svref rhs-c-sol j) term-code)) | |
| 512 | 0) | |
| 513 | (push (car (%svref rhs-c j)) rhs-subterms))) | |
| 510 | (declare (type fixnum j)) | |
| 511 | (when (> (the fixnum (make-and (%svref rhs-c-sol j) term-code)) | |
| 512 | 0) | |
| 513 | (push (car (%svref rhs-c j)) rhs-subterms))) | |
| 514 | 514 | ;; (AC-collapse-one-array-internal rhs-f-sol rhs-f) |
| 515 | 515 | (dotimes (j (length rhs-f-sol)) |
| 516 | (declare (type fixnum j)) | |
| 517 | (when (> (the fixnum (make-and (%svref rhs-f-sol j) term-code)) | |
| 518 | 0) | |
| 519 | (push (car (%svref rhs-f j)) rhs-subterms))) | |
| 516 | (declare (type fixnum j)) | |
| 517 | (when (> (the fixnum (make-and (%svref rhs-f-sol j) term-code)) | |
| 518 | 0) | |
| 519 | (push (car (%svref rhs-f j)) rhs-subterms))) | |
| 520 | 520 | (when rhs-subterms |
| 521 | (let ((t1 (car (%svref lhs-f i))) | |
| 522 | (t2 (if (cdr rhs-subterms) | |
| 523 | (make-right-assoc-normal-form-with-sort-check | |
| 524 | (%svref ops (cdr (%svref lhs-f i))) | |
| 525 | rhs-subterms) | |
| 526 | (first rhs-subterms)))) | |
| 527 | (let ((t1-head (term-head t1)) | |
| 528 | (t2-head (term-head t2))) | |
| 529 | (if (method-is-of-same-operator+ t1-head t2-head) | |
| 530 | (push (make-equation t1 t2) new-eqns) | |
| 531 | (let ((minfo-1 (method-theory-info-for-matching | |
| 532 | t1-head)) | |
| 533 | (minfo-2 (method-theory-info-for-matching | |
| 534 | t2-head))) | |
| 535 | (if (or (test-theory | |
| 536 | .z. (theory-info-code minfo-1)) | |
| 537 | (test-theory | |
| 538 | .z. (theory-info-code minfo-2))) | |
| 539 | (push (make-equation t1 t2) new-eqns) | |
| 540 | (progn | |
| 541 | (when *match-debug* | |
| 542 | (setq *ac-failure-eq* (cons t1 t2))) | |
| 543 | (setq new-eqns nil) | |
| 544 | (return nil)) | |
| 545 | )))))) | |
| 521 | (let ((t1 (car (%svref lhs-f i))) | |
| 522 | (t2 (if (cdr rhs-subterms) | |
| 523 | (make-right-assoc-normal-form-with-sort-check | |
| 524 | (%svref ops (cdr (%svref lhs-f i))) | |
| 525 | rhs-subterms) | |
| 526 | (first rhs-subterms)))) | |
| 527 | (let ((t1-head (term-head t1)) | |
| 528 | (t2-head (term-head t2))) | |
| 529 | (if (method-is-of-same-operator+ t1-head t2-head) | |
| 530 | (push (make-equation t1 t2) new-eqns) | |
| 531 | (let ((minfo-1 (method-theory-info-for-matching | |
| 532 | t1-head)) | |
| 533 | (minfo-2 (method-theory-info-for-matching | |
| 534 | t2-head))) | |
| 535 | (if (or (test-theory | |
| 536 | .z. (theory-info-code minfo-1)) | |
| 537 | (test-theory | |
| 538 | .z. (theory-info-code minfo-2))) | |
| 539 | (push (make-equation t1 t2) new-eqns) | |
| 540 | (progn | |
| 541 | (when *match-debug* | |
| 542 | (setq *ac-failure-eq* (cons t1 t2))) | |
| 543 | (setq new-eqns nil) | |
| 544 | (return nil)) | |
| 545 | )))))) | |
| 546 | 546 | ) |
| 547 | 547 | ;; |
| 548 | 548 | (if new-eqns |
| 549 | (progn | |
| 550 | (dolist (eq (nreverse new-eqns)) | |
| 551 | (add-equation-to-m-system new-sys eq)) | |
| 552 | (when *match-debug* | |
| 553 | (format t "~%** ac-solution-from-state") | |
| 554 | (print-m-system new-sys)) | |
| 555 | new-sys) | |
| 556 | (progn | |
| 557 | (when *match-debug* | |
| 558 | (format t "~%** no ac solution") | |
| 559 | (print-next) | |
| 560 | (princ " - t1 = ") (term-print (car *ac-failure-eq*)) | |
| 561 | (print-next) | |
| 562 | (princ " - t2 = ") (term-print (cdr *ac-failure-eq*)) | |
| 563 | ) | |
| 564 | nil)))) | |
| 549 | (progn | |
| 550 | (dolist (eq (nreverse new-eqns)) | |
| 551 | (add-equation-to-m-system new-sys eq)) | |
| 552 | (when *match-debug* | |
| 553 | (format t "~%** ac-solution-from-state") | |
| 554 | (print-m-system new-sys)) | |
| 555 | new-sys) | |
| 556 | (progn | |
| 557 | (when *match-debug* | |
| 558 | (format t "~%** no ac solution") | |
| 559 | (print-next) | |
| 560 | (princ " - t1 = ") (term-print (car *ac-failure-eq*)) | |
| 561 | (print-next) | |
| 562 | (princ " - t2 = ") (term-print (cdr *ac-failure-eq*)) | |
| 563 | ) | |
| 564 | nil)))) | |
| 565 | 565 | |
| 566 | 566 | (#+GCL si:define-inline-function #-GCL defun test_same_term_list (x y) |
| 567 | 567 | (declare (type list x y)) |
| 568 | 568 | (loop (when (null x) (return (null y))) |
| 569 | 569 | (unless (eq (car x) (car y)) |
| 570 | (return nil)) | |
| 570 | (return nil)) | |
| 571 | 571 | (setq x (cdr x)) |
| 572 | 572 | (setq y (cdr y)) |
| 573 | 573 | )) |
| 589 | 589 | (dolist (x list) |
| 590 | 590 | (declare (type term x)) |
| 591 | 591 | (let ((ms-x (dolist (pr ms-list nil) |
| 592 | (when (term-equational-equal x (car pr)) | |
| 593 | (return pr))))) | |
| 594 | (if ms-x | |
| 595 | (setf (cdr ms-x) (1+ (the fixnum (cdr ms-x)))) | |
| 596 | (push (cons x 1) ms-list)) | |
| 597 | )) | |
| 592 | (when (term-equational-equal x (car pr)) | |
| 593 | (return pr))))) | |
| 594 | (if ms-x | |
| 595 | (setf (cdr ms-x) (1+ (the fixnum (cdr ms-x)))) | |
| 596 | (push (cons x 1) ms-list)) | |
| 597 | )) | |
| 598 | 598 | ms-list)) |
| 599 | 599 | |
| 600 | 600 | ;;; Assume that t1 is NOT a variable |
| 608 | 608 | (copy-alist l2mslv1) |
| 609 | 609 | (if (and l2msla2 (test_same_term_list list l2msla2)) |
| 610 | 610 | (progn |
| 611 | (rotatef l2msla1 l2msla2) | |
| 612 | (rotatef l2mslv1 l2mslv2) | |
| 613 | (copy-alist l2mslv1)) | |
| 611 | (rotatef l2msla1 l2msla2) | |
| 612 | (rotatef l2mslv1 l2mslv2) | |
| 613 | (copy-alist l2mslv1)) | |
| 614 | 614 | (let ((res (list2multi-set-list-direct list))) |
| 615 | 615 | (setq l2msla2 l2msla1 l2mslv2 l2mslv1) |
| 616 | 616 | (setq l2msla1 list l2mslv1 res) |
| 631 | 631 | (dolist (x list) |
| 632 | 632 | (declare (type list x)) |
| 633 | 633 | (let ((ms-elt (assoc-if #'(lambda (y) |
| 634 | (declare (type list y)) | |
| 635 | (and (= (the fixnum (cdr x)) | |
| 636 | (the fixnum (cdr y))) | |
| 637 | (term-equational-equal (car y) (car x)))) | |
| 638 | ms-list))) | |
| 639 | (if ms-elt | |
| 640 | (setf (cdr ms-elt) | |
| 641 | (1+ (the fixnum (cdr ms-elt)))) ;;;*** | |
| 642 | (push (cons x 1) ms-list)))) | |
| 634 | (declare (type list y)) | |
| 635 | (and (= (the fixnum (cdr x)) | |
| 636 | (the fixnum (cdr y))) | |
| 637 | (term-equational-equal (car y) (car x)))) | |
| 638 | ms-list))) | |
| 639 | (if ms-elt | |
| 640 | (setf (cdr ms-elt) | |
| 641 | (1+ (the fixnum (cdr ms-elt)))) ;;;*** | |
| 642 | (push (cons x 1) ms-list)))) | |
| 643 | 643 | ms-list)) |
| 644 | 644 | |
| 645 | 645 | |
| 648 | 648 | (defun match-AC-ms-equal (x y) |
| 649 | 649 | (declare (type list x y)) |
| 650 | 650 | (let ((lenx (length x)) |
| 651 | (leny (length y))) | |
| 651 | (leny (length y))) | |
| 652 | 652 | ;; |
| 653 | 653 | (declare (type fixnum lenx leny)) |
| 654 | 654 | (unless (= lenx leny) |
| 656 | 656 | ;; |
| 657 | 657 | (block the-end |
| 658 | 658 | (let ((ydone 0)) |
| 659 | (declare (type fixnum ydone)) | |
| 660 | (dolist (xe x) | |
| 661 | (declare (type list xe)) | |
| 662 | (let ((xterm (car xe)) (xval (cdr xe))) | |
| 663 | (declare (type term xterm) | |
| 664 | (type fixnum xval)) | |
| 665 | (dolist (ye y (return-from the-end nil)) ; didn't find xe in y | |
| 666 | (declare (type list ye)) | |
| 667 | (when (term-equational-equal xterm (car ye)) | |
| 668 | (unless (= xval (the fixnum (cdr ye))) | |
| 669 | (return-from the-end nil)) | |
| 670 | (setq ydone (1+ ydone)) | |
| 671 | (return))))) ; quit the inner do-list | |
| 672 | (unless (= ydone leny) | |
| 673 | (return-from the-end nil))) | |
| 659 | (declare (type fixnum ydone)) | |
| 660 | (dolist (xe x) | |
| 661 | (declare (type list xe)) | |
| 662 | (let ((xterm (car xe)) (xval (cdr xe))) | |
| 663 | (declare (type term xterm) | |
| 664 | (type fixnum xval)) | |
| 665 | (dolist (ye y (return-from the-end nil)) ; didn't find xe in y | |
| 666 | (declare (type list ye)) | |
| 667 | (when (term-equational-equal xterm (car ye)) | |
| 668 | (unless (= xval (the fixnum (cdr ye))) | |
| 669 | (return-from the-end nil)) | |
| 670 | (setq ydone (1+ ydone)) | |
| 671 | (return))))) ; quit the inner do-list | |
| 672 | (unless (= ydone leny) | |
| 673 | (return-from the-end nil))) | |
| 674 | 674 | t))) |
| 675 | 675 | |
| 676 | 676 | (defun AC-next-state-sub (state) |
| 677 | (do* ((m 0) ; only initialize these vars | |
| 678 | (rhs-c-sol (AC-state-rhs-c-sol state)) | |
| 679 | (rhs-c-max (AC-state-rhs-c-max state)) | |
| 680 | (rhs-c-count (AC-state-rhs-c-count state)) | |
| 681 | (rhs-c-compat (AC-state-rhs-c-compat state)) | |
| 682 | (lhs-r-mask (AC-state-lhs-r-mask state))) | |
| 683 | (nil) ; forever | |
| 677 | (do* ((m 0) ; only initialize these vars | |
| 678 | (rhs-c-sol (AC-state-rhs-c-sol state)) | |
| 679 | (rhs-c-max (AC-state-rhs-c-max state)) | |
| 680 | (rhs-c-count (AC-state-rhs-c-count state)) | |
| 681 | (rhs-c-compat (AC-state-rhs-c-compat state)) | |
| 682 | (lhs-r-mask (AC-state-lhs-r-mask state))) | |
| 683 | (nil) ; forever | |
| 684 | 684 | (declare (type #+GCL vector #-GCL simple-vector rhs-c-compat) |
| 685 | (type fixnum m lhs-r-mask rhs-c-count)) | |
| 686 | (cond ((>= m rhs-c-count) ; no next row | |
| 687 | (setf (AC-state-no-more state) T) | |
| 688 | (return)) | |
| 689 | ((< m 0) ; no tests up here - could cut search here | |
| 690 | (let ((temp 0)) ; the empty bitvector | |
| 691 | (declare (type fixnum temp)) | |
| 692 | (dotimes (s rhs-c-count) | |
| 693 | (declare (type fixnum s)) | |
| 694 | (setq temp (make-or temp (%svref rhs-c-sol s)))) | |
| 695 | (setf (AC-state-LHS-mask state) temp) | |
| 696 | (return))) | |
| 697 | ((< (the fixnum (%svref rhs-c-sol m)) rhs-c-max) | |
| 698 | (AC-Rotate-Left rhs-c-sol m) | |
| 699 | (when (and ; this is a compatible position for this bit | |
| 700 | (> (the fixnum (make-and (%svref rhs-c-sol m) | |
| 701 | (%svref rhs-c-compat m))) | |
| 702 | 0) | |
| 703 | ;; either this isnt a repeated term | |
| 704 | (or (zerop (the fixnum | |
| 705 | (make-and (%svref rhs-c-sol m) lhs-r-mask))) | |
| 706 | ;; or it is, and its upper neighbor is home | |
| 707 | (and (< (1+ m) rhs-c-count) | |
| 708 | (= (* 2 (the fixnum (%svref rhs-c-sol m))) | |
| 709 | (the fixnum (%svref rhs-c-sol (1+ m))))))) | |
| 710 | (setq m (1- m)))) ; then this row is ok, else redo this row | |
| 711 | (t ; this row (m) is already maxed | |
| 712 | (setf (%svref rhs-c-sol m) 1) ; reset this row | |
| 713 | (setq m (1+ m)))))) | |
| 685 | (type fixnum m lhs-r-mask rhs-c-count)) | |
| 686 | (cond ((>= m rhs-c-count) ; no next row | |
| 687 | (setf (AC-state-no-more state) T) | |
| 688 | (return)) | |
| 689 | ((< m 0) ; no tests up here - could cut search here | |
| 690 | (let ((temp 0)) ; the empty bitvector | |
| 691 | (declare (type fixnum temp)) | |
| 692 | (dotimes (s rhs-c-count) | |
| 693 | (declare (type fixnum s)) | |
| 694 | (setq temp (make-or temp (%svref rhs-c-sol s)))) | |
| 695 | (setf (AC-state-LHS-mask state) temp) | |
| 696 | (return))) | |
| 697 | ((< (the fixnum (%svref rhs-c-sol m)) rhs-c-max) | |
| 698 | (AC-Rotate-Left rhs-c-sol m) | |
| 699 | (when (and ; this is a compatible position for this bit | |
| 700 | (> (the fixnum (make-and (%svref rhs-c-sol m) | |
| 701 | (%svref rhs-c-compat m))) | |
| 702 | 0) | |
| 703 | ;; either this isnt a repeated term | |
| 704 | (or (zerop (the fixnum | |
| 705 | (make-and (%svref rhs-c-sol m) lhs-r-mask))) | |
| 706 | ;; or it is, and its upper neighbor is home | |
| 707 | (and (< (1+ m) rhs-c-count) | |
| 708 | (= (* 2 (the fixnum (%svref rhs-c-sol m))) | |
| 709 | (the fixnum (%svref rhs-c-sol (1+ m))))))) | |
| 710 | (setq m (1- m)))) ; then this row is ok, else redo this row | |
| 711 | (t ; this row (m) is already maxed | |
| 712 | (setf (%svref rhs-c-sol m) 1) ; reset this row | |
| 713 | (setq m (1+ m)))))) | |
| 714 | 714 | |
| 715 | 715 | #|| |
| 716 | 716 | (match-AC-ms-equal |
| 721 | 721 | (defun match-AC-equal (t1 t2) |
| 722 | 722 | (if (term-is-applform? t2) |
| 723 | 723 | (let ((op (term-head t1))) |
| 724 | (declare (type method op)) | |
| 725 | (if (method-is-of-same-operator op (term-head t2)) | |
| 726 | (let ((sub1 (list-AC-subterms t1 op)) | |
| 727 | (sub2 (list-AC-subterms t2 op))) | |
| 728 | (declare (type list sub1 sub2)) | |
| 729 | (if (= (the fixnum (length sub1)) | |
| 730 | (the fixnum (length sub2))) | |
| 731 | (dolist (s sub1 t) | |
| 732 | (unless (member s sub2 :test #'term-equational-equal) | |
| 733 | (return nil))) | |
| 734 | nil)) | |
| 735 | nil)) | |
| 724 | (declare (type method op)) | |
| 725 | (if (method-is-of-same-operator op (term-head t2)) | |
| 726 | (let ((sub1 (list-AC-subterms t1 op)) | |
| 727 | (sub2 (list-AC-subterms t2 op))) | |
| 728 | (declare (type list sub1 sub2)) | |
| 729 | (if (= (the fixnum (length sub1)) | |
| 730 | (the fixnum (length sub2))) | |
| 731 | (dolist (s sub1 t) | |
| 732 | (unless (member s sub2 :test #'term-equational-equal) | |
| 733 | (return nil))) | |
| 734 | nil)) | |
| 735 | nil)) | |
| 736 | 736 | nil)) |
| 737 | 737 | |
| 738 | 738 | ;;; *********************** |
| 740 | 740 | ;;; (defvar .ac-state-pool. nil) |
| 741 | 741 | ;;;(defmacro allocate-ac-state () |
| 742 | 742 | ;;; ` (if .ac-state-pool. (pop .ac-state-pool.) |
| 743 | ;;; (make-AC-state))) | |
| 743 | ;;; (make-AC-state))) | |
| 744 | 744 | ;;;(defmacro deallocate-ac-state (ac-state) |
| 745 | 745 | ;;; `(push ,ac-state .ac-state-pool.)) |
| 746 | 746 | ;;;(eval-when (eval load) |
| 752 | 752 | or passing to 'AC-next-state'" |
| 753 | 753 | (declare (type list sys env)) |
| 754 | 754 | (when *match-debug* |
| 755 | (format t "~&** match-ac-state-initialize -------------------------------------") | |
| 755 | (format t "~%** match-ac-state-initialize -------------------------------------") | |
| 756 | 756 | (print-next) |
| 757 | 757 | (print-match-system-sys sys) |
| 758 | 758 | (print-next) |
| 760 | 760 | ;; |
| 761 | 761 | (block fail |
| 762 | 762 | (let ((eqn-number -1) |
| 763 | (sys-operators nil) | |
| 764 | (all-lhs-vars nil) | |
| 765 | (all-lhs-funs nil) | |
| 766 | (all-rhs-constants nil) | |
| 767 | (all-rhs-funs nil) | |
| 768 | (*print-circle* nil)) | |
| 763 | (sys-operators nil) | |
| 764 | (all-lhs-vars nil) | |
| 765 | (all-lhs-funs nil) | |
| 766 | (all-rhs-constants nil) | |
| 767 | (all-rhs-funs nil) | |
| 768 | (*print-circle* nil)) | |
| 769 | 769 | (declare (type (or null #-GCL simple-vector |
| 770 | #+GCL vector) | |
| 771 | sys-operators) | |
| 772 | (type list | |
| 773 | all-lhs-vars all-lhs-funs all-rhs-constants all-rhs-funs) | |
| 774 | (type fixnum eqn-number)) | |
| 770 | #+GCL vector) | |
| 771 | sys-operators) | |
| 772 | (type list | |
| 773 | all-lhs-vars all-lhs-funs all-rhs-constants all-rhs-funs) | |
| 774 | (type fixnum eqn-number)) | |
| 775 | 775 | ;; |
| 776 | 776 | (dolist (equation sys) |
| 777 | (incf eqn-number) | |
| 778 | (let* ((lhs-1 (equation-t1 equation)) | |
| 779 | (rhs-1 (equation-t2 equation)) | |
| 780 | (lhs-op (term-head lhs-1)) | |
| 781 | (rhs-op (term-head rhs-1))) | |
| 782 | (declare (type term lhs-1 rhs-1) | |
| 783 | (type method lhs-op rhs-op)) | |
| 784 | ;; quick failure cases. | |
| 785 | (unless (and (theory-contains-AC (method-theory lhs-op)) | |
| 786 | (method-is-ac-restriction-of rhs-op lhs-op)) | |
| 787 | ;; is the first condition really need? | |
| 788 | (return-from FAIL (values nil t))) | |
| 789 | ;; | |
| 790 | (let ((lhs-subs (list-AC-subterms lhs-1 lhs-op)) | |
| 791 | (rhs-subs (list-AC-subterms rhs-1 rhs-op)) | |
| 792 | (lhs-vars nil) | |
| 793 | (lhs-constants nil) | |
| 794 | (lhs-funs nil) | |
| 795 | (rhs-constants nil) | |
| 796 | (rhs-funs nil)) | |
| 797 | (declare (type list lhs-subs rhs-subs lhs-vars lhs-constants | |
| 798 | lhs-funs rhs-constants rhs-funs)) | |
| 799 | ;; quick failure cases | |
| 800 | (when (> (the fixnum (length lhs-subs)) | |
| 801 | (the fixnum (length rhs-subs))) | |
| 802 | (return-from FAIL (values nil t))) ; no possible match | |
| 803 | ;; | |
| 804 | (unless sys-operators | |
| 805 | (setq sys-operators (alloc-svec (the fixnum (length sys))))) | |
| 806 | (setf (%svref sys-operators eqn-number) lhs-op) | |
| 807 | ;; build lhs- vars/funs/constants | |
| 808 | (dolist (term lhs-subs) | |
| 809 | (cond ((term-is-variable? term) | |
| 810 | (let ((image (if env (environment-image env term) term))) | |
| 811 | (cond ((null image) | |
| 812 | (push (cons term eqn-number) lhs-vars)) | |
| 813 | ((term-is-variable? image) | |
| 814 | (push (cons image eqn-number) lhs-vars)) | |
| 815 | ((method-is-AC-restriction-of lhs-op | |
| 816 | (term-head image)) | |
| 817 | (dolist (term2 (list-AC-subterms image | |
| 818 | (term-head image))) | |
| 819 | (cond ((term-is-variable? term2) | |
| 820 | (push (cons term2 eqn-number) | |
| 821 | lhs-vars)) | |
| 822 | ((term-is-constant? term2) | |
| 823 | (push (cons term2 eqn-number) | |
| 824 | lhs-constants)) | |
| 825 | (t (push (cons term2 eqn-number) | |
| 826 | lhs-funs))))) | |
| 827 | ((term-is-constant? image) | |
| 828 | (push (cons image eqn-number) lhs-constants)) | |
| 829 | (t (push (cons image eqn-number) lhs-funs))))) | |
| 830 | ((term-is-constant? term) | |
| 831 | (push (cons term eqn-number) lhs-constants)) | |
| 832 | (t (push (cons term eqn-number) lhs-funs)))) | |
| 833 | ;; now that the lhs is partitioned - lets play with the rhs | |
| 834 | (dolist (term rhs-subs) | |
| 835 | (cond ((term-is-variable? term) | |
| 836 | (push (cons term eqn-number) rhs-constants)) | |
| 837 | ((term-is-constant? term) | |
| 838 | (let ((new (delete-one-term term lhs-constants))) | |
| 839 | (if (eq 'none new) | |
| 840 | (push (cons term eqn-number) rhs-constants) | |
| 841 | (if (eq :never-match new) | |
| 842 | (if lhs-vars | |
| 843 | (push (cons term eqn-number) | |
| 844 | rhs-constants) | |
| 845 | (progn | |
| 846 | (when *match-debug* | |
| 847 | (format t "~&- :never-match : lhs-vars ") | |
| 848 | (print-chaos-object lhs-vars)) | |
| 849 | (return-from FAIL (values nil t)))) | |
| 850 | (setq lhs-constants new))))) | |
| 851 | (t (let ((new (delete-one-term term lhs-funs))) | |
| 852 | (if (eq 'none new) | |
| 853 | (push (cons term eqn-number) rhs-funs) | |
| 854 | (if (eq :never-match new) | |
| 855 | (if lhs-vars | |
| 856 | (push (cons term eqn-number) | |
| 857 | rhs-funs) | |
| 858 | (progn | |
| 859 | (when *match-debug* | |
| 860 | (format t "~&- :never-match : lhs-vars ") | |
| 861 | (print-chaos-object lhs-vars)) | |
| 862 | (return-from FAIL (values nil t)))) | |
| 863 | (setq lhs-funs new))))))) | |
| 864 | ;; now there are no duplicates (things appearing on both sides) | |
| 865 | (let ((lhs-c-count (length lhs-constants)) | |
| 866 | (lhs-f-count (length lhs-funs)) | |
| 867 | (lhs-v-count (length lhs-vars)) | |
| 868 | (rhs-c-count (length rhs-constants)) | |
| 869 | (rhs-f-count (length rhs-funs))) | |
| 870 | (declare (type fixnum lhs-c-count lhs-f-count lhs-v-count | |
| 871 | rhs-c-count rhs-f-count)) | |
| 872 | ;; check trivial failure conditions | |
| 873 | (when (or (> lhs-c-count 0) ; there ain't nothin to match it | |
| 874 | (and (< lhs-v-count 1) ; no variables remain on lhs | |
| 875 | (> rhs-c-count 0)) ; and constants remain on rhs | |
| 876 | (> lhs-f-count rhs-f-count)) ; too many funs to match | |
| 877 | ;; (break "1") | |
| 878 | (return-from FAIL (values nil t))) ; FAIL most miserably | |
| 879 | ;; | |
| 880 | (setq all-lhs-funs (nconc lhs-funs all-lhs-funs)) | |
| 881 | (setq all-lhs-vars (nconc lhs-vars all-lhs-vars)) | |
| 882 | (setq all-rhs-constants (nconc rhs-constants all-rhs-constants)) | |
| 883 | (setq all-rhs-funs (nconc rhs-funs all-rhs-funs)))))) | |
| 777 | (incf eqn-number) | |
| 778 | (let* ((lhs-1 (equation-t1 equation)) | |
| 779 | (rhs-1 (equation-t2 equation)) | |
| 780 | (lhs-op (term-head lhs-1)) | |
| 781 | (rhs-op (term-head rhs-1))) | |
| 782 | (declare (type term lhs-1 rhs-1) | |
| 783 | (type method lhs-op rhs-op)) | |
| 784 | ;; quick failure cases. | |
| 785 | (unless (and (theory-contains-AC (method-theory lhs-op)) | |
| 786 | (method-is-ac-restriction-of rhs-op lhs-op)) | |
| 787 | ;; is the first condition really need? | |
| 788 | (return-from FAIL (values nil t))) | |
| 789 | ;; | |
| 790 | (let ((lhs-subs (list-AC-subterms lhs-1 lhs-op)) | |
| 791 | (rhs-subs (list-AC-subterms rhs-1 rhs-op)) | |
| 792 | (lhs-vars nil) | |
| 793 | (lhs-constants nil) | |
| 794 | (lhs-funs nil) | |
| 795 | (rhs-constants nil) | |
| 796 | (rhs-funs nil)) | |
| 797 | (declare (type list lhs-subs rhs-subs lhs-vars lhs-constants | |
| 798 | lhs-funs rhs-constants rhs-funs)) | |
| 799 | ;; quick failure cases | |
| 800 | (when (> (the fixnum (length lhs-subs)) | |
| 801 | (the fixnum (length rhs-subs))) | |
| 802 | (return-from FAIL (values nil t))) ; no possible match | |
| 803 | ;; | |
| 804 | (unless sys-operators | |
| 805 | (setq sys-operators (alloc-svec (the fixnum (length sys))))) | |
| 806 | (setf (%svref sys-operators eqn-number) lhs-op) | |
| 807 | ;; build lhs- vars/funs/constants | |
| 808 | (dolist (term lhs-subs) | |
| 809 | (cond ((term-is-variable? term) | |
| 810 | (let ((image (if env (environment-image env term) term))) | |
| 811 | (cond ((null image) | |
| 812 | (push (cons term eqn-number) lhs-vars)) | |
| 813 | ((term-is-variable? image) | |
| 814 | (push (cons image eqn-number) lhs-vars)) | |
| 815 | ((method-is-AC-restriction-of lhs-op | |
| 816 | (term-head image)) | |
| 817 | (dolist (term2 (list-AC-subterms image | |
| 818 | (term-head image))) | |
| 819 | (cond ((term-is-variable? term2) | |
| 820 | (push (cons term2 eqn-number) | |
| 821 | lhs-vars)) | |
| 822 | ((term-is-constant? term2) | |
| 823 | (push (cons term2 eqn-number) | |
| 824 | lhs-constants)) | |
| 825 | (t (push (cons term2 eqn-number) | |
| 826 | lhs-funs))))) | |
| 827 | ((term-is-constant? image) | |
| 828 | (push (cons image eqn-number) lhs-constants)) | |
| 829 | (t (push (cons image eqn-number) lhs-funs))))) | |
| 830 | ((term-is-constant? term) | |
| 831 | (push (cons term eqn-number) lhs-constants)) | |
| 832 | (t (push (cons term eqn-number) lhs-funs)))) | |
| 833 | ;; now that the lhs is partitioned - lets play with the rhs | |
| 834 | (dolist (term rhs-subs) | |
| 835 | (cond ((term-is-variable? term) | |
| 836 | (push (cons term eqn-number) rhs-constants)) | |
| 837 | ((term-is-constant? term) | |
| 838 | (let ((new (delete-one-term term lhs-constants))) | |
| 839 | (if (eq 'none new) | |
| 840 | (push (cons term eqn-number) rhs-constants) | |
| 841 | (if (eq :never-match new) | |
| 842 | (if lhs-vars | |
| 843 | (push (cons term eqn-number) | |
| 844 | rhs-constants) | |
| 845 | (progn | |
| 846 | (when *match-debug* | |
| 847 | (format t "~%- :never-match : lhs-vars ") | |
| 848 | (print-chaos-object lhs-vars)) | |
| 849 | (return-from FAIL (values nil t)))) | |
| 850 | (setq lhs-constants new))))) | |
| 851 | (t (let ((new (delete-one-term term lhs-funs))) | |
| 852 | (if (eq 'none new) | |
| 853 | (push (cons term eqn-number) rhs-funs) | |
| 854 | (if (eq :never-match new) | |
| 855 | (if lhs-vars | |
| 856 | (push (cons term eqn-number) | |
| 857 | rhs-funs) | |
| 858 | (progn | |
| 859 | (when *match-debug* | |
| 860 | (format t "~&- :never-match : lhs-vars ") | |
| 861 | (print-chaos-object lhs-vars)) | |
| 862 | (return-from FAIL (values nil t)))) | |
| 863 | (setq lhs-funs new))))))) | |
| 864 | ;; now there are no duplicates (things appearing on both sides) | |
| 865 | (let ((lhs-c-count (length lhs-constants)) | |
| 866 | (lhs-f-count (length lhs-funs)) | |
| 867 | (lhs-v-count (length lhs-vars)) | |
| 868 | (rhs-c-count (length rhs-constants)) | |
| 869 | (rhs-f-count (length rhs-funs))) | |
| 870 | (declare (type fixnum lhs-c-count lhs-f-count lhs-v-count | |
| 871 | rhs-c-count rhs-f-count)) | |
| 872 | ;; check trivial failure conditions | |
| 873 | (when (or (> lhs-c-count 0) ; there ain't nothin to match it | |
| 874 | (and (< lhs-v-count 1) ; no variables remain on lhs | |
| 875 | (> rhs-c-count 0)) ; and constants remain on rhs | |
| 876 | (> lhs-f-count rhs-f-count)) ; too many funs to match | |
| 877 | ;; (break "1") | |
| 878 | (return-from FAIL (values nil t))) ; FAIL most miserably | |
| 879 | ;; | |
| 880 | (setq all-lhs-funs (nconc lhs-funs all-lhs-funs)) | |
| 881 | (setq all-lhs-vars (nconc lhs-vars all-lhs-vars)) | |
| 882 | (setq all-rhs-constants (nconc rhs-constants all-rhs-constants)) | |
| 883 | (setq all-rhs-funs (nconc rhs-funs all-rhs-funs)))))) | |
| 884 | 884 | ;; |
| 885 | 885 | ;; done for all equations. |
| 886 | 886 | ;; |
| 887 | 887 | (let ((lhs-f-count (length all-lhs-funs)) |
| 888 | (lhs-v-count (1+ (the fixnum (length all-lhs-vars)))) | |
| 889 | ; note this is "wrong" | |
| 890 | (rhs-c-count (length all-rhs-constants)) | |
| 891 | (rhs-f-count (length all-rhs-funs))) | |
| 892 | (declare (type fixnum lhs-f-count lhs-v-count rhs-c-count rhs-f-count)) | |
| 893 | (let ((lhs-f-r (alloc-svec-fixnum lhs-f-count)) | |
| 894 | (lhs-v-r (alloc-svec-fixnum lhs-v-count)) | |
| 895 | (rhs-c-r (alloc-svec-fixnum rhs-c-count)) | |
| 896 | (rhs-f-r (alloc-svec-fixnum rhs-f-count)) | |
| 897 | (lhs-f-ms (AC-list2multi-set all-lhs-funs)) | |
| 898 | (lhs-v-ms (AC-list2multi-set all-lhs-vars)) | |
| 899 | (rhs-c-ms (AC-list2multi-set all-rhs-constants)) | |
| 900 | (rhs-f-ms (AC-list2multi-set all-rhs-funs)) | |
| 901 | (l-m 0) | |
| 902 | (r-m 0)) | |
| 903 | (declare (type #-GCL simple-vector | |
| 904 | #+GCL vector | |
| 905 | lhs-f-r lhs-v-r rhs-c-r rhs-f-r) | |
| 906 | (type fixnum l-m r-m) | |
| 907 | (type list lhs-f-ms lhs-v-ms rhs-c-ms rhs-f-ms)) | |
| 908 | (let* ((l-gcd (or (cdar lhs-f-ms) (cdar lhs-v-ms) 1)) | |
| 909 | (r-gcd (or (cdar rhs-f-ms) (cdar rhs-c-ms) 1)) | |
| 910 | (LHS-f-list (AC-note-repeats lhs-f-ms lhs-f-r l-m l-gcd)) | |
| 911 | (LHS-v-list (cons (cons 'dummy 13) | |
| 912 | (AC-note-repeats lhs-v-ms lhs-v-r l-m l-gcd))) | |
| 913 | (RHS-c-list (AC-note-repeats rhs-c-ms rhs-c-r r-m r-gcd)) | |
| 914 | (RHS-f-list (AC-note-repeats rhs-f-ms rhs-f-r r-m r-gcd))) | |
| 915 | (declare (type fixnum l-gcd r-gcd) | |
| 916 | (type list lhs-f-list lhs-v-list rhs-c-list rhs-f-list)) | |
| 917 | (let ((LHS-f (make-array lhs-f-count :initial-contents lhs-f-list)) | |
| 918 | (LHS-v (make-array lhs-v-count :initial-contents lhs-v-list)) | |
| 919 | (RHS-c (make-array rhs-c-count :initial-contents rhs-c-list)) | |
| 920 | (RHS-f (make-array rhs-f-count :initial-contents rhs-f-list)) | |
| 921 | (RHS-c-max (expt2 (1- lhs-v-count))) | |
| 922 | (RHS-f-max (expt2 (+ -1 lhs-v-count lhs-f-count))) | |
| 923 | (RHS-full-bits (- (expt2 (+ lhs-v-count lhs-f-count)) 2)) | |
| 924 | (rhs-c-sol (alloc-svec-fixnum rhs-c-count)) | |
| 925 | (rhs-f-sol (alloc-svec-fixnum rhs-f-count)) | |
| 926 | (rhs-c-compat (alloc-svec-fixnum rhs-c-count)) | |
| 927 | (rhs-f-compat (alloc-svec-fixnum rhs-f-count)) | |
| 928 | (dummy-bit 1) ; to save a whole bunch of expt'ing | |
| 929 | (lhs-r-mask 0) | |
| 930 | (state (make-ac-state)) | |
| 931 | ) | |
| 932 | (declare (type #-GCL simple-vector | |
| 933 | #+GCL vector | |
| 934 | lhs-f lhs-v rhs-c rhs-f | |
| 935 | rhs-c-sol rhs-f-sol rhs-c-compat rhs-f-compat) | |
| 936 | (type fixnum rhs-c-max rhs-f-max rhs-full-bits | |
| 937 | dummy-bit lhs-r-mask)) | |
| 938 | ;; one more easy failure check | |
| 939 | (when (or (> l-m r-m) ; a lhs item is repeated more than any rhs | |
| 940 | (not (integerp (/ r-gcd l-gcd)))) | |
| 941 | ;; (deallocate-ac-state state) | |
| 942 | ;; (break "2") | |
| 943 | (return-from FAIL (values nil t))) ; FAIL most miserably | |
| 944 | ;; NOW, get down to the real work.... | |
| 945 | ;; setup the repeat mask (first of v's) | |
| 946 | (dotimes (j lhs-v-count) | |
| 947 | (declare (type fixnum j)) | |
| 948 | (when (> (the fixnum (%svref lhs-v-r j)) 1) | |
| 949 | (setq lhs-r-mask (make-or lhs-r-mask dummy-bit)) | |
| 950 | (setq dummy-bit (* 2 dummy-bit)))) | |
| 951 | ;; note dummy-bit might not be 1 here... | |
| 952 | (dotimes (j lhs-f-count) ; (then of f's) | |
| 953 | (declare (type fixnum j)) | |
| 954 | (when (> (the fixnum (%svref lhs-f-r j)) 1) | |
| 955 | (setq lhs-r-mask (make-or lhs-r-mask dummy-bit)) | |
| 956 | (setq dummy-bit (* 2 dummy-bit)))) | |
| 957 | ;; now setup the compatibility bitvectors (for rhs-c) | |
| 958 | (dotimes (i rhs-c-count) | |
| 959 | (declare (type fixnum i)) | |
| 960 | (setq dummy-bit 1) | |
| 961 | (let ((my-repeat-count (%svref rhs-c-r i))) | |
| 962 | (declare (type fixnum my-repeat-count)) | |
| 963 | (dotimes (j lhs-v-count) | |
| 964 | (declare (type fixnum j)) | |
| 965 | (when (and (= (the fixnum (cdr (%svref rhs-c i))) | |
| 966 | (the fixnum (cdr (%svref lhs-v j)))) | |
| 967 | ;; both are from same equation, AND | |
| 968 | (or (= (the fixnum (%svref lhs-v-r j)) | |
| 969 | my-repeat-count) | |
| 970 | ;; the right repetition number OR 0 | |
| 971 | (= (the fixnum (%svref lhs-v-r j)) | |
| 972 | 0))) | |
| 973 | (setf (%svref rhs-c-compat i) | |
| 974 | (make-or (the fixnum (%svref rhs-c-compat i)) | |
| 975 | dummy-bit))) | |
| 976 | (setq dummy-bit (* 2 dummy-bit))))) | |
| 977 | ;; now setup the compatibility bitvectors (for rhs-f) | |
| 978 | (dotimes (i rhs-f-count) | |
| 979 | (declare (type fixnum i)) | |
| 980 | (setq dummy-bit 1) | |
| 981 | (let ((my-repeat-count (%svref rhs-f-r i))) | |
| 982 | (declare (fixnum my-repeat-count)) | |
| 983 | (dotimes (j lhs-v-count) | |
| 984 | (declare (type fixnum j)) | |
| 985 | (when (and (= (the fixnum (cdr (%svref rhs-f i))) | |
| 986 | (the fixnum (cdr (%svref lhs-v j)))) | |
| 987 | ;; both are from same equation, AND | |
| 988 | (or (= (the fixnum (%svref lhs-v-r j)) | |
| 989 | my-repeat-count) | |
| 990 | (= (the fixnum (%svref lhs-v-r j)) | |
| 991 | 0))) | |
| 992 | (setf (%svref rhs-f-compat i) | |
| 993 | (make-or (the fixnum (%svref rhs-f-compat i)) | |
| 994 | dummy-bit))) | |
| 995 | (setq dummy-bit (* 2 dummy-bit))) | |
| 996 | ;; now lhs vars are taken care of, we need to deal with funs | |
| 997 | (dotimes (j lhs-f-count) | |
| 998 | (declare (type fixnum j)) | |
| 999 | ;; for now, ignore repetition of funs (can be slower) | |
| 1000 | (when (and (= (the fixnum (cdr (%svref rhs-f i))) | |
| 1001 | (the fixnum (cdr (%svref lhs-f j)))) | |
| 1002 | ;; both are from same equation, AND | |
| 1003 | (possibly-matches (car (%svref lhs-f j)) | |
| 1004 | (car (%svref rhs-f i)))) | |
| 1005 | (setf (%svref rhs-f-compat i) | |
| 1006 | (make-or (the fixnum (%svref rhs-f-compat i)) | |
| 1007 | dummy-bit))) | |
| 1008 | (setq dummy-bit (* 2 dummy-bit))))) | |
| 1009 | ;; and now set up the initial state to a legal one | |
| 1010 | ;; (the smallest legal one) | |
| 1011 | ;; by just rotating the bit until it make-and's with | |
| 1012 | ;; the compatibility vector | |
| 1013 | (dotimes (i rhs-c-count) | |
| 1014 | (declare (type fixnum i)) | |
| 1015 | (setq dummy-bit 1) | |
| 1016 | (if (and (= i 0) (= rhs-f-count 0)) | |
| 1017 | (setf (%svref rhs-c-sol 0) 1) | |
| 1018 | (let ((my-compat (%svref rhs-c-compat i))) | |
| 1019 | (declare (type fixnum my-compat)) | |
| 1020 | (do () | |
| 1021 | ((> dummy-bit rhs-c-max) | |
| 1022 | (progn | |
| 1023 | ;; (deallocate-ac-state state) | |
| 1024 | ;; (break "3") | |
| 1025 | (return-from FAIL (values nil t)))) | |
| 1026 | (unless (zerop (make-and dummy-bit my-compat)) | |
| 1027 | (setf (%svref rhs-c-sol i) dummy-bit) | |
| 1028 | (return)) | |
| 1029 | (setq dummy-bit (* 2 dummy-bit)))))) | |
| 1030 | (dotimes (i rhs-f-count) | |
| 1031 | (declare (type fixnum i)) | |
| 1032 | (setq dummy-bit 1) | |
| 1033 | (if (= i 0) | |
| 1034 | (setf (%svref rhs-f-sol 0) 1) | |
| 1035 | (let ((my-compat (%svref rhs-f-compat i))) | |
| 1036 | (declare (type fixnum my-compat)) | |
| 1037 | (do () | |
| 1038 | ((> dummy-bit rhs-f-max) | |
| 1039 | (progn ;; (deallocate-ac-state state) | |
| 1040 | ;; (break "4") | |
| 1041 | (return-from FAIL (values nil t)))) | |
| 1042 | (unless (zerop (make-and dummy-bit my-compat)) | |
| 1043 | (setf (%svref rhs-f-sol i) dummy-bit) | |
| 1044 | (return)) | |
| 1045 | (setq dummy-bit (* 2 dummy-bit)))))) | |
| 1046 | ;; initialize the mask - | |
| 1047 | (if (= rhs-f-count 0) | |
| 1048 | (setf (AC-state-LHS-mask state) 0) | |
| 1049 | (let ((temp 0)) | |
| 1050 | (declare (type fixnum temp)) | |
| 1051 | (dotimes (s rhs-c-count) | |
| 1052 | (declare (type fixnum s)) | |
| 1053 | (setq temp (make-or temp (%svref rhs-c-sol s)))) | |
| 1054 | (setf (AC-state-LHS-mask state) temp))) | |
| 1055 | ;; and now stuff the state full of information, and return it. | |
| 1056 | (setf (ac-state-operators state) sys-operators | |
| 1057 | (ac-state-LHS-f state) lhs-f | |
| 1058 | (ac-state-LHS-v state) lhs-v | |
| 1059 | (ac-state-RHS-c state) rhs-c | |
| 1060 | (ac-state-RHS-f state) rhs-f | |
| 1061 | (ac-state-LHS-f-r state) lhs-f-r | |
| 1062 | (ac-state-LHS-v-r state) lhs-v-r | |
| 1063 | (ac-state-RHS-c-r state) rhs-c-r | |
| 1064 | (ac-state-RHS-f-r state) rhs-f-r | |
| 1065 | ;; (setf (ac-state-LHS-mask state) 0) | |
| 1066 | (ac-state-LHS-f-mask state) 0 | |
| 1067 | (ac-state-LHS-r-mask state) lhs-r-mask | |
| 1068 | (ac-state-RHS-c-sol state) rhs-c-sol | |
| 1069 | (ac-state-RHS-c-max state) rhs-c-max | |
| 1070 | (ac-state-RHS-f-sol state) rhs-f-sol | |
| 1071 | (ac-state-RHS-f-max state) rhs-f-max | |
| 1072 | (ac-state-RHS-full-bits state) rhs-full-bits | |
| 1073 | (ac-state-RHS-c-compat state) rhs-c-compat | |
| 1074 | (ac-state-RHS-f-compat state) rhs-f-compat | |
| 1075 | (ac-state-LHS-c-count state) 0 | |
| 1076 | (ac-state-LHS-f-count state) lhs-f-count | |
| 1077 | (ac-state-LHS-v-count state) lhs-v-count ; off 1+ intentionally | |
| 1078 | (ac-state-RHS-c-count state) rhs-c-count | |
| 1079 | (ac-state-RHS-f-count state) rhs-f-count | |
| 1080 | (ac-state-no-more state) nil | |
| 1081 | (ac-state-ac-state-p state) 'ac-state | |
| 1082 | ) | |
| 1083 | ;; | |
| 1084 | (when *match-debug* (format t "~&*** done initialization")) | |
| 1085 | (values state nil)))))))) | |
| 888 | (lhs-v-count (1+ (the fixnum (length all-lhs-vars)))) | |
| 889 | ; note this is "wrong" | |
| 890 | (rhs-c-count (length all-rhs-constants)) | |
| 891 | (rhs-f-count (length all-rhs-funs))) | |
| 892 | (declare (type fixnum lhs-f-count lhs-v-count rhs-c-count rhs-f-count)) | |
| 893 | (let ((lhs-f-r (alloc-svec-fixnum lhs-f-count)) | |
| 894 | (lhs-v-r (alloc-svec-fixnum lhs-v-count)) | |
| 895 | (rhs-c-r (alloc-svec-fixnum rhs-c-count)) | |
| 896 | (rhs-f-r (alloc-svec-fixnum rhs-f-count)) | |
| 897 | (lhs-f-ms (AC-list2multi-set all-lhs-funs)) | |
| 898 | (lhs-v-ms (AC-list2multi-set all-lhs-vars)) | |
| 899 | (rhs-c-ms (AC-list2multi-set all-rhs-constants)) | |
| 900 | (rhs-f-ms (AC-list2multi-set all-rhs-funs)) | |
| 901 | (l-m 0) | |
| 902 | (r-m 0)) | |
| 903 | (declare (type #-GCL simple-vector | |
| 904 | #+GCL vector | |
| 905 | lhs-f-r lhs-v-r rhs-c-r rhs-f-r) | |
| 906 | (type fixnum l-m r-m) | |
| 907 | (type list lhs-f-ms lhs-v-ms rhs-c-ms rhs-f-ms)) | |
| 908 | (let* ((l-gcd (or (cdar lhs-f-ms) (cdar lhs-v-ms) 1)) | |
| 909 | (r-gcd (or (cdar rhs-f-ms) (cdar rhs-c-ms) 1)) | |
| 910 | (LHS-f-list (AC-note-repeats lhs-f-ms lhs-f-r l-m l-gcd)) | |
| 911 | (LHS-v-list (cons (cons 'dummy 13) | |
| 912 | (AC-note-repeats lhs-v-ms lhs-v-r l-m l-gcd))) | |
| 913 | (RHS-c-list (AC-note-repeats rhs-c-ms rhs-c-r r-m r-gcd)) | |
| 914 | (RHS-f-list (AC-note-repeats rhs-f-ms rhs-f-r r-m r-gcd))) | |
| 915 | (declare (type fixnum l-gcd r-gcd) | |
| 916 | (type list lhs-f-list lhs-v-list rhs-c-list rhs-f-list)) | |
| 917 | (let ((LHS-f (make-array lhs-f-count :initial-contents lhs-f-list)) | |
| 918 | (LHS-v (make-array lhs-v-count :initial-contents lhs-v-list)) | |
| 919 | (RHS-c (make-array rhs-c-count :initial-contents rhs-c-list)) | |
| 920 | (RHS-f (make-array rhs-f-count :initial-contents rhs-f-list)) | |
| 921 | (RHS-c-max (expt2 (1- lhs-v-count))) | |
| 922 | (RHS-f-max (expt2 (+ -1 lhs-v-count lhs-f-count))) | |
| 923 | (RHS-full-bits (- (expt2 (+ lhs-v-count lhs-f-count)) 2)) | |
| 924 | (rhs-c-sol (alloc-svec-fixnum rhs-c-count)) | |
| 925 | (rhs-f-sol (alloc-svec-fixnum rhs-f-count)) | |
| 926 | (rhs-c-compat (alloc-svec-fixnum rhs-c-count)) | |
| 927 | (rhs-f-compat (alloc-svec-fixnum rhs-f-count)) | |
| 928 | (dummy-bit 1) ; to save a whole bunch of expt'ing | |
| 929 | (lhs-r-mask 0) | |
| 930 | (state (make-ac-state)) | |
| 931 | ) | |
| 932 | (declare (type #-GCL simple-vector | |
| 933 | #+GCL vector | |
| 934 | lhs-f lhs-v rhs-c rhs-f | |
| 935 | rhs-c-sol rhs-f-sol rhs-c-compat rhs-f-compat) | |
| 936 | (type fixnum rhs-c-max rhs-f-max rhs-full-bits | |
| 937 | dummy-bit lhs-r-mask)) | |
| 938 | ;; one more easy failure check | |
| 939 | (when (or (> l-m r-m) ; a lhs item is repeated more than any rhs | |
| 940 | (not (integerp (/ r-gcd l-gcd)))) | |
| 941 | ;; (deallocate-ac-state state) | |
| 942 | ;; (break "2") | |
| 943 | (return-from FAIL (values nil t))) ; FAIL most miserably | |
| 944 | ;; NOW, get down to the real work.... | |
| 945 | ;; setup the repeat mask (first of v's) | |
| 946 | (dotimes (j lhs-v-count) | |
| 947 | (declare (type fixnum j)) | |
| 948 | (when (> (the fixnum (%svref lhs-v-r j)) 1) | |
| 949 | (setq lhs-r-mask (make-or lhs-r-mask dummy-bit)) | |
| 950 | (setq dummy-bit (* 2 dummy-bit)))) | |
| 951 | ;; note dummy-bit might not be 1 here... | |
| 952 | (dotimes (j lhs-f-count) ; (then of f's) | |
| 953 | (declare (type fixnum j)) | |
| 954 | (when (> (the fixnum (%svref lhs-f-r j)) 1) | |
| 955 | (setq lhs-r-mask (make-or lhs-r-mask dummy-bit)) | |
| 956 | (setq dummy-bit (* 2 dummy-bit)))) | |
| 957 | ;; now setup the compatibility bitvectors (for rhs-c) | |
| 958 | (dotimes (i rhs-c-count) | |
| 959 | (declare (type fixnum i)) | |
| 960 | (setq dummy-bit 1) | |
| 961 | (let ((my-repeat-count (%svref rhs-c-r i))) | |
| 962 | (declare (type fixnum my-repeat-count)) | |
| 963 | (dotimes (j lhs-v-count) | |
| 964 | (declare (type fixnum j)) | |
| 965 | (when (and (= (the fixnum (cdr (%svref rhs-c i))) | |
| 966 | (the fixnum (cdr (%svref lhs-v j)))) | |
| 967 | ;; both are from same equation, AND | |
| 968 | (or (= (the fixnum (%svref lhs-v-r j)) | |
| 969 | my-repeat-count) | |
| 970 | ;; the right repetition number OR 0 | |
| 971 | (= (the fixnum (%svref lhs-v-r j)) | |
| 972 | 0))) | |
| 973 | (setf (%svref rhs-c-compat i) | |
| 974 | (make-or (the fixnum (%svref rhs-c-compat i)) | |
| 975 | dummy-bit))) | |
| 976 | (setq dummy-bit (* 2 dummy-bit))))) | |
| 977 | ;; now setup the compatibility bitvectors (for rhs-f) | |
| 978 | (dotimes (i rhs-f-count) | |
| 979 | (declare (type fixnum i)) | |
| 980 | (setq dummy-bit 1) | |
| 981 | (let ((my-repeat-count (%svref rhs-f-r i))) | |
| 982 | (declare (fixnum my-repeat-count)) | |
| 983 | (dotimes (j lhs-v-count) | |
| 984 | (declare (type fixnum j)) | |
| 985 | (when (and (= (the fixnum (cdr (%svref rhs-f i))) | |
| 986 | (the fixnum (cdr (%svref lhs-v j)))) | |
| 987 | ;; both are from same equation, AND | |
| 988 | (or (= (the fixnum (%svref lhs-v-r j)) | |
| 989 | my-repeat-count) | |
| 990 | (= (the fixnum (%svref lhs-v-r j)) | |
| 991 | 0))) | |
| 992 | (setf (%svref rhs-f-compat i) | |
| 993 | (make-or (the fixnum (%svref rhs-f-compat i)) | |
| 994 | dummy-bit))) | |
| 995 | (setq dummy-bit (* 2 dummy-bit))) | |
| 996 | ;; now lhs vars are taken care of, we need to deal with funs | |
| 997 | (dotimes (j lhs-f-count) | |
| 998 | (declare (type fixnum j)) | |
| 999 | ;; for now, ignore repetition of funs (can be slower) | |
| 1000 | (when (and (= (the fixnum (cdr (%svref rhs-f i))) | |
| 1001 | (the fixnum (cdr (%svref lhs-f j)))) | |
| 1002 | ;; both are from same equation, AND | |
| 1003 | (possibly-matches (car (%svref lhs-f j)) | |
| 1004 | (car (%svref rhs-f i)))) | |
| 1005 | (setf (%svref rhs-f-compat i) | |
| 1006 | (make-or (the fixnum (%svref rhs-f-compat i)) | |
| 1007 | dummy-bit))) | |
| 1008 | (setq dummy-bit (* 2 dummy-bit))))) | |
| 1009 | ;; and now set up the initial state to a legal one | |
| 1010 | ;; (the smallest legal one) | |
| 1011 | ;; by just rotating the bit until it make-and's with | |
| 1012 | ;; the compatibility vector | |
| 1013 | (dotimes (i rhs-c-count) | |
| 1014 | (declare (type fixnum i)) | |
| 1015 | (setq dummy-bit 1) | |
| 1016 | (if (and (= i 0) (= rhs-f-count 0)) | |
| 1017 | (setf (%svref rhs-c-sol 0) 1) | |
| 1018 | (let ((my-compat (%svref rhs-c-compat i))) | |
| 1019 | (declare (type fixnum my-compat)) | |
| 1020 | (do () | |
| 1021 | ((> dummy-bit rhs-c-max) | |
| 1022 | (progn | |
| 1023 | ;; (deallocate-ac-state state) | |
| 1024 | ;; (break "3") | |
| 1025 | (return-from FAIL (values nil t)))) | |
| 1026 | (unless (zerop (make-and dummy-bit my-compat)) | |
| 1027 | (setf (%svref rhs-c-sol i) dummy-bit) | |
| 1028 | (return)) | |
| 1029 | (setq dummy-bit (* 2 dummy-bit)))))) | |
| 1030 | (dotimes (i rhs-f-count) | |
| 1031 | (declare (type fixnum i)) | |
| 1032 | (setq dummy-bit 1) | |
| 1033 | (if (= i 0) | |
| 1034 | (setf (%svref rhs-f-sol 0) 1) | |
| 1035 | (let ((my-compat (%svref rhs-f-compat i))) | |
| 1036 | (declare (type fixnum my-compat)) | |
| 1037 | (do () | |
| 1038 | ((> dummy-bit rhs-f-max) | |
| 1039 | (progn ;; (deallocate-ac-state state) | |
| 1040 | ;; (break "4") | |
| 1041 | (return-from FAIL (values nil t)))) | |
| 1042 | (unless (zerop (make-and dummy-bit my-compat)) | |
| 1043 | (setf (%svref rhs-f-sol i) dummy-bit) | |
| 1044 | (return)) | |
| 1045 | (setq dummy-bit (* 2 dummy-bit)))))) | |
| 1046 | ;; initialize the mask - | |
| 1047 | (if (= rhs-f-count 0) | |
| 1048 | (setf (AC-state-LHS-mask state) 0) | |
| 1049 | (let ((temp 0)) | |
| 1050 | (declare (type fixnum temp)) | |
| 1051 | (dotimes (s rhs-c-count) | |
| 1052 | (declare (type fixnum s)) | |
| 1053 | (setq temp (make-or temp (%svref rhs-c-sol s)))) | |
| 1054 | (setf (AC-state-LHS-mask state) temp))) | |
| 1055 | ;; and now stuff the state full of information, and return it. | |
| 1056 | (setf (ac-state-operators state) sys-operators | |
| 1057 | (ac-state-LHS-f state) lhs-f | |
| 1058 | (ac-state-LHS-v state) lhs-v | |
| 1059 | (ac-state-RHS-c state) rhs-c | |
| 1060 | (ac-state-RHS-f state) rhs-f | |
| 1061 | (ac-state-LHS-f-r state) lhs-f-r | |
| 1062 | (ac-state-LHS-v-r state) lhs-v-r | |
| 1063 | (ac-state-RHS-c-r state) rhs-c-r | |
| 1064 | (ac-state-RHS-f-r state) rhs-f-r | |
| 1065 | ;; (setf (ac-state-LHS-mask state) 0) | |
| 1066 | (ac-state-LHS-f-mask state) 0 | |
| 1067 | (ac-state-LHS-r-mask state) lhs-r-mask | |
| 1068 | (ac-state-RHS-c-sol state) rhs-c-sol | |
| 1069 | (ac-state-RHS-c-max state) rhs-c-max | |
| 1070 | (ac-state-RHS-f-sol state) rhs-f-sol | |
| 1071 | (ac-state-RHS-f-max state) rhs-f-max | |
| 1072 | (ac-state-RHS-full-bits state) rhs-full-bits | |
| 1073 | (ac-state-RHS-c-compat state) rhs-c-compat | |
| 1074 | (ac-state-RHS-f-compat state) rhs-f-compat | |
| 1075 | (ac-state-LHS-c-count state) 0 | |
| 1076 | (ac-state-LHS-f-count state) lhs-f-count | |
| 1077 | (ac-state-LHS-v-count state) lhs-v-count ; off 1+ intentionally | |
| 1078 | (ac-state-RHS-c-count state) rhs-c-count | |
| 1079 | (ac-state-RHS-f-count state) rhs-f-count | |
| 1080 | (ac-state-no-more state) nil | |
| 1081 | (ac-state-ac-state-p state) 'ac-state | |
| 1082 | ) | |
| 1083 | ;; | |
| 1084 | (when *match-debug* (format t "~&*** done initialization")) | |
| 1085 | (values state nil)))))))) | |
| 1086 | 1086 | |
| 1087 | 1087 | (defun match-AC-next-state (state) |
| 1088 | 1088 | (declare (type #+GCL vector #-GCL simple-vector state)) |
| 1093 | 1093 | ||# |
| 1094 | 1094 | (if (not (AC-state-p state)) |
| 1095 | 1095 | (progn (format t "~& AC-Next-State given non-ac-state:~A~&" state) |
| 1096 | (values nil nil t)) ; failing is default behavior... | |
| 1096 | (values nil nil t)) ; failing is default behavior... | |
| 1097 | 1097 | (if (AC-state-no-more state) |
| 1098 | (progn | |
| 1099 | ;; (deallocate-ac-state state) | |
| 1100 | (values nil nil t) ; there are no more solutions - fail | |
| 1101 | ) | |
| 1102 | (do* ((n 0) | |
| 1103 | (rhs-f-sol (AC-state-rhs-f-sol state)) | |
| 1104 | (rhs-f-max (AC-state-rhs-f-max state)) | |
| 1105 | (rhs-f-compat (AC-state-rhs-f-compat state)) | |
| 1106 | (rhs-f-count (AC-state-rhs-f-count state)) | |
| 1107 | (rhs-full-bits (AC-state-rhs-full-bits state)) | |
| 1108 | (lhs-r-mask (AC-state-lhs-r-mask state)) | |
| 1109 | ) | |
| 1110 | (nil) ; forever | |
| 1111 | (declare (type fixnum | |
| 1112 | n rhs-f-count rhs-f-max lhs-r-mask rhs-full-bits) | |
| 1113 | (type #+GCL vector #-GCL simple-vector | |
| 1114 | rhs-f-sol rhs-f-compat)) | |
| 1115 | (cond ((>= n rhs-f-count) ; no next row | |
| 1116 | (AC-next-state-sub state) | |
| 1117 | (if (AC-state-no-more state) | |
| 1118 | (if (and (= 0 (the fixnum (ac-state-LHS-f-count state))) | |
| 1119 | (= 1 (the fixnum (ac-state-LHS-v-count state))) | |
| 1120 | (= 0 (the fixnum (ac-state-RHS-c-count state))) | |
| 1121 | (= 0 (the fixnum (ac-state-RHS-f-count state)))) | |
| 1122 | (let ((sol (AC-solution-from-state state))) | |
| 1123 | (if sol | |
| 1124 | (return (values sol state nil)) | |
| 1125 | (return (values nil nil t)))) | |
| 1126 | (progn | |
| 1127 | ;; failed at f-level | |
| 1128 | ;; (deallocate-ac-state state) | |
| 1129 | (return (values nil nil t))) | |
| 1130 | ) | |
| 1131 | (setq n (1- n)))) | |
| 1132 | ((< n 0) | |
| 1133 | (let ((temp (AC-state-LHS-mask state))) | |
| 1134 | (declare (type fixnum temp)) | |
| 1135 | (dotimes (s rhs-f-count) | |
| 1136 | (declare (type fixnum s)) | |
| 1137 | (setq temp (make-or temp (%svref rhs-f-sol s)))) | |
| 1138 | (if (= rhs-full-bits temp) | |
| 1139 | (let ((sol (AC-solution-from-state state))) | |
| 1140 | (if sol | |
| 1141 | (return (values sol state nil)) | |
| 1142 | (return (match-ac-next-state state)))) | |
| 1143 | (setq n 0)))) | |
| 1144 | ((< (the fixnum (%svref rhs-f-sol n)) rhs-f-max) | |
| 1145 | (AC-Rotate-Left rhs-f-sol n) | |
| 1146 | (when (and ; this is a compatible position for this bit | |
| 1147 | (> (the fixnum (make-and (%svref rhs-f-sol n) | |
| 1148 | (%svref rhs-f-compat n))) | |
| 1149 | 0) | |
| 1150 | ;; either this isnt a repeated term | |
| 1151 | (or (zerop (the fixnum | |
| 1152 | (make-and (%svref rhs-f-sol n) lhs-r-mask))) | |
| 1153 | ;; or it is, and its upper neighbor is home | |
| 1154 | (and (< (1+ n) rhs-f-count) | |
| 1155 | (= (* 2 (the fixnum (%svref rhs-f-sol n))) | |
| 1156 | (the fixnum (%svref rhs-f-sol (1+ n))))))) | |
| 1157 | (setq n (1- n)))) ; then this row is ok, else redo | |
| 1158 | (t ; this row (n) is already maxed | |
| 1159 | (setf (%svref rhs-f-sol n) 1) ; reset this row to one | |
| 1160 | (setq n (1+ n)))))))) | |
| 1098 | (progn | |
| 1099 | ;; (deallocate-ac-state state) | |
| 1100 | (values nil nil t) ; there are no more solutions - fail | |
| 1101 | ) | |
| 1102 | (do* ((n 0) | |
| 1103 | (rhs-f-sol (AC-state-rhs-f-sol state)) | |
| 1104 | (rhs-f-max (AC-state-rhs-f-max state)) | |
| 1105 | (rhs-f-compat (AC-state-rhs-f-compat state)) | |
| 1106 | (rhs-f-count (AC-state-rhs-f-count state)) | |
| 1107 | (rhs-full-bits (AC-state-rhs-full-bits state)) | |
| 1108 | (lhs-r-mask (AC-state-lhs-r-mask state)) | |
| 1109 | ) | |
| 1110 | (nil) ; forever | |
| 1111 | (declare (type fixnum | |
| 1112 | n rhs-f-count rhs-f-max lhs-r-mask rhs-full-bits) | |
| 1113 | (type #+GCL vector #-GCL simple-vector | |
| 1114 | rhs-f-sol rhs-f-compat)) | |
| 1115 | (cond ((>= n rhs-f-count) ; no next row | |
| 1116 | (AC-next-state-sub state) | |
| 1117 | (if (AC-state-no-more state) | |
| 1118 | (if (and (= 0 (the fixnum (ac-state-LHS-f-count state))) | |
| 1119 | (= 1 (the fixnum (ac-state-LHS-v-count state))) | |
| 1120 | (= 0 (the fixnum (ac-state-RHS-c-count state))) | |
| 1121 | (= 0 (the fixnum (ac-state-RHS-f-count state)))) | |
| 1122 | (let ((sol (AC-solution-from-state state))) | |
| 1123 | (if sol | |
| 1124 | (return (values sol state nil)) | |
| 1125 | (return (values nil nil t)))) | |
| 1126 | (progn | |
| 1127 | ;; failed at f-level | |
| 1128 | ;; (deallocate-ac-state state) | |
| 1129 | (return (values nil nil t))) | |
| 1130 | ) | |
| 1131 | (setq n (1- n)))) | |
| 1132 | ((< n 0) | |
| 1133 | (let ((temp (AC-state-LHS-mask state))) | |
| 1134 | (declare (type fixnum temp)) | |
| 1135 | (dotimes (s rhs-f-count) | |
| 1136 | (declare (type fixnum s)) | |
| 1137 | (setq temp (make-or temp (%svref rhs-f-sol s)))) | |
| 1138 | (if (= rhs-full-bits temp) | |
| 1139 | (let ((sol (AC-solution-from-state state))) | |
| 1140 | (if sol | |
| 1141 | (return (values sol state nil)) | |
| 1142 | (return (match-ac-next-state state)))) | |
| 1143 | (setq n 0)))) | |
| 1144 | ((< (the fixnum (%svref rhs-f-sol n)) rhs-f-max) | |
| 1145 | (AC-Rotate-Left rhs-f-sol n) | |
| 1146 | (when (and ; this is a compatible position for this bit | |
| 1147 | (> (the fixnum (make-and (%svref rhs-f-sol n) | |
| 1148 | (%svref rhs-f-compat n))) | |
| 1149 | 0) | |
| 1150 | ;; either this isnt a repeated term | |
| 1151 | (or (zerop (the fixnum | |
| 1152 | (make-and (%svref rhs-f-sol n) lhs-r-mask))) | |
| 1153 | ;; or it is, and its upper neighbor is home | |
| 1154 | (and (< (1+ n) rhs-f-count) | |
| 1155 | (= (* 2 (the fixnum (%svref rhs-f-sol n))) | |
| 1156 | (the fixnum (%svref rhs-f-sol (1+ n))))))) | |
| 1157 | (setq n (1- n)))) ; then this row is ok, else redo | |
| 1158 | (t ; this row (n) is already maxed | |
| 1159 | (setf (%svref rhs-f-sol n) 1) ; reset this row to one | |
| 1160 | (setq n (1+ n)))))))) | |
| 1161 | 1161 | |
| 1162 | 1162 | |
| 1163 | 1163 | #+CMU (declaim (ext:end-block)) |
| 1176 | 1176 | (format t "~&-- LHS-f: ~&") |
| 1177 | 1177 | (map nil #'print-chaos-object (AC-state-LHS-f AC-st)) |
| 1178 | 1178 | (format t "~&-- rhs-c-count=~A, rhs-f-count=~A~&" |
| 1179 | (AC-state-RHS-c-count AC-st) | |
| 1180 | (AC-state-RHS-f-count AC-st)) | |
| 1179 | (AC-state-RHS-c-count AC-st) | |
| 1180 | (AC-state-RHS-f-count AC-st)) | |
| 1181 | 1181 | (format t "~&-- lhs-c-count=~A, lhs-f-count=~A, lhs-v-count=~A~%" |
| 1182 | (AC-state-LHS-c-count AC-st) | |
| 1183 | (AC-state-LHS-f-count AC-st) | |
| 1184 | (AC-state-LHS-v-count AC-st)) | |
| 1182 | (AC-state-LHS-c-count AC-st) | |
| 1183 | (AC-state-LHS-f-count AC-st) | |
| 1184 | (AC-state-LHS-v-count AC-st)) | |
| 1185 | 1185 | (let ((*print-base* 2)) ; these be bitvectors, print them as such |
| 1186 | 1186 | (format t "----------~%-- rhs-c-sol= ~A~&rhs-f-sol=~A~&" |
| 1187 | (AC-state-RHS-c-sol AC-st) (AC-state-RHS-f-sol AC-st)) | |
| 1187 | (AC-state-RHS-c-sol AC-st) (AC-state-RHS-f-sol AC-st)) | |
| 1188 | 1188 | (format t "~&-- rhs-c-max=~A, rhs-f-max=~A, rhs-full-bits=~A~&" |
| 1189 | (AC-state-RHS-c-max AC-st) | |
| 1190 | (AC-state-RHS-f-max AC-st) | |
| 1191 | (AC-state-RHS-full-bits AC-st)) | |
| 1189 | (AC-state-RHS-c-max AC-st) | |
| 1190 | (AC-state-RHS-f-max AC-st) | |
| 1191 | (AC-state-RHS-full-bits AC-st)) | |
| 1192 | 1192 | (format t "~&-- rhs-c-compat=~A, rhs-f-compat=~A~&" |
| 1193 | (AC-state-RHS-c-compat AC-st) | |
| 1194 | (AC-state-RHS-f-compat AC-st)) | |
| 1193 | (AC-state-RHS-c-compat AC-st) | |
| 1194 | (AC-state-RHS-f-compat AC-st)) | |
| 1195 | 1195 | (format t "~&-- rhs-c-r=~A, rhs-f-r=~A~&" |
| 1196 | (AC-state-RHS-c-r AC-st) | |
| 1197 | (AC-state-RHS-f-r AC-st)) | |
| 1196 | (AC-state-RHS-c-r AC-st) | |
| 1197 | (AC-state-RHS-f-r AC-st)) | |
| 1198 | 1198 | (format t "~&-- lhs-f-r=~A, lhs-v-r=~A~&" |
| 1199 | (AC-state-LHS-f-r AC-st) | |
| 1200 | (AC-state-LHS-v-r AC-st)) | |
| 1199 | (AC-state-LHS-f-r AC-st) | |
| 1200 | (AC-state-LHS-v-r AC-st)) | |
| 1201 | 1201 | (format t "~&-- lhs-mask=~A~%" |
| 1202 | (AC-state-LHS-mask AC-st)) | |
| 1202 | (AC-state-LHS-mask AC-st)) | |
| 1203 | 1203 | (terpri) |
| 1204 | 1204 | (format t "~&-- lhs-f-mask=~A~%" |
| 1205 | (AC-state-LHS-f-mask AC-st)) | |
| 1205 | (AC-state-LHS-f-mask AC-st)) | |
| 1206 | 1206 | (format t "~&-- lhs-r-mask=~A~%" |
| 1207 | (AC-state-LHS-r-mask AC-st)) | |
| 1207 | (AC-state-LHS-r-mask AC-st)) | |
| 1208 | 1208 | )) |
| 1209 | 1209 | |
| 1210 | 1210 | (defun ac-args-nss (x) (AC-unparse-AC-state (car x)) (terpri)) |
| 0 | 0 | ;;;-*- Mode:Lisp; Syntax:CommonLisp; Package: CHAOS -*- |
| 1 | 1 | ;;; |
| 2 | ;;; Copyright (c) 2000-2014, Toshimi Sawada. All rights reserved. | |
| 2 | ;;; Copyright (c) 2000-2015, Toshimi Sawada. All rights reserved. | |
| 3 | 3 | ;;; |
| 4 | 4 | ;;; Redistribution and use in source and binary forms, with or without |
| 5 | 5 | ;;; modification, are permitted provided that the following conditions |
| 27 | 27 | ;;; |
| 28 | 28 | (in-package :chaos) |
| 29 | 29 | #|============================================================================== |
| 30 | System:Chaos | |
| 31 | Module:e-match | |
| 32 | File:match-acz.lisp | |
| 30 | System:Chaos | |
| 31 | Module:e-match | |
| 32 | File:match-acz.lisp | |
| 33 | 33 | ==============================================================================|# |
| 34 | 34 | #-:chaos-debug |
| 35 | 35 | (declaim (optimize (safety 3) #-GCL (debug 2))) |
| 47 | 47 | |
| 48 | 48 | #|| |
| 49 | 49 | (defstruct match-ACZ-state |
| 50 | methods ; array[meth] the top level mthods of | |
| 51 | ; each eqn in the system. | |
| 52 | LHS-f ; array[term] functional terms. | |
| 53 | LHS-v ; array[term] variables. | |
| 54 | RHS-c ; array[term] constants. | |
| 55 | RHS-f ; array[term] functional terms. | |
| 56 | LHS-f-r ; array[bool] notes repeated functional | |
| 57 | ; terms. | |
| 58 | LHS-v-r ; array[bool] notes repeated variables. | |
| 59 | RHS-c-r ; array[bool] notes repeated constants. | |
| 60 | RHS-f-r ; array[bool] notes repeated functional | |
| 61 | ; terms. | |
| 62 | (LHS-mask 0) ; long int variables and funs accounted | |
| 63 | ; for by RHS-c-sol. | |
| 64 | (LHS-f-mask 0) ; long int funs accounted for by | |
| 65 | ; RHS-c-sol. | |
| 66 | (LHS-r-mask 0) ; long int bitvector of all repeated | |
| 67 | ; (>0) terms on lhs. | |
| 68 | RHS-c-sol ; array[int] solution matrix constants. | |
| 69 | RHS-c-max ; int max value of elements of | |
| 70 | ; RHS-c-sol. | |
| 71 | RHS-f-sol ; array[int] solution matrix functional | |
| 72 | ; terms. | |
| 73 | RHS-f-max ; int max value of elements of | |
| 74 | ; RHS-f-sol. | |
| 75 | RHS-full-bits ; int 11111...111. | |
| 76 | RHS-c-compat ; array[int] array of compatibility | |
| 77 | ; bitvectors. | |
| 78 | RHS-f-compat ; array[int] array of compatibility | |
| 79 | ; bitvectors. | |
| 80 | LHS-c-count ; int number of constants on LHS after | |
| 81 | ; simplification. | |
| 82 | LHS-f-count ; int number of functions on LHS after | |
| 83 | ; simplification. | |
| 84 | LHS-v-count ; int number of variables on LHS after | |
| 85 | ; simplification. | |
| 86 | RHS-c-count ; int number of constants on RHS after | |
| 87 | ; simplification. | |
| 88 | RHS-f-count ; int number of functions on RHS after | |
| 89 | ; simplification. | |
| 90 | (no-more nil) ; when true implies that all solutions | |
| 91 | ; have been reported. | |
| 50 | methods ; array[meth] the top level mthods of | |
| 51 | ; each eqn in the system. | |
| 52 | LHS-f ; array[term] functional terms. | |
| 53 | LHS-v ; array[term] variables. | |
| 54 | RHS-c ; array[term] constants. | |
| 55 | RHS-f ; array[term] functional terms. | |
| 56 | LHS-f-r ; array[bool] notes repeated functional | |
| 57 | ; terms. | |
| 58 | LHS-v-r ; array[bool] notes repeated variables. | |
| 59 | RHS-c-r ; array[bool] notes repeated constants. | |
| 60 | RHS-f-r ; array[bool] notes repeated functional | |
| 61 | ; terms. | |
| 62 | (LHS-mask 0) ; long int variables and funs accounted | |
| 63 | ; for by RHS-c-sol. | |
| 64 | (LHS-f-mask 0) ; long int funs accounted for by | |
| 65 | ; RHS-c-sol. | |
| 66 | (LHS-r-mask 0) ; long int bitvector of all repeated | |
| 67 | ; (>0) terms on lhs. | |
| 68 | RHS-c-sol ; array[int] solution matrix constants. | |
| 69 | RHS-c-max ; int max value of elements of | |
| 70 | ; RHS-c-sol. | |
| 71 | RHS-f-sol ; array[int] solution matrix functional | |
| 72 | ; terms. | |
| 73 | RHS-f-max ; int max value of elements of | |
| 74 | ; RHS-f-sol. | |
| 75 | RHS-full-bits ; int 11111...111. | |
| 76 | RHS-c-compat ; array[int] array of compatibility | |
| 77 | ; bitvectors. | |
| 78 | RHS-f-compat ; array[int] array of compatibility | |
| 79 | ; bitvectors. | |
| 80 | LHS-c-count ; int number of constants on LHS after | |
| 81 | ; simplification. | |
| 82 | LHS-f-count ; int number of functions on LHS after | |
| 83 | ; simplification. | |
| 84 | LHS-v-count ; int number of variables on LHS after | |
| 85 | ; simplification. | |
| 86 | RHS-c-count ; int number of constants on RHS after | |
| 87 | ; simplification. | |
| 88 | RHS-f-count ; int number of functions on RHS after | |
| 89 | ; simplification. | |
| 90 | (no-more nil) ; when true implies that all solutions | |
| 91 | ; have been reported. | |
| 92 | 92 | ) |
| 93 | 93 | ||# |
| 94 | 94 | |
| 217 | 217 | (defmacro match-ACZ-Rotate-Left (?**array ?**m*) |
| 218 | 218 | "; shifts the element one bit to the left" |
| 219 | 219 | ` (setf (svref ,?**array ,?**m*) |
| 220 | (* 2 (svref ,?**array ,?**m*)))) | |
| 220 | (* 2 (svref ,?**array ,?**m*)))) | |
| 221 | 221 | |
| 222 | 222 | ;;; Puts all repeated terms together in the list, and bashes the array (into |
| 223 | 223 | ;;; numbers) in locations corresponding to the duplicate terms. Returns the |
| 227 | 227 | ;;; |
| 228 | 228 | (defmacro match-ACZ-note-repeats (mset_? array_? max_? gcd_?) |
| 229 | 229 | ` (let* ((list2 nil) |
| 230 | (counter (length (the #+GCL vector #-GCL simple-vector | |
| 231 | ,array_?) | |
| 232 | )) ) | |
| 230 | (counter (length (the #+GCL vector #-GCL simple-vector | |
| 231 | ,array_?) | |
| 232 | )) ) | |
| 233 | 233 | (declare (type list list2) |
| 234 | (type fixnum counter)) | |
| 234 | (type fixnum counter)) | |
| 235 | 235 | (dolist (element ,mset_?) |
| 236 | (declare (type list element)) | |
| 237 | (let ((n (cdr element))) | |
| 238 | (declare (type fixnum n)) | |
| 239 | (when (> n (the fixnum ,max_?)) | |
| 240 | (setq ,max_? n)) | |
| 241 | (setq ,gcd_? (gcd ,gcd_? n)) | |
| 242 | (if (> n 1) ; if it is repeated at all | |
| 243 | (dotimes (xc n) | |
| 244 | (declare (type fixnum xc)) | |
| 245 | (push (first element) list2) | |
| 246 | (setf counter (1- counter)) | |
| 247 | (setf (svref ,array_? counter) | |
| 248 | (1+ xc))) | |
| 249 | (progn (push (first element) list2) | |
| 250 | (setf counter | |
| 251 | (1- counter)) | |
| 252 | (setf (svref ,array_? counter) 0))))) ; this line optional | |
| 253 | list2)) ; (if 0'd array is guaranteed) | |
| 236 | (declare (type list element)) | |
| 237 | (let ((n (cdr element))) | |
| 238 | (declare (type fixnum n)) | |
| 239 | (when (> n (the fixnum ,max_?)) | |
| 240 | (setq ,max_? n)) | |
| 241 | (setq ,gcd_? (gcd ,gcd_? n)) | |
| 242 | (if (> n 1) ; if it is repeated at all | |
| 243 | (dotimes (xc n) | |
| 244 | (declare (type fixnum xc)) | |
| 245 | (push (first element) list2) | |
| 246 | (setf counter (1- counter)) | |
| 247 | (setf (svref ,array_? counter) | |
| 248 | (1+ xc))) | |
| 249 | (progn (push (first element) list2) | |
| 250 | (setf counter | |
| 251 | (1- counter)) | |
| 252 | (setf (svref ,array_? counter) 0))))) ; this line optional | |
| 253 | list2)) ; (if 0'd array is guaranteed) | |
| 254 | 254 | |
| 255 | 255 | ;;; predicate. true if term is term.equational-equal some element of list" |
| 256 | 256 | (defmacro match-ACZ-eq-member (term_!* list_!*) |
| 257 | 257 | ` (dolist ($$_term2 ,list_!*) |
| 258 | 258 | (when (term-equational-equal ,term_!* $$_term2) |
| 259 | (return t)))) | |
| 260 | ||
| 261 | ;;; acz-state-pool | |
| 262 | ||
| 263 | #|| | |
| 264 | (defvar .acz-state-pool. nil) | |
| 265 | ||
| 266 | (defmacro allocate-acz-state () | |
| 267 | ` (if .acz-state-pool. | |
| 268 | (pop .acz-state-pool.) | |
| 269 | (make-match-ACZ-state))) | |
| 270 | ||
| 271 | (defmacro deallocate-acz-state (acz-state) | |
| 272 | `(push ,acz-state .acz-state-pool.)) | |
| 273 | ||
| 274 | (eval-when (:execute :load-toplevel) | |
| 275 | (dotimes (x 20) (push (make-match-ACZ-state) .acz-state-pool.))) | |
| 276 | ||# | |
| 259 | (return t)))) | |
| 277 | 260 | |
| 278 | 261 | (defmacro allocate-acz-state () |
| 279 | 262 | (make-match-ACZ-state)) |
| 280 | 263 | |
| 281 | #|| | |
| 282 | (defmacro deallocate-acz-state (acz-state) | |
| 283 | nil) | |
| 284 | ||# | |
| 285 | ||
| 286 | 264 | #+CMU (declaim (ext:start-block match-acz-state-initialize |
| 287 | match-acz-next-state | |
| 288 | match-acz-equal)) | |
| 265 | match-acz-next-state | |
| 266 | match-acz-equal)) | |
| 289 | 267 | ;;; |
| 290 | 268 | #+CMU |
| 291 | 269 | (defun test_same_term_list (x y) |
| 292 | 270 | (declare (type list x y)) |
| 293 | 271 | (loop (when (null x) (return (null y))) |
| 294 | 272 | (unless (eq (car x) (car y)) |
| 295 | (return nil)) | |
| 273 | (return nil)) | |
| 296 | 274 | (setq x (cdr x)) |
| 297 | (setq y (cdr y)) | |
| 298 | )) | |
| 275 | (setq y (cdr y)))) | |
| 299 | 276 | |
| 300 | 277 | ;;; NOTE this is a version for ACZ-internal use only. |
| 301 | 278 | ;;; it simply takes care of the "from which equation" info. |
| 314 | 291 | (dolist (x list) |
| 315 | 292 | (declare (type term x)) |
| 316 | 293 | (let ((ms-x (dolist (pr ms-list nil) |
| 317 | (when (term-equational-equal x (car pr)) | |
| 318 | (return pr))))) | |
| 319 | (if ms-x | |
| 320 | (setf (cdr ms-x) | |
| 321 | (1+ (cdr ms-x))) | |
| 322 | (push (cons x 1) ms-list)) | |
| 323 | )) | |
| 294 | (when (term-equational-equal x (car pr)) | |
| 295 | (return pr))))) | |
| 296 | (if ms-x | |
| 297 | (setf (cdr ms-x) | |
| 298 | (1+ (cdr ms-x))) | |
| 299 | (push (cons x 1) ms-list)) | |
| 300 | )) | |
| 324 | 301 | ms-list)) |
| 325 | 302 | |
| 326 | 303 | #+CMU |
| 330 | 307 | (copy-alist l2mslv1) |
| 331 | 308 | (if (and l2msla2 (test_same_term_list list l2msla2)) |
| 332 | 309 | (progn |
| 333 | (rotatef l2msla1 l2msla2) | |
| 334 | (rotatef l2mslv1 l2mslv2) | |
| 335 | (copy-alist l2mslv1)) | |
| 310 | (rotatef l2msla1 l2msla2) | |
| 311 | (rotatef l2mslv1 l2mslv2) | |
| 312 | (copy-alist l2mslv1)) | |
| 336 | 313 | (let ((res (list2multi-set-list-direct list))) |
| 337 | 314 | (setq l2msla2 l2msla1 l2mslv2 l2mslv1) |
| 338 | 315 | (setq l2msla1 list l2mslv1 res) |
| 341 | 318 | |
| 342 | 319 | (defun match-ACZ-list2multi-set (list) |
| 343 | 320 | (declare (type list list) |
| 344 | ;; (optimize (speed 3) (safety 0)) | |
| 345 | ) | |
| 321 | ;; (optimize (speed 3) (safety 0)) | |
| 322 | ) | |
| 346 | 323 | (let ((ms-list nil)) |
| 347 | 324 | (declare (type list ms-list)) |
| 348 | 325 | (dolist (x list) |
| 349 | 326 | (let ((ms-elt (assoc-if #'(lambda (y) |
| 350 | (declare (type list y)) | |
| 351 | (and (= (the fixnum (cdr x)) | |
| 352 | (the fixnum (cdr y))) | |
| 353 | (term-equational-equal (car y) (car x)))) | |
| 354 | ms-list))) | |
| 355 | (if ms-elt | |
| 356 | (setf (cdr ms-elt) | |
| 357 | (1+ (cdr ms-elt))) | |
| 358 | (push (cons x 1) ms-list)))) | |
| 327 | (declare (type list y)) | |
| 328 | (and (= (the fixnum (cdr x)) | |
| 329 | (the fixnum (cdr y))) | |
| 330 | (term-equational-equal (car y) (car x)))) | |
| 331 | ms-list))) | |
| 332 | (if ms-elt | |
| 333 | (setf (cdr ms-elt) | |
| 334 | (1+ (cdr ms-elt))) | |
| 335 | (push (cons x 1) ms-list)))) | |
| 359 | 336 | ms-list)) |
| 360 | 337 | |
| 361 | 338 | #+CMU |
| 364 | 341 | (if (null y) |
| 365 | 342 | 'none |
| 366 | 343 | (if (term-equational-equal x (caar y)) |
| 367 | (cdr y) | |
| 368 | (let ((last y) (rest (cdr y))) | |
| 369 | (loop (when (null rest) (return 'none)) | |
| 370 | (when (term-equational-equal x (caar rest)) | |
| 371 | ;; delete pattern | |
| 372 | (rplacd last (cdr rest)) | |
| 373 | ;; new | |
| 374 | (return y)) | |
| 375 | (setq last rest rest (cdr rest)))) | |
| 376 | )) | |
| 344 | (cdr y) | |
| 345 | (let ((last y) (rest (cdr y))) | |
| 346 | (loop (when (null rest) (return 'none)) | |
| 347 | (when (term-equational-equal x (caar rest)) | |
| 348 | ;; delete pattern | |
| 349 | (rplacd last (cdr rest)) | |
| 350 | ;; new | |
| 351 | (return y)) | |
| 352 | (setq last rest rest (cdr rest)))) | |
| 353 | )) | |
| 377 | 354 | ) |
| 378 | 355 | |
| 379 | 356 | ;;; check for multi-set equality |
| 381 | 358 | ;;; |
| 382 | 359 | (defun match-ACZ-ms-equal (x y) |
| 383 | 360 | (declare (type list x y) |
| 384 | ;; (optimize (speed 3) (safety 0)) | |
| 385 | ) | |
| 361 | ;; (optimize (speed 3) (safety 0)) | |
| 362 | ) | |
| 386 | 363 | (block the-end |
| 387 | 364 | (let ((ydone 0) |
| 388 | (ylength (length y))) | |
| 365 | (ylength (length y))) | |
| 389 | 366 | (declare (type fixnum ydone ylength)) |
| 390 | 367 | ;; |
| 391 | 368 | (dolist (xe x) |
| 392 | (let ((xterm (car xe)) (xval (cdr xe))) | |
| 393 | (declare (type term xterm) | |
| 394 | (type fixnum xval)) | |
| 395 | (dolist (ye y (return-from the-end nil)) ; didn't find xe in y | |
| 396 | (when (term-equational-equal xterm (car ye)) | |
| 397 | (unless (= xval (the fixnum (cdr ye))) | |
| 398 | (return-from the-end nil)) | |
| 399 | (incf ydone) | |
| 400 | (return))))) ; quit the inner do-list | |
| 369 | (let ((xterm (car xe)) (xval (cdr xe))) | |
| 370 | (declare (type term xterm) | |
| 371 | (type fixnum xval)) | |
| 372 | (dolist (ye y (return-from the-end nil)) ; didn't find xe in y | |
| 373 | (when (term-equational-equal xterm (car ye)) | |
| 374 | (unless (= xval (the fixnum (cdr ye))) | |
| 375 | (return-from the-end nil)) | |
| 376 | (incf ydone) | |
| 377 | (return))))) ; quit the inner do-list | |
| 401 | 378 | (unless (= ydone ylength) |
| 402 | (return-from the-end nil))) | |
| 379 | (return-from the-end nil))) | |
| 403 | 380 | t)) |
| 404 | 381 | |
| 405 | 382 | ;;; |
| 407 | 384 | ;;; |
| 408 | 385 | (defun match-ACZ-equal (t1 t2) |
| 409 | 386 | (declare (type term t1 t2) |
| 410 | ;; (optimize (speed 3) (safety 0)) | |
| 411 | ) | |
| 387 | ;; (optimize (speed 3) (safety 0)) | |
| 388 | ) | |
| 412 | 389 | (if (term-is-applform? t2) |
| 413 | 390 | (let ((op (term-method t1))) |
| 414 | (declare (type method op)) | |
| 415 | (if (method-is-of-same-operator op (term-head t2)) | |
| 416 | (match-ACZ-ms-equal | |
| 417 | (list2multi-set-list (list-ACZ-subterms t1 op)) | |
| 418 | (list2multi-set-list (list-ACZ-subterms t2 op))) | |
| 419 | nil)) | |
| 391 | (declare (type method op)) | |
| 392 | (if (method-is-of-same-operator op (term-head t2)) | |
| 393 | (match-ACZ-ms-equal | |
| 394 | (list2multi-set-list (list-ACZ-subterms t1 op)) | |
| 395 | (list2multi-set-list (list-ACZ-subterms t2 op))) | |
| 396 | nil)) | |
| 420 | 397 | nil)) |
| 421 | 398 | |
| 422 | 399 | ;;; op match-ACZ-make-term : Operator List Of Term |
| 424 | 401 | ;;; |
| 425 | 402 | (defun match-ACZ-make-term (op list) |
| 426 | 403 | (declare (type method op) |
| 427 | (type list list) | |
| 428 | ;; (optimize (speed 3) (safety 0)) | |
| 429 | ) | |
| 404 | (type list list) | |
| 405 | ;; (optimize (speed 3) (safety 0)) | |
| 406 | ) | |
| 430 | 407 | (if (null list) |
| 431 | 408 | (term-make-zero op) |
| 432 | 409 | (if (null (cdr list)) |
| 433 | (car list) | |
| 434 | (make-term-with-sort-check | |
| 435 | op (list (car list) (match-ACZ-make-term op (cdr list))))))) | |
| 410 | (car list) | |
| 411 | (make-term-with-sort-check | |
| 412 | op (list (car list) (match-ACZ-make-term op (cdr list))))))) | |
| 436 | 413 | |
| 437 | 414 | ;;; given an match-ACZ-state, produce a solution (system of equations |
| 438 | 415 | ;;; which, if true, imply the original ACZ equation true) from |
| 443 | 420 | (defun match-ACZ-solution-from-state (state) |
| 444 | 421 | ;; (declare (optimize (speed 3) (safety 0))) |
| 445 | 422 | (let* ((ops (match-ACZ-state-methods state)) |
| 446 | (lhs-f (match-ACZ-state-lhs-f state)) | |
| 447 | (lhs-v (match-ACZ-state-lhs-v state)) | |
| 448 | (rhs-c (match-ACZ-state-rhs-c state)) | |
| 449 | (rhs-f (match-ACZ-state-rhs-f state)) | |
| 450 | (rhs-c-sol (match-ACZ-state-rhs-c-sol state)) | |
| 451 | (rhs-f-sol (match-ACZ-state-rhs-f-sol state)) | |
| 452 | (new-sys (new-m-system)) | |
| 453 | (term-code 1) | |
| 454 | (rhs-subterms nil) | |
| 455 | (made-zero nil)) | |
| 423 | (lhs-f (match-ACZ-state-lhs-f state)) | |
| 424 | (lhs-v (match-ACZ-state-lhs-v state)) | |
| 425 | (rhs-c (match-ACZ-state-rhs-c state)) | |
| 426 | (rhs-f (match-ACZ-state-rhs-f state)) | |
| 427 | (rhs-c-sol (match-ACZ-state-rhs-c-sol state)) | |
| 428 | (rhs-f-sol (match-ACZ-state-rhs-f-sol state)) | |
| 429 | (new-sys (new-m-system)) | |
| 430 | (term-code 1) | |
| 431 | (rhs-subterms nil) | |
| 432 | (made-zero nil)) | |
| 456 | 433 | (declare (type #-GCL simple-vector |
| 457 | #+GCL vector | |
| 458 | lhs-f lhs-v rhs-c rhs-f) | |
| 459 | (type list rhs-subterms) | |
| 460 | (type #-GCL simple-vector | |
| 461 | #+GCL vector | |
| 462 | ops rhs-c-sol rhs-f-sol) | |
| 463 | (type fixnum term-code)) | |
| 434 | #+GCL vector | |
| 435 | lhs-f lhs-v rhs-c rhs-f) | |
| 436 | (type list rhs-subterms) | |
| 437 | (type #-GCL simple-vector | |
| 438 | #+GCL vector | |
| 439 | ops rhs-c-sol rhs-f-sol) | |
| 440 | (type fixnum term-code)) | |
| 464 | 441 | ;; |
| 465 | 442 | (setq *acz-failure-pat* nil) |
| 466 | 443 | ;; (match-ACZ-collapse-arrays-internal lhs-v 1) |
| 467 | 444 | (let ((new-eqs nil)) |
| 468 | 445 | (dotimes (i (length lhs-v)) |
| 469 | (declare (type fixnum i)) | |
| 470 | (if (< i 1) | |
| 471 | nil | |
| 472 | (let ((ith-var (svref lhs-v i))) | |
| 473 | (setq rhs-subterms nil) | |
| 474 | (setq term-code (* 2 term-code)) | |
| 475 | ;; (match-ACZ-collapse-one-array-internal rhs-c-sol rhs-c) | |
| 476 | (dotimes (j (length rhs-c-sol)) | |
| 477 | (declare (type fixnum j)) | |
| 478 | (when (> (make-and (svref rhs-c-sol j) | |
| 479 | term-code) | |
| 480 | 0) | |
| 481 | (push (car (svref rhs-c j)) rhs-subterms))) | |
| 482 | ;; (match-ACZ-collapse-one-array-internal rhs-f-sol rhs-f) | |
| 483 | (dotimes (j (length rhs-f-sol)) | |
| 484 | (declare (type fixnum j)) | |
| 485 | (when (> (make-and (svref rhs-f-sol j) | |
| 486 | term-code) | |
| 487 | 0) | |
| 488 | (push (car (svref rhs-f j)) rhs-subterms))) | |
| 489 | ;; | |
| 490 | (if (null rhs-subterms) | |
| 491 | (let ((zero (term-make-zero (svref ops (cdr | |
| 492 | ith-var))))) | |
| 493 | (when zero | |
| 494 | (setq made-zero t) | |
| 495 | (push (make-equation (car ith-var) zero) new-eqs))) | |
| 496 | (push (make-equation (car ith-var) | |
| 497 | (if (cdr rhs-subterms) | |
| 498 | ;; implies length is | |
| 499 | ;; greater than 1 | |
| 500 | (make-right-assoc-normal-form-with-sort-check | |
| 501 | (svref ops (cdr ith-var)) | |
| 502 | rhs-subterms) | |
| 503 | (first rhs-subterms))) | |
| 504 | new-eqs)) | |
| 505 | ))) | |
| 446 | (declare (type fixnum i)) | |
| 447 | (if (< i 1) | |
| 448 | nil | |
| 449 | (let ((ith-var (svref lhs-v i))) | |
| 450 | (setq rhs-subterms nil) | |
| 451 | (setq term-code (* 2 term-code)) | |
| 452 | ;; (match-ACZ-collapse-one-array-internal rhs-c-sol rhs-c) | |
| 453 | (dotimes (j (length rhs-c-sol)) | |
| 454 | (declare (type fixnum j)) | |
| 455 | (when (> (make-and (svref rhs-c-sol j) | |
| 456 | term-code) | |
| 457 | 0) | |
| 458 | (push (car (svref rhs-c j)) rhs-subterms))) | |
| 459 | ;; (match-ACZ-collapse-one-array-internal rhs-f-sol rhs-f) | |
| 460 | (dotimes (j (length rhs-f-sol)) | |
| 461 | (declare (type fixnum j)) | |
| 462 | (when (> (make-and (svref rhs-f-sol j) | |
| 463 | term-code) | |
| 464 | 0) | |
| 465 | (push (car (svref rhs-f j)) rhs-subterms))) | |
| 466 | ;; | |
| 467 | (if (null rhs-subterms) | |
| 468 | (let ((zero (term-make-zero (svref ops (cdr | |
| 469 | ith-var))))) | |
| 470 | (when zero | |
| 471 | (setq made-zero t) | |
| 472 | (push (make-equation (car ith-var) zero) new-eqs))) | |
| 473 | (push (make-equation (car ith-var) | |
| 474 | (if (cdr rhs-subterms) | |
| 475 | ;; implies length is | |
| 476 | ;; greater than 1 | |
| 477 | (make-right-assoc-normal-form-with-sort-check | |
| 478 | (svref ops (cdr ith-var)) | |
| 479 | rhs-subterms) | |
| 480 | (first rhs-subterms))) | |
| 481 | new-eqs)) | |
| 482 | ))) | |
| 506 | 483 | ;; note term-code is now the right thing. |
| 507 | 484 | ;; (match-ACZ-collapse-arrays-internal lhs-f 0) |
| 508 | 485 | (dotimes (i (length lhs-f)) |
| 509 | (declare (type fixnum i)) | |
| 510 | (let ((ith-f (svref lhs-f i))) | |
| 511 | ;; (?zero (term-make-zero (svref ops (cdr ith-f)))) | |
| 512 | (setq rhs-subterms nil) | |
| 513 | (setq term-code (* 2 term-code)) | |
| 514 | ;; (match-ACZ-collapse-one-array-internal rhs-c-sol rhs-c) | |
| 515 | (dotimes (j (length rhs-c-sol)) | |
| 516 | (declare (type fixnum j)) | |
| 517 | (when (> (the fixnum | |
| 518 | (make-and (svref rhs-c-sol j) | |
| 519 | term-code)) | |
| 520 | 0) | |
| 521 | (push (car (svref rhs-c j)) rhs-subterms))) | |
| 522 | ;; (match-ACZ-collapse-one-array-internal rhs-f-sol rhs-f) | |
| 523 | (dotimes (j (length rhs-f-sol)) | |
| 524 | (declare (type fixnum j)) | |
| 525 | (when (> (the fixnum (make-and (svref rhs-f-sol j) | |
| 526 | term-code)) | |
| 527 | 0) | |
| 528 | (push (car (svref rhs-f j)) rhs-subterms))) | |
| 529 | (if (null rhs-subterms) | |
| 530 | (let ((?zero (term-make-zero (svref ops (cdr ith-f))))) | |
| 531 | (if (and ?zero (method-is-of-same-operator+ | |
| 532 | (term-head ?zero) | |
| 533 | (term-head (car ith-f)))) | |
| 534 | (progn | |
| 535 | (setq made-zero t) | |
| 536 | (push (make-equation (car ith-f) ?zero) new-eqs)) | |
| 537 | ;; | |
| 538 | (progn | |
| 539 | (setq *acz-failure-pat* | |
| 540 | (cons (car ith-f) ?zero)) | |
| 541 | (setq new-eqs nil) (return nil)))) | |
| 542 | (let ((t1 (car ith-f)) | |
| 543 | (t2 (if (cdr rhs-subterms) | |
| 544 | ;; implies length is greater than 1 | |
| 545 | (make-right-assoc-normal-form-with-sort-check | |
| 546 | (svref ops (cdr ith-f)) | |
| 547 | rhs-subterms) | |
| 548 | (first rhs-subterms)))) | |
| 549 | ;; | |
| 550 | (let ((t1-head (term-head t1)) | |
| 551 | (t2-head (term-head t2))) | |
| 552 | (if (method-is-of-same-operator+ t1-head t2-head) | |
| 553 | (push (make-equation t1 t2) new-eqs) | |
| 554 | (let ((minfo-1 (method-theory-info-for-matching | |
| 555 | t1-head)) | |
| 556 | (minfo-2 (method-theory-info-for-matching | |
| 557 | t2-head))) | |
| 558 | (if (or (test-theory | |
| 559 | .z. (theory-info-code minfo-1)) | |
| 560 | (test-theory | |
| 561 | .z. (theory-info-code minfo-2))) | |
| 562 | (push (make-equation t1 t2) new-eqs) | |
| 563 | (progn (setq new-eqs nil) | |
| 564 | (setq *acz-failure-pat* (cons t1 t2)) | |
| 565 | (return nil)) | |
| 566 | )))) | |
| 567 | )))) | |
| 486 | (declare (type fixnum i)) | |
| 487 | (let ((ith-f (svref lhs-f i))) | |
| 488 | ;; (?zero (term-make-zero (svref ops (cdr ith-f)))) | |
| 489 | (setq rhs-subterms nil) | |
| 490 | (setq term-code (* 2 term-code)) | |
| 491 | ;; (match-ACZ-collapse-one-array-internal rhs-c-sol rhs-c) | |
| 492 | (dotimes (j (length rhs-c-sol)) | |
| 493 | (declare (type fixnum j)) | |
| 494 | (when (> (the fixnum | |
| 495 | (make-and (svref rhs-c-sol j) | |
| 496 | term-code)) | |
| 497 | 0) | |
| 498 | (push (car (svref rhs-c j)) rhs-subterms))) | |
| 499 | ;; (match-ACZ-collapse-one-array-internal rhs-f-sol rhs-f) | |
| 500 | (dotimes (j (length rhs-f-sol)) | |
| 501 | (declare (type fixnum j)) | |
| 502 | (when (> (the fixnum (make-and (svref rhs-f-sol j) | |
| 503 | term-code)) | |
| 504 | 0) | |
| 505 | (push (car (svref rhs-f j)) rhs-subterms))) | |
| 506 | (if (null rhs-subterms) | |
| 507 | (let ((?zero (term-make-zero (svref ops (cdr ith-f))))) | |
| 508 | (if (and ?zero (method-is-of-same-operator+ | |
| 509 | (term-head ?zero) | |
| 510 | (term-head (car ith-f)))) | |
| 511 | (progn | |
| 512 | (setq made-zero t) | |
| 513 | (push (make-equation (car ith-f) ?zero) new-eqs)) | |
| 514 | ;; | |
| 515 | (progn | |
| 516 | (setq *acz-failure-pat* | |
| 517 | (cons (car ith-f) ?zero)) | |
| 518 | (setq new-eqs nil) (return nil)))) | |
| 519 | (let ((t1 (car ith-f)) | |
| 520 | (t2 (if (cdr rhs-subterms) | |
| 521 | ;; implies length is greater than 1 | |
| 522 | (make-right-assoc-normal-form-with-sort-check | |
| 523 | (svref ops (cdr ith-f)) | |
| 524 | rhs-subterms) | |
| 525 | (first rhs-subterms)))) | |
| 526 | ;; | |
| 527 | (let ((t1-head (term-head t1)) | |
| 528 | (t2-head (term-head t2))) | |
| 529 | (if (method-is-of-same-operator+ t1-head t2-head) | |
| 530 | (push (make-equation t1 t2) new-eqs) | |
| 531 | (let ((minfo-1 (method-theory-info-for-matching | |
| 532 | t1-head)) | |
| 533 | (minfo-2 (method-theory-info-for-matching | |
| 534 | t2-head))) | |
| 535 | (if (or (test-theory | |
| 536 | .z. (theory-info-code minfo-1)) | |
| 537 | (test-theory | |
| 538 | .z. (theory-info-code minfo-2))) | |
| 539 | (push (make-equation t1 t2) new-eqs) | |
| 540 | (progn (setq new-eqs nil) | |
| 541 | (setq *acz-failure-pat* (cons t1 t2)) | |
| 542 | (return nil)) | |
| 543 | )))) | |
| 544 | )))) | |
| 568 | 545 | ;; |
| 569 | 546 | (if new-eqs |
| 570 | (progn | |
| 571 | (dolist (eq (nreverse new-eqs)) | |
| 572 | (add-equation-to-m-system new-sys eq)) | |
| 573 | (when *match-debug* | |
| 574 | (format t "~%*** acz solution: ") | |
| 575 | (print-m-system new-sys) | |
| 576 | (format t "~%***") | |
| 577 | ) | |
| 578 | (values new-sys made-zero)) | |
| 579 | (progn | |
| 580 | (when *match-debug* | |
| 581 | (format t "~%*** no possible solution in this case") | |
| 582 | (print-next) | |
| 583 | (princ "t1 = ") (term-print (car *acz-failure-pat*)) | |
| 584 | (print-next) | |
| 585 | (princ "t2 = ") (term-print (cdr *acz-failure-pat*)) | |
| 586 | ) | |
| 587 | (values nil nil))) | |
| 588 | ))) | |
| 547 | (progn | |
| 548 | (dolist (eq (nreverse new-eqs)) | |
| 549 | (add-equation-to-m-system new-sys eq)) | |
| 550 | (when *match-debug* | |
| 551 | (format t "~%*** acz solution: ") | |
| 552 | (print-m-system new-sys) | |
| 553 | (format t "~%***")) | |
| 554 | (values new-sys made-zero)) | |
| 555 | (progn | |
| 556 | (with-match-debug() | |
| 557 | (format t "~%***[acz] no possible solution in this case") | |
| 558 | (print-next) | |
| 559 | (princ "t1 = ") (term-print (car *acz-failure-pat*)) | |
| 560 | (print-next) | |
| 561 | (princ "t2 = ") (term-print (cdr *acz-failure-pat*))) | |
| 562 | (values nil nil)))))) | |
| 589 | 563 | |
| 590 | 564 | |
| 591 | 565 | ;;; ACZ State Intialization |
| 597 | 571 | |
| 598 | 572 | (defun match-ACZ-state-initialize (sys env) |
| 599 | 573 | (declare (type list sys env)) |
| 574 | (with-match-debug () | |
| 575 | (format t "~%** match-acz-state-initialize -------------------------------------") | |
| 576 | (print-next) | |
| 577 | (print-match-system-sys sys) | |
| 578 | (print-next) | |
| 579 | (print-match-system-env env)) | |
| 600 | 580 | (block TOP |
| 601 | 581 | (let ((eqn-number -1) |
| 602 | (sys-methods (alloc-svec (length sys))) | |
| 603 | (all-lhs-vars nil) | |
| 604 | (all-lhs-funs nil) | |
| 605 | (all-rhs-constants nil) | |
| 606 | (all-rhs-funs nil) | |
| 607 | (*print-circle* nil)) | |
| 582 | (sys-methods (alloc-svec (length sys))) | |
| 583 | (all-lhs-vars nil) | |
| 584 | (all-lhs-funs nil) | |
| 585 | (all-rhs-constants nil) | |
| 586 | (all-rhs-funs nil) | |
| 587 | (*print-circle* nil)) | |
| 608 | 588 | (declare (type fixnum eqn-number) |
| 609 | #-GCL (type simple-vector sys-methods) | |
| 610 | #+GCL (type vector sys-methods) | |
| 611 | (type list all-lhs-vars all-lhs-funs all-rhs-constants | |
| 612 | all-rhs-funs)) | |
| 589 | #-GCL (type simple-vector sys-methods) | |
| 590 | #+GCL (type vector sys-methods) | |
| 591 | (type list all-lhs-vars all-lhs-funs all-rhs-constants | |
| 592 | all-rhs-funs)) | |
| 613 | 593 | (dolist (equation sys) |
| 614 | (setf eqn-number | |
| 615 | (1+ eqn-number)) | |
| 616 | (let* ((lhs-1 (equation-t1 equation)) | |
| 617 | (rhs-1 (equation-t2 equation)) | |
| 618 | (lh-meth (term-method lhs-1)) | |
| 619 | (rhs-meth (if (and (term-is-applform? rhs-1) | |
| 620 | (not (term-is-builtin-constant? rhs-1))) | |
| 621 | (term-method rhs-1) | |
| 622 | nil)) | |
| 623 | (lhs-2 (list-ACZ-subterms lhs-1 lh-meth)) | |
| 624 | (rhs-2 | |
| 625 | (if (and rhs-meth | |
| 626 | (method-is-AC-restriction-of rhs-meth lh-meth)) | |
| 627 | (list-ACZ-subterms rhs-1 rhs-meth) | |
| 628 | (list rhs-1))) | |
| 629 | (lhs-vars nil) | |
| 630 | (lhs-constants nil) | |
| 631 | (lhs-funs nil) | |
| 632 | (rhs-constants nil) | |
| 633 | (rhs-funs nil) | |
| 634 | ) | |
| 635 | (declare (type term rhs-1 rhs-1) | |
| 636 | (type method lh-meth) | |
| 637 | (type (or null method) rhs-meth) | |
| 638 | (type list lhs-2 rhs-2 lhs-vars lhs-constants lhs-funs | |
| 639 | rhs-constants rhs-funs)) | |
| 640 | ;; | |
| 641 | (setf (svref sys-methods eqn-number) lh-meth) | |
| 642 | ;; quick failure cases of AC do Not apply to ACZ | |
| 643 | ;; build lhs- vars/funs/constants | |
| 644 | (dolist (term lhs-2) | |
| 645 | ;; for each subterm of lhs | |
| 646 | ;; note: unit elements are already eliminated from lhs-2. | |
| 647 | ;; | |
| 648 | (cond ((term-is-variable? term) | |
| 649 | (let ((image (if env (environment-image env term) term))) | |
| 650 | (cond ((null image) | |
| 651 | (push (cons term eqn-number) lhs-vars)) | |
| 652 | ((term-is-variable? image) | |
| 653 | (push (cons image eqn-number) lhs-vars)) | |
| 654 | ((term-is-constant? image) | |
| 655 | (push (cons image eqn-number) lhs-constants)) | |
| 656 | ((method-is-AC-restriction-of lh-meth | |
| 657 | (term-method image)) | |
| 658 | (dolist (term2 (list-ACZ-subterms | |
| 659 | image (term-head image))) | |
| 660 | (cond ((term-is-variable? term2) | |
| 661 | (push (cons term2 eqn-number) | |
| 662 | lhs-vars)) | |
| 663 | ((term-is-constant? term2) | |
| 664 | (push (cons term2 eqn-number) | |
| 665 | lhs-constants)) | |
| 666 | (t (push (cons term2 eqn-number) | |
| 667 | lhs-funs))))) | |
| 668 | (t (push (cons image eqn-number) lhs-funs))))) | |
| 669 | ((term-is-constant? term) | |
| 670 | #|| term can never be a unit. <- list-acz-subterms. | |
| 671 | (unless (term-is-zero-for-method term lh-meth) | |
| 672 | (push (cons term eqn-number) lhs-constants)) | |
| 673 | ||# | |
| 674 | (push (cons term eqn-number) lhs-constants) | |
| 675 | ) | |
| 676 | (t (push (cons term eqn-number) lhs-funs)))) | |
| 677 | ;; | |
| 678 | ;; now that the lhs is partitioned - lets play with the rhs | |
| 679 | ;; | |
| 680 | (dolist (term rhs-2) | |
| 681 | (cond ((term-is-variable? term) | |
| 682 | (push (cons term eqn-number) rhs-constants)) | |
| 683 | ((term-is-constant? term) | |
| 684 | (unless (term-is-zero-for-method term lh-meth) | |
| 685 | (let ((new (delete-one-term term lhs-constants))) | |
| 686 | (if (eq 'none new) | |
| 687 | (push (cons term eqn-number) rhs-constants) | |
| 688 | (if (eq new :never-match) | |
| 689 | (if lhs-vars | |
| 690 | (push (cons term eqn-number) rhs-constants) | |
| 691 | (return-from TOP (values nil t))) | |
| 692 | (setq lhs-constants new)))))) | |
| 693 | (t (let ((new (delete-one-term term lhs-funs))) | |
| 694 | (if (eq 'none new) | |
| 695 | (push (cons term eqn-number) rhs-funs) | |
| 696 | (if (eq new :never-match) | |
| 697 | (if lhs-vars | |
| 698 | (push (cons term eqn-number) rhs-funs) | |
| 699 | (return-from TOP (values nil t))) | |
| 700 | (setq lhs-funs new))))))) | |
| 701 | ;; now there are no duplicates (things appearing on both sides) | |
| 702 | (let ((lhs-c-count (length lhs-constants)) | |
| 703 | (lhs-f-count (length lhs-funs)) | |
| 704 | (lhs-v-count (length lhs-vars)) | |
| 705 | (rhs-c-count (length rhs-constants)) | |
| 706 | (rhs-f-count (length rhs-funs)) | |
| 707 | ) | |
| 708 | (declare (type fixnum lhs-c-count lhs-f-count lhs-v-count | |
| 709 | rhs-c-count rhs-f-count)) | |
| 710 | ;; check trivial failure conditions | |
| 711 | (when (or (> lhs-c-count 0) ; a const without anything to match it | |
| 712 | (and (< lhs-v-count 1) ; no variables remain on lhs | |
| 713 | (> rhs-c-count 0)) ; and constants remain on rhs | |
| 714 | (> lhs-f-count rhs-f-count)) ; too many funs to match | |
| 715 | ;; this assumption may be dubius in ACZ --- can arbitrary | |
| 716 | ;; funs eventually reduce to identity? | |
| 717 | (return-from TOP (values nil t))) ; FAIL most miserably | |
| 718 | (setq all-lhs-funs (nconc lhs-funs all-lhs-funs)) | |
| 719 | (setq all-lhs-vars (nconc lhs-vars all-lhs-vars)) | |
| 720 | (setq all-rhs-constants (nconc rhs-constants all-rhs-constants)) | |
| 721 | (setq all-rhs-funs (nconc rhs-funs all-rhs-funs))))) | |
| 594 | (setf eqn-number (1+ eqn-number)) | |
| 595 | (let* ((lhs-1 (equation-t1 equation)) | |
| 596 | (rhs-1 (equation-t2 equation)) | |
| 597 | (lh-meth (term-method lhs-1)) | |
| 598 | (rhs-meth (if (term-is-applform? rhs-1) | |
| 599 | (term-method rhs-1) | |
| 600 | nil)) | |
| 601 | (lhs-2 (list-ACZ-subterms lhs-1 lh-meth)) | |
| 602 | (rhs-2 (if (and rhs-meth | |
| 603 | (method-is-AC-restriction-of rhs-meth lh-meth)) | |
| 604 | (list-ACZ-subterms rhs-1 rhs-meth) | |
| 605 | (list rhs-1))) | |
| 606 | (lhs-vars nil) | |
| 607 | (lhs-constants nil) | |
| 608 | (lhs-funs nil) | |
| 609 | (rhs-constants nil) | |
| 610 | (rhs-funs nil)) | |
| 611 | (declare (type term rhs-1 rhs-1) | |
| 612 | (type method lh-meth) | |
| 613 | (type (or null method) rhs-meth) | |
| 614 | (type list lhs-2 rhs-2 lhs-vars | |
| 615 | lhs-constants lhs-funs | |
| 616 | rhs-constants rhs-funs)) | |
| 617 | ;; | |
| 618 | (setf (svref sys-methods eqn-number) lh-meth) | |
| 619 | ;; quick failure cases of AC do Not apply to ACZ | |
| 620 | ;; build lhs- vars/funs/constants | |
| 621 | (dolist (term lhs-2) | |
| 622 | ;; for each subterm of lhs | |
| 623 | ;; note: unit elements are already eliminated from lhs-2. | |
| 624 | (cond ((term-is-variable? term) | |
| 625 | (let ((image (if env (environment-image env term) term))) | |
| 626 | (cond ((null image) | |
| 627 | (push (cons term eqn-number) lhs-vars)) | |
| 628 | ((term-is-variable? image) | |
| 629 | (push (cons image eqn-number) lhs-vars)) | |
| 630 | ((term-is-constant? image) | |
| 631 | (push (cons image eqn-number) lhs-constants)) | |
| 632 | ((method-is-AC-restriction-of lh-meth | |
| 633 | (term-method image)) | |
| 634 | (dolist (term2 (list-ACZ-subterms image (term-head image))) | |
| 635 | (cond ((term-is-variable? term2) | |
| 636 | (push (cons term2 eqn-number) | |
| 637 | lhs-vars)) | |
| 638 | ((term-is-constant? term2) | |
| 639 | (push (cons term2 eqn-number) | |
| 640 | lhs-constants)) | |
| 641 | (t (push (cons term2 eqn-number) | |
| 642 | lhs-funs))))) | |
| 643 | (t (push (cons image eqn-number) lhs-funs))))) | |
| 644 | ((term-is-constant? term) | |
| 645 | #|| term can never be a unit. <- list-acz-subterms. | |
| 646 | (unless (term-is-zero-for-method term lh-meth) | |
| 647 | (push (cons term eqn-number) lhs-constants)) | |
| 648 | ||# | |
| 649 | (push (cons term eqn-number) lhs-constants) | |
| 650 | ) | |
| 651 | (t (push (cons term eqn-number) lhs-funs)))) | |
| 652 | (with-match-debug () | |
| 653 | (format t "~%[acz] lhs-funs = ~d, lhs-constants = ~d, lhs-vars = ~d" | |
| 654 | (length lhs-funs) (length lhs-constants) (length lhs-vars)) | |
| 655 | (format t "~%[acz] lhs-funs") | |
| 656 | (dolist (lf lhs-funs) | |
| 657 | (print lf)) | |
| 658 | (format t "~%[acz] lhs-constants") | |
| 659 | (dolist (lc lhs-constants) | |
| 660 | (print lc)) | |
| 661 | (format t "~%[acz] lhs-vars") | |
| 662 | (dolist (lv lhs-vars) | |
| 663 | (print lv))) | |
| 664 | ;; | |
| 665 | ;; now that the lhs is partitioned - lets play with the rhs | |
| 666 | ;; | |
| 667 | (dolist (term rhs-2) | |
| 668 | (cond ((term-is-variable? term) | |
| 669 | (push (cons term eqn-number) rhs-constants)) | |
| 670 | ((term-is-constant? term) | |
| 671 | (unless (term-is-zero-for-method term lh-meth) | |
| 672 | (let ((new (delete-one-term term lhs-constants))) | |
| 673 | (if (eq 'none new) | |
| 674 | (push (cons term eqn-number) rhs-constants) | |
| 675 | (if (eq new :never-match) | |
| 676 | (if lhs-vars | |
| 677 | (push (cons term eqn-number) rhs-constants) | |
| 678 | (progn | |
| 679 | (with-match-debug () | |
| 680 | (format t "~%++ :never-match 1")) | |
| 681 | (return-from TOP (values nil t)))) | |
| 682 | (setq lhs-constants new)))))) | |
| 683 | (t (let ((new (delete-one-term term lhs-funs))) | |
| 684 | (if (eq 'none new) | |
| 685 | (push (cons term eqn-number) rhs-funs) | |
| 686 | (if (eq new :never-match) | |
| 687 | (if lhs-vars | |
| 688 | (push (cons term eqn-number) rhs-funs) | |
| 689 | (progn | |
| 690 | (with-match-debug () | |
| 691 | (format t "~%++ :never-match 2")) | |
| 692 | (return-from TOP (values nil t)))) | |
| 693 | (setq lhs-funs new))))))) | |
| 694 | ;; now there are no duplicates (things appearing on both sides) | |
| 695 | (let ((lhs-c-count (length lhs-constants)) | |
| 696 | (lhs-f-count (length lhs-funs)) | |
| 697 | (lhs-v-count (length lhs-vars)) | |
| 698 | (rhs-c-count (length rhs-constants)) | |
| 699 | (rhs-f-count (length rhs-funs))) | |
| 700 | (declare (type fixnum lhs-c-count lhs-f-count lhs-v-count | |
| 701 | rhs-c-count rhs-f-count)) | |
| 702 | ;; check trivial failure conditions | |
| 703 | (when (or (> lhs-c-count 0) ; a const without anything to match it | |
| 704 | (and (< lhs-v-count 1) ; no variables remain on lhs | |
| 705 | (> rhs-c-count 0)) ; and constants remain on rhs | |
| 706 | (> lhs-f-count rhs-f-count)) ; too many funs to match | |
| 707 | ;; this assumption may be dubius in ACZ --- can arbitrary | |
| 708 | ;; funs eventually reduce to identity? | |
| 709 | (with-match-debug () | |
| 710 | (format t "~%++ fail exit 1")) | |
| 711 | (return-from TOP (values nil t))) ; FAIL most miserably | |
| 712 | (setq all-lhs-funs (nconc lhs-funs all-lhs-funs)) | |
| 713 | (setq all-lhs-vars (nconc lhs-vars all-lhs-vars)) | |
| 714 | (setq all-rhs-constants (nconc rhs-constants all-rhs-constants)) | |
| 715 | (setq all-rhs-funs (nconc rhs-funs all-rhs-funs))))) | |
| 722 | 716 | ;; we are now done with all equations. |
| 723 | 717 | ;; NOTE that we have now gathered all equations into one giant morass |
| 724 | (cond ((and (null all-lhs-funs) ; nothing left, all formulas removed | |
| 725 | (null all-lhs-vars)) | |
| 726 | (if (and (null all-rhs-constants) ; this is rare | |
| 727 | (null all-rhs-funs)) | |
| 728 | (return-from TOP (values (make-trivial-match-ACZ-state | |
| 729 | :sys (new-m-system)) nil)) | |
| 730 | (return-from TOP (values nil t)))) | |
| 731 | ;; maybe check for more simple cases, like one-var vs the world. | |
| 732 | ((and *use-one-var-opt* | |
| 733 | (null all-lhs-funs) ; only one var left on lhs | |
| 734 | (null (cdr all-lhs-vars))) | |
| 735 | (let ((fresh-sys (new-m-system))) | |
| 736 | (add-equation-to-m-system fresh-sys | |
| 737 | (make-equation | |
| 738 | (caar all-lhs-vars) | |
| 739 | (match-ACZ-make-term | |
| 740 | (svref sys-methods | |
| 741 | (cdar all-lhs-vars)) | |
| 742 | (nconc all-rhs-constants | |
| 743 | all-rhs-funs)))) | |
| 744 | (return-from TOP (values (make-trivial-match-ACZ-state :sys fresh-sys) | |
| 745 | nil)))) | |
| 746 | (t | |
| 747 | (let* ((lhs-f-count (length all-lhs-funs)) | |
| 748 | (lhs-v-count (1+ (length all-lhs-vars))) ; note this is "wrong" | |
| 749 | ;; (lhs-v-count (length all-lhs-vars)) | |
| 750 | (rhs-c-count (length all-rhs-constants)) | |
| 751 | (rhs-f-count (length all-rhs-funs)) | |
| 752 | (lhs-f-r (alloc-svec-fixnum lhs-f-count)) | |
| 753 | (lhs-v-r (alloc-svec-fixnum lhs-v-count)) | |
| 754 | (rhs-c-r (alloc-svec-fixnum rhs-c-count)) | |
| 755 | (rhs-f-r (alloc-svec-fixnum rhs-f-count)) | |
| 756 | (LHS-f-ms (match-ACZ-list2multi-set all-lhs-funs)) ; expensive. | |
| 757 | (LHS-v-ms (match-ACZ-list2multi-set all-lhs-vars)) ; expensive. | |
| 758 | (RHS-c-ms (match-ACZ-list2multi-set all-rhs-constants)) ; expensive. | |
| 759 | (RHS-f-ms (match-ACZ-list2multi-set all-rhs-funs)) ; expensive. | |
| 760 | (l-f-m 0) ; TCW 14 Mar 91 mods associated with this var | |
| 761 | (l-v-m 0) ; note this is not used | |
| 762 | (r-m 0) | |
| 763 | (l-gcd (or (cdar lhs-f-ms) (cdar lhs-v-ms) 1)) | |
| 764 | (r-gcd (or (cdar rhs-f-ms) (cdar rhs-c-ms) 1)) | |
| 765 | (LHS-f-list (match-ACZ-note-repeats lhs-f-ms lhs-f-r l-f-m l-gcd)) | |
| 766 | ||
| 767 | (LHS-v-list (cons (cons 'if-this-appears-youve-lost 999) | |
| 768 | (match-ACZ-note-repeats lhs-v-ms lhs-v-r l-v-m l-gcd))) | |
| 769 | ||
| 770 | (RHS-c-list (match-ACZ-note-repeats rhs-c-ms rhs-c-r r-m r-gcd)) | |
| 771 | (RHS-f-list (match-ACZ-note-repeats rhs-f-ms rhs-f-r r-m r-gcd)) | |
| 772 | (LHS-f (make-array lhs-f-count :initial-contents lhs-f-list)) | |
| 773 | (LHS-v (make-array lhs-v-count :initial-contents lhs-v-list)) | |
| 774 | (RHS-c (make-array rhs-c-count :initial-contents rhs-c-list)) | |
| 775 | (RHS-f (make-array rhs-f-count :initial-contents rhs-f-list)) | |
| 776 | (RHS-c-max (expt2 (1- lhs-v-count))) | |
| 777 | (RHS-f-max (expt2 (+ -1 lhs-v-count lhs-f-count))) | |
| 778 | (RHS-full-bits (- (expt2 (+ lhs-v-count lhs-f-count)) 2)) | |
| 779 | (rhs-c-sol (alloc-svec-fixnum rhs-c-count)) | |
| 780 | (rhs-f-sol (alloc-svec-fixnum rhs-f-count)) | |
| 781 | (rhs-c-compat (alloc-svec-fixnum rhs-c-count)) | |
| 782 | (rhs-f-compat (alloc-svec-fixnum rhs-f-count)) | |
| 783 | (dummy-bit 1) ; to save a whole bunch of expt'ing | |
| 784 | (lhs-r-mask 0) | |
| 785 | (state (make-match-ACZ-state)) | |
| 786 | ) | |
| 787 | (declare (type #-GCL simple-vector | |
| 788 | #+GCL vector | |
| 789 | lhs-f-r lhs-v-r rhs-c-r rhs-f-r | |
| 790 | rhs-c-sol rhs-f-sol | |
| 791 | rhs-c-compat rhs-f-compat) | |
| 792 | (type #-GCL simple-vector | |
| 793 | #+GCL vector | |
| 794 | lhs-f lhs-v rhs-c rhs-f) | |
| 795 | (type fixnum | |
| 796 | rhs-c-max rhs-f-max rhs-full-bits | |
| 797 | lhs-f-count lhs-v-count rhs-c-count rhs-f-count | |
| 798 | dummy-bit lhs-r-mask l-gcd r-gcd l-f-m r-m)) | |
| 799 | ;;(declare (ignore l-v-m)) not strictly true | |
| 800 | ;; one more easy failure check | |
| 801 | ;; TCW 14 Mar 91 need to restrict this for ACZ | |
| 802 | (when (or (> l-f-m r-m) ; a lhs item is repeated more than any rhs | |
| 803 | (not (integerp (/ r-gcd l-gcd)))) | |
| 804 | ;; (deallocate-acz-state state) | |
| 805 | (return-from TOP (values nil t))) ; FAIL most miserably | |
| 806 | ;; NOW, get down to the real work.... | |
| 807 | ;; setup the repeat mask (first of v's) | |
| 808 | (dotimes (j lhs-v-count) | |
| 809 | (declare (type fixnum j)) | |
| 810 | (when (> (the fixnum (svref lhs-v-r j)) 1) | |
| 811 | (setq lhs-r-mask (make-or lhs-r-mask dummy-bit)) | |
| 812 | (setq dummy-bit (* 2 dummy-bit)))) | |
| 813 | ;; note dummy-bit might not be 1 here... | |
| 814 | (dotimes (j lhs-f-count) ; (then of f's) | |
| 815 | (declare (type fixnum j)) | |
| 816 | (when (> (the fixnum (svref lhs-f-r j)) 1) | |
| 817 | (setq lhs-r-mask (make-or lhs-r-mask dummy-bit)) | |
| 818 | (setq dummy-bit (* 2 dummy-bit)))) | |
| 819 | ;; now setup the compatibility bitvectors (for rhs-c) | |
| 820 | (dotimes (i rhs-c-count) | |
| 821 | (declare (type fixnum i)) | |
| 822 | (setq dummy-bit 1) | |
| 823 | (let ((my-repeat-count (svref rhs-c-r i))) | |
| 824 | (declare (fixnum my-repeat-count)) | |
| 825 | (dotimes (j lhs-v-count) | |
| 826 | (declare (type fixnum j)) | |
| 827 | (when (and (= (the fixnum (cdr (svref rhs-c i))) | |
| 828 | (the fixnum (cdr (svref lhs-v j)))) | |
| 829 | ;; both are from same equation, AND | |
| 830 | (or (= (the fixnum (svref lhs-v-r j)) | |
| 831 | my-repeat-count) | |
| 832 | ;; the right repetition number OR 0 | |
| 833 | (= (the fixnum (svref lhs-v-r j)) | |
| 834 | 0))) | |
| 835 | (setf (svref rhs-c-compat i) | |
| 836 | (make-or (svref rhs-c-compat i) | |
| 837 | dummy-bit))) | |
| 838 | (setq dummy-bit (* 2 dummy-bit))))) | |
| 839 | ;; now setup the compatibility bitvectors (for rhs-f) | |
| 840 | (dotimes (i rhs-f-count) | |
| 841 | (declare (type fixnum i)) | |
| 842 | (setq dummy-bit 1) | |
| 843 | (let ((my-repeat-count (svref rhs-f-r i))) | |
| 844 | (declare (fixnum my-repeat-count)) | |
| 845 | (dotimes (j lhs-v-count) | |
| 846 | (declare (type fixnum j)) | |
| 847 | (when (and (= (the fixnum (cdr (svref rhs-f i))) | |
| 848 | (the fixnum (cdr (svref lhs-v j)))) | |
| 849 | ;; both are from same equation, AND | |
| 850 | (or (= (the fixnum (svref lhs-v-r j)) | |
| 851 | my-repeat-count) | |
| 852 | (= (the fixnum (svref lhs-v-r j)) | |
| 853 | 0))) | |
| 854 | (setf (svref rhs-f-compat i) | |
| 855 | (make-or (svref rhs-f-compat i) | |
| 856 | dummy-bit))) | |
| 857 | (setq dummy-bit (* 2 dummy-bit))) | |
| 858 | ;; now lhs vars are taken care of, we need to deal with funs | |
| 859 | (dotimes (j lhs-f-count) | |
| 860 | (declare (type fixnum j)) | |
| 861 | ;; for now, ignore repetition of funs (can be slower) | |
| 862 | (when (and (= (the fixnum (cdr (svref rhs-f i))) | |
| 863 | (the fixnum (cdr (svref lhs-f j)))) | |
| 864 | ;; both are from same equation, AND | |
| 865 | (possibly-matches (car (svref lhs-f j)) | |
| 866 | (car (svref rhs-f i)))) | |
| 867 | (setf (svref rhs-f-compat i) | |
| 868 | (make-or (svref rhs-f-compat i) | |
| 869 | dummy-bit))) | |
| 870 | (setq dummy-bit (* 2 dummy-bit))))) | |
| 871 | ;; and now set up the initial state to a legal one (the smallest | |
| 872 | ;; legal one) | |
| 873 | ;; by just rotating the bit until it make-and's with the | |
| 874 | ;; compatibility vector | |
| 875 | (dotimes (i rhs-c-count) | |
| 876 | (declare (type fixnum i)) | |
| 877 | (setq dummy-bit 1) | |
| 878 | (if (and (= i 0) (= rhs-f-count 0)) | |
| 879 | (setf (svref rhs-c-sol 0) 1) | |
| 880 | (let ((my-compat (svref rhs-c-compat i))) | |
| 881 | (declare (type fixnum my-compat)) | |
| 882 | (do () | |
| 883 | ((> dummy-bit rhs-c-max) | |
| 884 | (progn ;; (deallocate-acz-state state) | |
| 885 | (return-from TOP (values nil t)))) | |
| 886 | (unless (zerop (make-and dummy-bit my-compat)) | |
| 887 | (setf (svref rhs-c-sol i) dummy-bit) | |
| 888 | (return)) | |
| 889 | (setq dummy-bit (* 2 dummy-bit)))))) | |
| 890 | (dotimes (i rhs-f-count) | |
| 891 | (declare (type fixnum i)) | |
| 892 | (setq dummy-bit 1) | |
| 893 | (if (= i 0) | |
| 894 | (setf (svref rhs-f-sol 0) 1) | |
| 895 | (let ((my-compat (svref rhs-f-compat i))) | |
| 896 | (declare (type fixnum my-compat)) | |
| 897 | (do () | |
| 898 | ((> dummy-bit rhs-f-max) | |
| 899 | (progn | |
| 900 | ;; (deallocate-acz-state state) | |
| 901 | (return-from TOP (values nil t)))) | |
| 902 | (unless (zerop (make-and dummy-bit my-compat)) | |
| 903 | (setf (svref rhs-f-sol i) dummy-bit) | |
| 904 | (return)) | |
| 905 | (setq dummy-bit (* 2 dummy-bit)))))) | |
| 906 | ||
| 907 | ;; initialize the mask - | |
| 908 | (if (= rhs-f-count 0) | |
| 909 | (setf (match-ACZ-state-LHS-mask state) 0) | |
| 910 | (let ((temp 0)) | |
| 911 | (declare (type fixnum temp)) | |
| 912 | (dotimes (s rhs-c-count) | |
| 913 | (declare (type fixnum s)) | |
| 914 | (setq temp (make-or temp | |
| 915 | (svref rhs-c-sol s)))) | |
| 916 | (setf (match-ACZ-state-LHS-mask state) temp))) | |
| 917 | ||
| 918 | ;; and now stuff the state full of information, and return it. | |
| 919 | (setf (match-ACZ-state-methods state) sys-methods) | |
| 920 | (setf (match-ACZ-state-LHS-f state) lhs-f) | |
| 921 | (setf (match-ACZ-state-LHS-v state) lhs-v) | |
| 922 | (setf (match-ACZ-state-RHS-c state) rhs-c) | |
| 923 | (setf (match-ACZ-state-RHS-f state) rhs-f) | |
| 924 | (setf (match-ACZ-state-LHS-f-r state) lhs-f-r) | |
| 925 | (setf (match-ACZ-state-LHS-v-r state) lhs-v-r) | |
| 926 | (setf (match-ACZ-state-RHS-c-r state) rhs-c-r) | |
| 927 | (setf (match-ACZ-state-RHS-f-r state) rhs-f-r) | |
| 928 | ;; (setf (match-ACZ-state-LHS-mask state) 0) | |
| 929 | (setf (match-ACZ-state-LHS-f-mask state) 0) | |
| 930 | (setf (match-ACZ-state-LHS-r-mask state) lhs-r-mask) | |
| 931 | (setf (match-ACZ-state-RHS-c-sol state) rhs-c-sol) | |
| 932 | (setf (match-ACZ-state-RHS-c-max state) rhs-c-max) | |
| 933 | (setf (match-ACZ-state-RHS-f-sol state) rhs-f-sol) | |
| 934 | (setf (match-ACZ-state-RHS-f-max state) rhs-f-max) | |
| 935 | (setf (match-ACZ-state-RHS-full-bits state) rhs-full-bits) | |
| 936 | (setf (match-ACZ-state-RHS-c-compat state) rhs-c-compat) | |
| 937 | (setf (match-ACZ-state-RHS-f-compat state) rhs-f-compat) | |
| 938 | (setf (match-ACZ-state-LHS-c-count state) 0) | |
| 939 | (setf (match-ACZ-state-LHS-f-count state) lhs-f-count) | |
| 940 | (setf (match-ACZ-state-LHS-v-count state) lhs-v-count) | |
| 941 | ; off 1+ intentionally | |
| 942 | (setf (match-ACZ-state-RHS-c-count state) rhs-c-count) | |
| 943 | (setf (match-ACZ-state-RHS-f-count state) rhs-f-count) | |
| 944 | (setf (match-ACZ-state-no-more state) nil) | |
| 945 | (setf (match-ACZ-state-acz-state-p state) 'acz-state) | |
| 946 | ;; | |
| 947 | (when *match-debug* | |
| 948 | (format t "~&acz-init: state=~&") | |
| 949 | (match-ACZ-unparse-match-ACZ-state state)) | |
| 950 | ;; | |
| 951 | (values state nil))))))) | |
| 952 | ||
| 953 | #|| | |
| 954 | ||
| 955 | (defun match-ACZ-state-initialize (sys env) | |
| 956 | (match-AC-state-initialize sys env :have-unit)) | |
| 957 | ||# | |
| 958 | ||
| 718 | (cond ((and (null all-lhs-funs) ; nothing left, all formulas removed | |
| 719 | (null all-lhs-vars)) | |
| 720 | (if (and (null all-rhs-constants) ; this is rare | |
| 721 | (null all-rhs-funs)) | |
| 722 | (progn | |
| 723 | (with-match-debug () | |
| 724 | (format t "~%++ done 1")) | |
| 725 | (return-from TOP (values (make-trivial-match-ACZ-state :sys (new-m-system)) | |
| 726 | nil))) | |
| 727 | (progn | |
| 728 | (with-match-debug () | |
| 729 | (format t "~%++ nomatch done 1")) | |
| 730 | (return-from TOP (values nil t))))) | |
| 731 | ;; maybe check for more simple cases, like one-var vs the world. | |
| 732 | ((and *use-one-var-opt* | |
| 733 | (null all-lhs-funs) ; only one var left on lhs | |
| 734 | (null (cdr all-lhs-vars))) | |
| 735 | (let ((fresh-sys (new-m-system))) | |
| 736 | (add-equation-to-m-system fresh-sys | |
| 737 | (make-equation | |
| 738 | (caar all-lhs-vars) | |
| 739 | (match-ACZ-make-term | |
| 740 | (svref sys-methods | |
| 741 | (cdar all-lhs-vars)) | |
| 742 | (nconc all-rhs-constants | |
| 743 | all-rhs-funs)))) | |
| 744 | (with-match-debug () | |
| 745 | (format t "~%++ done 2")) | |
| 746 | (return-from TOP (values (make-trivial-match-ACZ-state :sys fresh-sys) nil)))) | |
| 747 | (t | |
| 748 | (let* ((lhs-f-count (length all-lhs-funs)) | |
| 749 | (lhs-v-count (1+ (length all-lhs-vars))) ; note this is "wrong" | |
| 750 | ;; (lhs-v-count (length all-lhs-vars)) | |
| 751 | (rhs-c-count (length all-rhs-constants)) | |
| 752 | (rhs-f-count (length all-rhs-funs)) | |
| 753 | (lhs-f-r (alloc-svec-fixnum lhs-f-count)) | |
| 754 | (lhs-v-r (alloc-svec-fixnum lhs-v-count)) | |
| 755 | (rhs-c-r (alloc-svec-fixnum rhs-c-count)) | |
| 756 | (rhs-f-r (alloc-svec-fixnum rhs-f-count)) | |
| 757 | (LHS-f-ms (match-ACZ-list2multi-set all-lhs-funs)) ; expensive. | |
| 758 | (LHS-v-ms (match-ACZ-list2multi-set all-lhs-vars)) ; expensive. | |
| 759 | (RHS-c-ms (match-ACZ-list2multi-set all-rhs-constants)) ; expensive. | |
| 760 | (RHS-f-ms (match-ACZ-list2multi-set all-rhs-funs)) ; expensive. | |
| 761 | (l-f-m 0) ; TCW 14 Mar 91 mods associated with this var | |
| 762 | (l-v-m 0) ; note this is not used | |
| 763 | (r-m 0) | |
| 764 | (l-gcd (or (cdar lhs-f-ms) (cdar lhs-v-ms) 1)) | |
| 765 | (r-gcd (or (cdar rhs-f-ms) (cdar rhs-c-ms) 1)) | |
| 766 | (LHS-f-list (match-ACZ-note-repeats lhs-f-ms lhs-f-r l-f-m l-gcd)) | |
| 767 | ||
| 768 | (LHS-v-list (cons (cons 'if-this-appears-youve-lost 999) | |
| 769 | (match-ACZ-note-repeats lhs-v-ms lhs-v-r l-v-m l-gcd))) | |
| 770 | ||
| 771 | (RHS-c-list (match-ACZ-note-repeats rhs-c-ms rhs-c-r r-m r-gcd)) | |
| 772 | (RHS-f-list (match-ACZ-note-repeats rhs-f-ms rhs-f-r r-m r-gcd)) | |
| 773 | (LHS-f (make-array lhs-f-count :initial-contents lhs-f-list)) | |
| 774 | (LHS-v (make-array lhs-v-count :initial-contents lhs-v-list)) | |
| 775 | (RHS-c (make-array rhs-c-count :initial-contents rhs-c-list)) | |
| 776 | (RHS-f (make-array rhs-f-count :initial-contents rhs-f-list)) | |
| 777 | (RHS-c-max (expt2 (1- lhs-v-count))) | |
| 778 | (RHS-f-max (expt2 (+ -1 lhs-v-count lhs-f-count))) | |
| 779 | (RHS-full-bits (- (expt2 (+ lhs-v-count lhs-f-count)) 2)) | |
| 780 | (rhs-c-sol (alloc-svec-fixnum rhs-c-count)) | |
| 781 | (rhs-f-sol (alloc-svec-fixnum rhs-f-count)) | |
| 782 | (rhs-c-compat (alloc-svec-fixnum rhs-c-count)) | |
| 783 | (rhs-f-compat (alloc-svec-fixnum rhs-f-count)) | |
| 784 | (dummy-bit 1) ; to save a whole bunch of expt'ing | |
| 785 | (lhs-r-mask 0) | |
| 786 | (state (make-match-ACZ-state)) | |
| 787 | ) | |
| 788 | (declare (type #-GCL simple-vector | |
| 789 | #+GCL vector | |
| 790 | lhs-f-r lhs-v-r rhs-c-r rhs-f-r | |
| 791 | rhs-c-sol rhs-f-sol | |
| 792 | rhs-c-compat rhs-f-compat) | |
| 793 | (type #-GCL simple-vector | |
| 794 | #+GCL vector | |
| 795 | lhs-f lhs-v rhs-c rhs-f) | |
| 796 | (type fixnum | |
| 797 | rhs-c-max rhs-f-max rhs-full-bits | |
| 798 | lhs-f-count lhs-v-count rhs-c-count rhs-f-count | |
| 799 | dummy-bit lhs-r-mask l-gcd r-gcd l-f-m r-m)) | |
| 800 | ;;(declare (ignore l-v-m)) not strictly true | |
| 801 | ;; one more easy failure check | |
| 802 | ;; TCW 14 Mar 91 need to restrict this for ACZ | |
| 803 | (when (or (> l-f-m r-m) ; a lhs item is repeated more than any rhs | |
| 804 | (not (integerp (/ r-gcd l-gcd)))) | |
| 805 | (with-match-debug () | |
| 806 | (format t "~%++ nomatch done 4")) | |
| 807 | (return-from TOP (values nil t))) ; FAIL most miserably | |
| 808 | ;; NOW, get down to the real work.... | |
| 809 | ;; setup the repeat mask (first of v's) | |
| 810 | (dotimes (j lhs-v-count) | |
| 811 | (declare (type fixnum j)) | |
| 812 | (when (> (the fixnum (svref lhs-v-r j)) 1) | |
| 813 | (setq lhs-r-mask (make-or lhs-r-mask dummy-bit)) | |
| 814 | (setq dummy-bit (* 2 dummy-bit)))) | |
| 815 | ;; note dummy-bit might not be 1 here... | |
| 816 | (dotimes (j lhs-f-count) ; (then of f's) | |
| 817 | (declare (type fixnum j)) | |
| 818 | (when (> (the fixnum (svref lhs-f-r j)) 1) | |
| 819 | (setq lhs-r-mask (make-or lhs-r-mask dummy-bit)) | |
| 820 | (setq dummy-bit (* 2 dummy-bit)))) | |
| 821 | ;; now setup the compatibility bitvectors (for rhs-c) | |
| 822 | (dotimes (i rhs-c-count) | |
| 823 | (declare (type fixnum i)) | |
| 824 | (setq dummy-bit 1) | |
| 825 | (let ((my-repeat-count (svref rhs-c-r i))) | |
| 826 | (declare (fixnum my-repeat-count)) | |
| 827 | (dotimes (j lhs-v-count) | |
| 828 | (declare (type fixnum j)) | |
| 829 | (when (and (= (the fixnum (cdr (svref rhs-c i))) | |
| 830 | (the fixnum (cdr (svref lhs-v j)))) | |
| 831 | ;; both are from same equation, AND | |
| 832 | (or (= (the fixnum (svref lhs-v-r j)) | |
| 833 | my-repeat-count) | |
| 834 | ;; the right repetition number OR 0 | |
| 835 | (= (the fixnum (svref lhs-v-r j)) | |
| 836 | 0))) | |
| 837 | (setf (svref rhs-c-compat i) | |
| 838 | (make-or (svref rhs-c-compat i) | |
| 839 | dummy-bit))) | |
| 840 | (setq dummy-bit (* 2 dummy-bit))))) | |
| 841 | ;; now setup the compatibility bitvectors (for rhs-f) | |
| 842 | (dotimes (i rhs-f-count) | |
| 843 | (declare (type fixnum i)) | |
| 844 | (setq dummy-bit 1) | |
| 845 | (let ((my-repeat-count (svref rhs-f-r i))) | |
| 846 | (declare (fixnum my-repeat-count)) | |
| 847 | (dotimes (j lhs-v-count) | |
| 848 | (declare (type fixnum j)) | |
| 849 | (when (and (= (the fixnum (cdr (svref rhs-f i))) | |
| 850 | (the fixnum (cdr (svref lhs-v j)))) | |
| 851 | ;; both are from same equation, AND | |
| 852 | (or (= (the fixnum (svref lhs-v-r j)) | |
| 853 | my-repeat-count) | |
| 854 | (= (the fixnum (svref lhs-v-r j)) | |
| 855 | 0))) | |
| 856 | (setf (svref rhs-f-compat i) | |
| 857 | (make-or (svref rhs-f-compat i) | |
| 858 | dummy-bit))) | |
| 859 | (setq dummy-bit (* 2 dummy-bit))) | |
| 860 | ;; now lhs vars are taken care of, we need to deal with funs | |
| 861 | (dotimes (j lhs-f-count) | |
| 862 | (declare (type fixnum j)) | |
| 863 | ;; for now, ignore repetition of funs (can be slower) | |
| 864 | (when (and (= (the fixnum (cdr (svref rhs-f i))) | |
| 865 | (the fixnum (cdr (svref lhs-f j)))) | |
| 866 | ;; both are from same equation, AND | |
| 867 | (possibly-matches (car (svref lhs-f j)) | |
| 868 | (car (svref rhs-f i)))) | |
| 869 | (setf (svref rhs-f-compat i) | |
| 870 | (make-or (svref rhs-f-compat i) | |
| 871 | dummy-bit))) | |
| 872 | (setq dummy-bit (* 2 dummy-bit))))) | |
| 873 | ;; and now set up the initial state to a legal one (the smallest | |
| 874 | ;; legal one) | |
| 875 | ;; by just rotating the bit until it make-and's with the | |
| 876 | ;; compatibility vector | |
| 877 | (dotimes (i rhs-c-count) | |
| 878 | (declare (type fixnum i)) | |
| 879 | (setq dummy-bit 1) | |
| 880 | (if (and (= i 0) (= rhs-f-count 0)) | |
| 881 | (setf (svref rhs-c-sol 0) 1) | |
| 882 | (let ((my-compat (svref rhs-c-compat i))) | |
| 883 | (declare (type fixnum my-compat)) | |
| 884 | (do () | |
| 885 | ((> dummy-bit rhs-c-max) | |
| 886 | (progn | |
| 887 | (with-match-debug () | |
| 888 | (format t "~%++ nomatch done 5")) | |
| 889 | (return-from TOP (values nil t)))) | |
| 890 | (unless (zerop (make-and dummy-bit my-compat)) | |
| 891 | (setf (svref rhs-c-sol i) dummy-bit) | |
| 892 | (return)) | |
| 893 | (setq dummy-bit (* 2 dummy-bit)))))) | |
| 894 | (dotimes (i rhs-f-count) | |
| 895 | (declare (type fixnum i)) | |
| 896 | (setq dummy-bit 1) | |
| 897 | (if (= i 0) | |
| 898 | (setf (svref rhs-f-sol 0) 1) | |
| 899 | (let ((my-compat (svref rhs-f-compat i))) | |
| 900 | (declare (type fixnum my-compat)) | |
| 901 | (do () | |
| 902 | ((> dummy-bit rhs-f-max) | |
| 903 | (progn | |
| 904 | (with-match-debug () | |
| 905 | (format t "~%++ nomatch-done 6")) | |
| 906 | (return-from TOP (values nil t)))) | |
| 907 | (unless (zerop (make-and dummy-bit my-compat)) | |
| 908 | (setf (svref rhs-f-sol i) dummy-bit) | |
| 909 | (return)) | |
| 910 | (setq dummy-bit (* 2 dummy-bit)))))) | |
| 911 | ||
| 912 | ;; initialize the mask - | |
| 913 | (if (= rhs-f-count 0) | |
| 914 | (setf (match-ACZ-state-LHS-mask state) 0) | |
| 915 | (let ((temp 0)) | |
| 916 | (declare (type fixnum temp)) | |
| 917 | (dotimes (s rhs-c-count) | |
| 918 | (declare (type fixnum s)) | |
| 919 | (setq temp (make-or temp | |
| 920 | (svref rhs-c-sol s)))) | |
| 921 | (setf (match-ACZ-state-LHS-mask state) temp))) | |
| 922 | ||
| 923 | ;; and now stuff the state full of information, and return it. | |
| 924 | (setf (match-ACZ-state-methods state) sys-methods) | |
| 925 | (setf (match-ACZ-state-LHS-f state) lhs-f) | |
| 926 | (setf (match-ACZ-state-LHS-v state) lhs-v) | |
| 927 | (setf (match-ACZ-state-RHS-c state) rhs-c) | |
| 928 | (setf (match-ACZ-state-RHS-f state) rhs-f) | |
| 929 | (setf (match-ACZ-state-LHS-f-r state) lhs-f-r) | |
| 930 | (setf (match-ACZ-state-LHS-v-r state) lhs-v-r) | |
| 931 | (setf (match-ACZ-state-RHS-c-r state) rhs-c-r) | |
| 932 | (setf (match-ACZ-state-RHS-f-r state) rhs-f-r) | |
| 933 | ;; (setf (match-ACZ-state-LHS-mask state) 0) | |
| 934 | (setf (match-ACZ-state-LHS-f-mask state) 0) | |
| 935 | (setf (match-ACZ-state-LHS-r-mask state) lhs-r-mask) | |
| 936 | (setf (match-ACZ-state-RHS-c-sol state) rhs-c-sol) | |
| 937 | (setf (match-ACZ-state-RHS-c-max state) rhs-c-max) | |
| 938 | (setf (match-ACZ-state-RHS-f-sol state) rhs-f-sol) | |
| 939 | (setf (match-ACZ-state-RHS-f-max state) rhs-f-max) | |
| 940 | (setf (match-ACZ-state-RHS-full-bits state) rhs-full-bits) | |
| 941 | (setf (match-ACZ-state-RHS-c-compat state) rhs-c-compat) | |
| 942 | (setf (match-ACZ-state-RHS-f-compat state) rhs-f-compat) | |
| 943 | (setf (match-ACZ-state-LHS-c-count state) 0) | |
| 944 | (setf (match-ACZ-state-LHS-f-count state) lhs-f-count) | |
| 945 | (setf (match-ACZ-state-LHS-v-count state) lhs-v-count) | |
| 946 | ; off 1+ intentionally | |
| 947 | (setf (match-ACZ-state-RHS-c-count state) rhs-c-count) | |
| 948 | (setf (match-ACZ-state-RHS-f-count state) rhs-f-count) | |
| 949 | (setf (match-ACZ-state-no-more state) nil) | |
| 950 | (setf (match-ACZ-state-acz-state-p state) 'acz-state) | |
| 951 | ;; | |
| 952 | (with-match-debug () | |
| 953 | (format t "~%acz-init: state=~&") | |
| 954 | (match-ACZ-unparse-match-ACZ-state state)) | |
| 955 | ;; | |
| 956 | (values state nil))))))) | |
| 957 | ||
| 959 | 958 | (defun match-ACZ-next-state-sub (state) |
| 960 | (do* ((m 0) ; only initialize these vars | |
| 961 | (rhs-c-sol (match-ACZ-state-rhs-c-sol state)) | |
| 962 | (rhs-c-max (match-ACZ-state-rhs-c-max state)) | |
| 963 | (rhs-c-count (match-ACZ-state-rhs-c-count state)) | |
| 964 | (rhs-c-compat (match-ACZ-state-rhs-c-compat state)) | |
| 965 | (lhs-r-mask (match-ACZ-state-lhs-r-mask state))) | |
| 966 | (nil) ; forever | |
| 959 | (do* ((m 0) ; only initialize these vars | |
| 960 | (rhs-c-sol (match-ACZ-state-rhs-c-sol state)) | |
| 961 | (rhs-c-max (match-ACZ-state-rhs-c-max state)) | |
| 962 | (rhs-c-count (match-ACZ-state-rhs-c-count state)) | |
| 963 | (rhs-c-compat (match-ACZ-state-rhs-c-compat state)) | |
| 964 | (lhs-r-mask (match-ACZ-state-lhs-r-mask state))) | |
| 965 | (nil) ; forever | |
| 967 | 966 | (declare (type #+GCL vector #-GCL simple-vector rhs-c-compat rhs-c-sol) |
| 968 | (type fixnum lhs-r-mask rhs-c-count rhs-c-max m)) | |
| 969 | (cond ((>= m rhs-c-count) ; no next row | |
| 970 | (setf (match-ACZ-state-no-more state) T) | |
| 971 | (return)) | |
| 972 | ((< m 0) ; no tests up here - could cut search here | |
| 973 | (let ((temp 0)) ; the empty bitvector | |
| 974 | (declare (type fixnum temp)) | |
| 975 | (dotimes (s rhs-c-count) | |
| 976 | (declare (type fixnum s)) | |
| 977 | (setq temp (make-or temp (svref rhs-c-sol s)))) | |
| 978 | (setf (match-ACZ-state-LHS-mask state) temp) | |
| 979 | (return))) | |
| 980 | ((< (the fixnum (svref rhs-c-sol m)) rhs-c-max) | |
| 981 | (match-ACZ-Rotate-Left rhs-c-sol m) | |
| 982 | (when (and ; this is a compatible | |
| 983 | ; position for this bit | |
| 984 | (> (make-and (svref rhs-c-sol m) | |
| 985 | (svref rhs-c-compat m)) | |
| 986 | 0) | |
| 987 | ;; either this isnt a repeated term | |
| 988 | (or (zerop (make-and (svref rhs-c-sol m) | |
| 989 | lhs-r-mask)) | |
| 990 | ;; or it is, and its upper neighbor is home | |
| 991 | (and (< (1+ m) rhs-c-count) | |
| 992 | (= (* 2 (the fixnum (svref rhs-c-sol m))) | |
| 993 | (the fixnum (svref rhs-c-sol (1+ m))))))) | |
| 994 | (setq m (1- m)))) ; then this row is ok, else redo this row | |
| 995 | (t ; this row (m) is already maxed | |
| 996 | (setf (svref rhs-c-sol m) 1) ; reset this row | |
| 997 | (setq m (1+ m)))))) ; go to next row | |
| 967 | (type fixnum lhs-r-mask rhs-c-count rhs-c-max m)) | |
| 968 | (cond ((>= m rhs-c-count) ; no next row | |
| 969 | (setf (match-ACZ-state-no-more state) T) | |
| 970 | (return)) | |
| 971 | ((< m 0) ; no tests up here - could cut search here | |
| 972 | (let ((temp 0)) ; the empty bitvector | |
| 973 | (declare (type fixnum temp)) | |
| 974 | (dotimes (s rhs-c-count) | |
| 975 | (declare (type fixnum s)) | |
| 976 | (setq temp (make-or temp (svref rhs-c-sol s)))) | |
| 977 | (setf (match-ACZ-state-LHS-mask state) temp) | |
| 978 | (return))) | |
| 979 | ((< (the fixnum (svref rhs-c-sol m)) rhs-c-max) | |
| 980 | (match-ACZ-Rotate-Left rhs-c-sol m) | |
| 981 | (when (and ; this is a compatible | |
| 982 | ; position for this bit | |
| 983 | (> (make-and (svref rhs-c-sol m) | |
| 984 | (svref rhs-c-compat m)) | |
| 985 | 0) | |
| 986 | ;; either this isnt a repeated term | |
| 987 | (or (zerop (make-and (svref rhs-c-sol m) | |
| 988 | lhs-r-mask)) | |
| 989 | ;; or it is, and its upper neighbor is home | |
| 990 | (and (< (1+ m) rhs-c-count) | |
| 991 | (= (* 2 (the fixnum (svref rhs-c-sol m))) | |
| 992 | (the fixnum (svref rhs-c-sol (1+ m))))))) | |
| 993 | (setq m (1- m)))) ; then this row is ok, else redo this row | |
| 994 | (t ; this row (m) is already maxed | |
| 995 | (setf (svref rhs-c-sol m) 1) ; reset this row | |
| 996 | (setq m (1+ m)))))) ; go to next row | |
| 998 | 997 | |
| 999 | 998 | ;;; ACZ Next State |
| 1000 | 999 | |
| 1001 | 1000 | (defun match-ACZ-next-state (state) |
| 1002 | 1001 | (if (trivial-match-ACZ-state-p state) |
| 1003 | 1002 | (if (trivial-match-ACZ-state-no-more-p state) |
| 1004 | (values nil nil t) | |
| 1005 | (progn | |
| 1006 | (setf (trivial-match-ACZ-state-no-more-p state) t) | |
| 1007 | (values (trivial-match-ACZ-state-sys state) nil nil))) | |
| 1003 | (values nil nil t) | |
| 1004 | (progn | |
| 1005 | (setf (trivial-match-ACZ-state-no-more-p state) t) | |
| 1006 | (values (trivial-match-ACZ-state-sys state) nil nil))) | |
| 1008 | 1007 | (if (not (match-ACZ-state-p state)) |
| 1009 | (progn (format t "~& match-ACZ-Next-State given non match-ACZ-state:~A~&" state) | |
| 1010 | (values nil t nil)) | |
| 1008 | (progn (format t "~% match-ACZ-Next-State given non match-ACZ-state:~A~%" state) | |
| 1009 | (values nil nil t)) | |
| 1011 | 1010 | (let ((sys nil) |
| 1012 | (no-more (match-acz-state-no-more state)) | |
| 1013 | (zero nil)) | |
| 1014 | (if no-more | |
| 1015 | (let ((zeros (pop (match-acz-state-zero-matches state)))) | |
| 1016 | (if zeros | |
| 1017 | (values zeros state nil) | |
| 1018 | (values nil nil t))) | |
| 1019 | (progn | |
| 1020 | (loop | |
| 1021 | (multiple-value-setq (sys no-more zero) | |
| 1022 | (match-acz-next-state-aux state)) | |
| 1023 | (when no-more (return)) | |
| 1024 | (when (not zero) (return)) | |
| 1025 | (push sys (match-acz-state-zero-matches state)) | |
| 1026 | ) | |
| 1027 | (if no-more | |
| 1028 | (match-acz-next-state state) | |
| 1029 | (values sys state nil) | |
| 1030 | ) | |
| 1031 | ) | |
| 1032 | ) | |
| 1033 | )))) | |
| 1034 | ||
| 1011 | (no-more (match-acz-state-no-more state)) | |
| 1012 | (zero nil)) | |
| 1013 | (if no-more | |
| 1014 | (let ((zeros (pop (match-acz-state-zero-matches state)))) | |
| 1015 | (if zeros | |
| 1016 | (values zeros state nil) | |
| 1017 | (values nil nil t))) | |
| 1018 | (progn | |
| 1019 | (loop | |
| 1020 | (multiple-value-setq (sys no-more zero) | |
| 1021 | (match-acz-next-state-aux state)) | |
| 1022 | (when no-more (return)) | |
| 1023 | (when (not zero) (return)) | |
| 1024 | (push sys (match-acz-state-zero-matches state)) | |
| 1025 | ) | |
| 1026 | (if no-more | |
| 1027 | (match-acz-next-state state) | |
| 1028 | (values sys state nil)))))))) | |
| 1029 | ||
| 1035 | 1030 | (defun match-acz-next-state-aux (state) |
| 1036 | (when *match-debug* | |
| 1037 | (format t "~&** ACZ next state")) | |
| 1031 | (with-match-debug () | |
| 1032 | (format t "~%** ACZ next state")) | |
| 1038 | 1033 | (if (match-ACZ-state-no-more state) |
| 1039 | 1034 | (progn |
| 1040 | ;; (deallocate-acz-state state) | |
| 1041 | (values nil t nil) ; there are no more solutions - so fail | |
| 1042 | ) | |
| 1035 | ;; (deallocate-acz-state state) | |
| 1036 | (values nil t nil) ; there are no more solutions - so fail | |
| 1037 | ) | |
| 1043 | 1038 | (do* ((n 0) |
| 1044 | (rhs-f-sol (match-ACZ-state-rhs-f-sol state)) | |
| 1045 | (rhs-f-max (match-ACZ-state-rhs-f-max state)) | |
| 1046 | (rhs-f-compat (match-ACZ-state-rhs-f-compat state)) | |
| 1047 | (rhs-f-count (match-ACZ-state-rhs-f-count state)) | |
| 1048 | ;; (rhs-full-bits (match-ACZ-state-rhs-full-bits state)) ;@@ | |
| 1049 | (lhs-r-mask (match-ACZ-state-lhs-r-mask state)) | |
| 1050 | (made-zero nil) | |
| 1051 | ) | |
| 1052 | (nil) ; do forever | |
| 1039 | (rhs-f-sol (match-ACZ-state-rhs-f-sol state)) | |
| 1040 | (rhs-f-max (match-ACZ-state-rhs-f-max state)) | |
| 1041 | (rhs-f-compat (match-ACZ-state-rhs-f-compat state)) | |
| 1042 | (rhs-f-count (match-ACZ-state-rhs-f-count state)) | |
| 1043 | ;; (rhs-full-bits (match-ACZ-state-rhs-full-bits state)) ;@@ | |
| 1044 | (lhs-r-mask (match-ACZ-state-lhs-r-mask state)) | |
| 1045 | (made-zero nil)) | |
| 1046 | (nil) ; do forever | |
| 1053 | 1047 | (declare (type fixnum n rhs-f-count rhs-f-max lhs-r-mask) |
| 1054 | (type #+GCL vector #-GCL simple-vector | |
| 1055 | rhs-f-sol rhs-f-compat)) | |
| 1048 | (type #+GCL vector #-GCL simple-vector | |
| 1049 | rhs-f-sol rhs-f-compat)) | |
| 1056 | 1050 | (cond ((< n 0) |
| 1057 | (let ((temp (match-ACZ-state-LHS-mask state))) | |
| 1058 | (declare (type fixnum temp)) | |
| 1059 | ;;acz (make-or (- (expt2 (ACZ-stat-lhs-v-count state)) 1)) | |
| 1060 | (dotimes (s rhs-f-count) | |
| 1061 | (declare (type fixnum s)) | |
| 1062 | (setq temp (make-or temp (svref rhs-f-sol s)))) | |
| 1063 | (let ((sol nil)) | |
| 1064 | (multiple-value-setq (sol made-zero) | |
| 1065 | (match-ACZ-solution-from-state state)) | |
| 1066 | (if sol | |
| 1067 | (return (values sol nil made-zero)) | |
| 1068 | (return (match-acz-next-state-aux state)))))) | |
| 1069 | ;; | |
| 1070 | ((>= n rhs-f-count) ; no next row | |
| 1071 | (match-ACZ-next-state-sub state) | |
| 1072 | (if (match-ACZ-state-no-more state) | |
| 1073 | (if (and (= 0 (the fixnum | |
| 1074 | (match-ACZ-state-LHS-f-count state))) | |
| 1075 | (<= 1 (the fixnum | |
| 1076 | (match-ACZ-state-LHS-v-count state))) | |
| 1077 | (= 0 (the fixnum | |
| 1078 | (match-ACZ-state-RHS-c-count state))) | |
| 1079 | (= 0 (the fixnum | |
| 1080 | (match-ACZ-state-RHS-f-count state))) | |
| 1081 | ;; TCW 14 Mar 91 vaguely plausible | |
| 1082 | (let ((lhs-v (match-ACZ-state-lhs-v state)) | |
| 1083 | (ops (match-ACZ-state-methods state))) | |
| 1084 | (declare (type #+GCL vector | |
| 1085 | #-GCL simple-vector | |
| 1086 | lhs-v ops)) | |
| 1087 | (dotimes (i (length lhs-v) t) | |
| 1088 | (declare (type fixnum i)) | |
| 1089 | (if (< i 1) nil | |
| 1090 | (unless (sort<= | |
| 1091 | (term-sort | |
| 1092 | (car (theory-zero | |
| 1093 | (method-theory (svref | |
| 1094 | ops | |
| 1095 | (cdr | |
| 1096 | (svref | |
| 1097 | lhs-v | |
| 1098 | i))))))) | |
| 1099 | (term-sort (car (svref lhs-v i)))) | |
| 1100 | (return nil)))))) | |
| 1101 | (let ((sol nil)) | |
| 1102 | (multiple-value-setq (sol made-zero) | |
| 1103 | (match-acz-solution-from-state state)) | |
| 1104 | (if sol | |
| 1105 | (return (values sol nil made-zero)) | |
| 1106 | (return (match-acz-next-state-aux state)))) | |
| 1107 | (progn | |
| 1108 | ;; failed at f-level | |
| 1109 | ;; (deallocate-acz-state state) | |
| 1110 | (return (values nil t nil)))) | |
| 1111 | (setq n (1- n))) | |
| 1112 | ) | |
| 1113 | ((< (the fixnum (svref rhs-f-sol n)) rhs-f-max) | |
| 1114 | (match-ACZ-Rotate-Left rhs-f-sol n) | |
| 1115 | (when (and ; this is a compatible position for this bit | |
| 1116 | (> (make-and (svref rhs-f-sol n) | |
| 1117 | (svref rhs-f-compat n)) | |
| 1118 | 0) | |
| 1119 | ;; either this isnt a repeated term | |
| 1120 | (or (= 0 | |
| 1121 | (the fixnum (make-and (svref rhs-f-sol n) | |
| 1122 | lhs-r-mask))) | |
| 1123 | ;; or it is, and its upper neighbor is home | |
| 1124 | (and (< (1+ n) rhs-f-count) | |
| 1125 | (= (the fixnum (* 2 (svref rhs-f-sol n))) | |
| 1126 | (the fixnum (svref rhs-f-sol (1+ n))))))) | |
| 1127 | (setq n (1- n)))) ; then this row is ok, else redo | |
| 1128 | ||
| 1129 | (t ; this row (n) is already maxed | |
| 1130 | (setf (svref rhs-f-sol n) 1) ; reset this row to one | |
| 1131 | (setq n (1+ n))))))) | |
| 1132 | ||
| 1133 | #|| | |
| 1134 | (defun match-ACZ-next-state (state) | |
| 1135 | (match-AC-next-state state)) | |
| 1136 | ||# | |
| 1051 | (let ((temp (match-ACZ-state-LHS-mask state))) | |
| 1052 | (declare (type fixnum temp)) | |
| 1053 | ;;acz (make-or (- (expt2 (ACZ-stat-lhs-v-count state)) 1)) | |
| 1054 | (dotimes (s rhs-f-count) | |
| 1055 | (declare (type fixnum s)) | |
| 1056 | (setq temp (make-or temp (svref rhs-f-sol s)))) | |
| 1057 | (let ((sol nil)) | |
| 1058 | (multiple-value-setq (sol made-zero) | |
| 1059 | (match-ACZ-solution-from-state state)) | |
| 1060 | (if sol | |
| 1061 | (return (values sol nil made-zero)) | |
| 1062 | (return (match-acz-next-state-aux state)))))) | |
| 1063 | ;; | |
| 1064 | ((>= n rhs-f-count) ; no next row | |
| 1065 | (match-ACZ-next-state-sub state) | |
| 1066 | (if (match-ACZ-state-no-more state) | |
| 1067 | (if (and (= 0 (the fixnum | |
| 1068 | (match-ACZ-state-LHS-f-count state))) | |
| 1069 | (<= 1 (the fixnum | |
| 1070 | (match-ACZ-state-LHS-v-count state))) | |
| 1071 | (= 0 (the fixnum | |
| 1072 | (match-ACZ-state-RHS-c-count state))) | |
| 1073 | (= 0 (the fixnum | |
| 1074 | (match-ACZ-state-RHS-f-count state))) | |
| 1075 | ;; TCW 14 Mar 91 vaguely plausible | |
| 1076 | (let ((lhs-v (match-ACZ-state-lhs-v state)) | |
| 1077 | (ops (match-ACZ-state-methods state))) | |
| 1078 | (declare (type #+GCL vector | |
| 1079 | #-GCL simple-vector | |
| 1080 | lhs-v ops)) | |
| 1081 | (dotimes (i (length lhs-v) t) | |
| 1082 | (declare (type fixnum i)) | |
| 1083 | (if (< i 1) nil | |
| 1084 | (unless (sort<= (term-sort (car (theory-zero (method-theory (svref ops (cdr (svref lhs-v i))))))) | |
| 1085 | (term-sort (car (svref lhs-v i)))) | |
| 1086 | (return nil)))))) | |
| 1087 | (let ((sol nil)) | |
| 1088 | (multiple-value-setq (sol made-zero) | |
| 1089 | (match-acz-solution-from-state state)) | |
| 1090 | (if sol | |
| 1091 | (return (values sol nil made-zero)) | |
| 1092 | (return (match-acz-next-state-aux state)))) | |
| 1093 | (progn | |
| 1094 | ;; failed at f-level | |
| 1095 | ;; (deallocate-acz-state state) | |
| 1096 | (return (values nil t nil)))) | |
| 1097 | (setq n (1- n)))) | |
| 1098 | ((< (the fixnum (svref rhs-f-sol n)) rhs-f-max) | |
| 1099 | (match-ACZ-Rotate-Left rhs-f-sol n) | |
| 1100 | (when (and ; this is a compatible position for this bit | |
| 1101 | (> (make-and (svref rhs-f-sol n) | |
| 1102 | (svref rhs-f-compat n)) | |
| 1103 | 0) | |
| 1104 | ;; either this isnt a repeated term | |
| 1105 | (or (= 0 | |
| 1106 | (the fixnum (make-and (svref rhs-f-sol n) | |
| 1107 | lhs-r-mask))) | |
| 1108 | ;; or it is, and its upper neighbor is home | |
| 1109 | (and (< (1+ n) rhs-f-count) | |
| 1110 | (= (the fixnum (* 2 (svref rhs-f-sol n))) | |
| 1111 | (the fixnum (svref rhs-f-sol (1+ n))))))) | |
| 1112 | (setq n (1- n)))) ; then this row is ok, else redo | |
| 1113 | ||
| 1114 | (t ; this row (n) is already maxed | |
| 1115 | (setf (svref rhs-f-sol n) 1) ; reset this row to one | |
| 1116 | (setq n (1+ n))))))) | |
| 1137 | 1117 | |
| 1138 | 1118 | #+CMU (declaim (ext:end-block)) |
| 1139 | 1119 | |
| 1140 | 1120 | ;; printout of important parts of ACZ state. |
| 1141 | 1121 | (defun match-ACZ-unparse-match-ACZ-state (ACZ-st) |
| 1142 | (format t "~&no more=~A~%" (match-ACZ-state-no-more ACZ-st)) | |
| 1143 | (format t "~&operators: ~&") | |
| 1144 | (map nil #'print-chaos-object(match-ACZ-state-methods ACZ-st)) | |
| 1145 | (format t "~&RHS-f: ~&") | |
| 1146 | (map nil #'print-chaos-object (match-ACZ-state-RHS-f ACZ-st)) | |
| 1147 | (format t "~&RHS-c: ~&") | |
| 1148 | (map nil #'print-chaos-object (match-ACZ-state-RHS-c ACZ-st)) | |
| 1149 | (format t "~&LHS-v: ~&") | |
| 1150 | (map nil #'print-chaos-object (match-ACZ-state-LHS-v ACZ-st)) | |
| 1151 | (format t "~&LHS-f: ~&") | |
| 1152 | (map nil #'print-chaos-object (match-ACZ-state-LHS-f ACZ-st)) | |
| 1153 | (format t "~& rhs-c-count=~A, rhs-f-count=~A~&" | |
| 1154 | (match-ACZ-state-RHS-c-count ACZ-st) | |
| 1155 | (match-ACZ-state-RHS-f-count ACZ-st)) | |
| 1156 | (format t "~& lhs-c-count=~A, lhs-f-count=~A, lhs-v-count=~A~%" | |
| 1157 | (match-ACZ-state-LHS-c-count ACZ-st) | |
| 1158 | (match-ACZ-state-LHS-f-count ACZ-st) | |
| 1159 | (match-ACZ-state-LHS-v-count ACZ-st)) | |
| 1160 | (let ((*print-base* 2)) ; these be bitvectors, print them as such | |
| 1161 | (format t "-------------------~%rhs-c-sol= ~A~&rhs-f-sol=~A~&" | |
| 1162 | (match-ACZ-state-RHS-c-sol ACZ-st) (match-ACZ-state-RHS-f-sol ACZ-st)) | |
| 1163 | (format t "~& rhs-c-max=~A, rhs-f-max=~A, rhs-full-bits=~A~&" | |
| 1164 | (match-ACZ-state-RHS-c-max ACZ-st) | |
| 1165 | (match-ACZ-state-RHS-f-max ACZ-st) | |
| 1166 | (match-ACZ-state-RHS-full-bits ACZ-st)) | |
| 1167 | (format t "~& rhs-c-compat=~A, rhs-f-compat=~A~&" | |
| 1168 | (match-ACZ-state-RHS-c-compat ACZ-st) | |
| 1169 | (match-ACZ-state-RHS-f-compat ACZ-st)) | |
| 1170 | (format t "~& rhs-c-r=~A, rhs-f-r=~A~&" | |
| 1171 | (match-ACZ-state-RHS-c-r ACZ-st) | |
| 1172 | (match-ACZ-state-RHS-f-r ACZ-st)) | |
| 1173 | (format t "~& lhs-f-r=~A, lhs-v-r=~A~&" | |
| 1174 | (match-ACZ-state-LHS-f-r ACZ-st) | |
| 1175 | (match-ACZ-state-LHS-v-r ACZ-st)) | |
| 1176 | (format t "~& lhs-mask=~A~%" | |
| 1177 | (match-ACZ-state-LHS-mask ACZ-st)) | |
| 1178 | (terpri) | |
| 1179 | (format t "~& lhs-f-mask=~A~%" | |
| 1180 | (match-ACZ-state-LHS-f-mask ACZ-st)) | |
| 1181 | (format t "~& lhs-r-mask=~A~%" | |
| 1182 | (match-ACZ-state-LHS-r-mask ACZ-st)) | |
| 1183 | )) | |
| 1122 | (format t "[ACZ State]") | |
| 1123 | (let ((*print-indent* (+ 2 *print-indent*))) | |
| 1124 | (format t "~%no more=~A" (match-ACZ-state-no-more ACZ-st)) | |
| 1125 | (format t "~%operators:") | |
| 1126 | (map nil #'(lambda (x) (print-next) (print-chaos-object x))(match-ACZ-state-methods ACZ-st)) | |
| 1127 | (format t "~%RHS-f:") | |
| 1128 | (map nil #'(lambda (x) (print-next) (print-chaos-object x)) (match-ACZ-state-RHS-f ACZ-st)) | |
| 1129 | (format t "~%RHS-c:") | |
| 1130 | (map nil #'(lambda (x) (print-next) (print-chaos-object x)) (match-ACZ-state-RHS-c ACZ-st)) | |
| 1131 | (format t "~%LHS-v:") | |
| 1132 | (map nil #'(lambda (x) (print-next) (print-chaos-object x)) (match-ACZ-state-LHS-v ACZ-st)) | |
| 1133 | (format t "~%LHS-f:") | |
| 1134 | (map nil #'(lambda (x) (print-next) (print-chaos-object x)) (match-ACZ-state-LHS-f ACZ-st)) | |
| 1135 | (format t "~%rhs-c-count=~A, rhs-f-count=~A" | |
| 1136 | (match-ACZ-state-RHS-c-count ACZ-st) | |
| 1137 | (match-ACZ-state-RHS-f-count ACZ-st)) | |
| 1138 | (format t "~%lhs-c-count=~A, lhs-f-count=~A, lhs-v-count=~A" | |
| 1139 | (match-ACZ-state-LHS-c-count ACZ-st) | |
| 1140 | (match-ACZ-state-LHS-f-count ACZ-st) | |
| 1141 | (match-ACZ-state-LHS-v-count ACZ-st)) | |
| 1142 | (let ((*print-base* 2)) ; these be bitvectors, print them as such | |
| 1143 | (format t "-------------------~%rhs-c-sol= ~A~&rhs-f-sol=~A~%" | |
| 1144 | (match-ACZ-state-RHS-c-sol ACZ-st) (match-ACZ-state-RHS-f-sol ACZ-st)) | |
| 1145 | (format t " rhs-c-max=~A, rhs-f-max=~A, rhs-full-bits=~A~%" | |
| 1146 | (match-ACZ-state-RHS-c-max ACZ-st) | |
| 1147 | (match-ACZ-state-RHS-f-max ACZ-st) | |
| 1148 | (match-ACZ-state-RHS-full-bits ACZ-st)) | |
| 1149 | (format t " rhs-c-compat=~s, rhs-f-compat=~s~%" | |
| 1150 | (match-ACZ-state-RHS-c-compat ACZ-st) | |
| 1151 | (match-ACZ-state-RHS-f-compat ACZ-st)) | |
| 1152 | (format t " rhs-c-r=~s, rhs-f-r=~s~%" | |
| 1153 | (match-ACZ-state-RHS-c-r ACZ-st) | |
| 1154 | (match-ACZ-state-RHS-f-r ACZ-st)) | |
| 1155 | (format t " lhs-f-r=~s, lhs-v-r=~s~%" | |
| 1156 | (match-ACZ-state-LHS-f-r ACZ-st) | |
| 1157 | (match-ACZ-state-LHS-v-r ACZ-st)) | |
| 1158 | (format t " lhs-mask=~s~%" | |
| 1159 | (match-ACZ-state-LHS-mask ACZ-st)) | |
| 1160 | (format t " lhs-f-mask=~s~%" | |
| 1161 | (match-ACZ-state-LHS-f-mask ACZ-st)) | |
| 1162 | (format t " lhs-r-mask=~s~%" | |
| 1163 | (match-ACZ-state-LHS-r-mask ACZ-st)) | |
| 1164 | ))) | |
| 1184 | 1165 | |
| 1185 | 1166 | (defun match-ACZ-trivial-unparse (state) |
| 1186 | 1167 | (let ((sys (trivial-match-ACZ-state-sys state)) |
| 1187 | (no-more-p (trivial-match-ACZ-state-no-more-p state))) | |
| 1168 | (no-more-p (trivial-match-ACZ-state-no-more-p state))) | |
| 1188 | 1169 | sys |
| 1189 | (format t "~% acz-unparse-trivial no-more-p = ~A~%" no-more-p) | |
| 1190 | ) | |
| 1191 | ) | |
| 1170 | (format t "~% acz-unparse-trivial no-more-p = ~A~%" no-more-p))) | |
| 1192 | 1171 | |
| 1193 | 1172 | (defun match-ACZ-args-nss (x) (match-ACZ-unparse-match-ACZ-state (car x)) (terpri)) |
| 1194 | 1173 | (setf (get 'match-ACZ-next-state-sub 'print-args) 'match-ACZ-args-nss) |
| 0 | 0 | ;;;-*- Mode:Lisp; Syntax:CommonLisp; Package:CHAOS -*- |
| 1 | 1 | ;;; |
| 2 | ;;; Copyright (c) 2000-2014, Toshimi Sawada. All rights reserved. | |
| 2 | ;;; Copyright (c) 2000-2015, Toshimi Sawada. All rights reserved. | |
| 3 | 3 | ;;; |
| 4 | 4 | ;;; Redistribution and use in source and binary forms, with or without |
| 5 | 5 | ;;; modification, are permitted provided that the following conditions |
| 27 | 27 | ;;; |
| 28 | 28 | (in-package :chaos) |
| 29 | 29 | #|============================================================================== |
| 30 | System:Chaos | |
| 31 | Module:e-match | |
| 32 | File:match-az.lisp | |
| 30 | System:Chaos | |
| 31 | Module:e-match | |
| 32 | File:match-az.lisp | |
| 33 | 33 | ==============================================================================|# |
| 34 | 34 | #-:chaos-debug |
| 35 | 35 | (declaim (optimize (speed 3) (safety 0) #-GCL (debug 0))) |
| 41 | 41 | ;;; ASSOCIATIVE with Identity STATE |
| 42 | 42 | |
| 43 | 43 | (defstruct (match-az-state (:constructor create-match-az-state |
| 44 | (size method sys))) | |
| 44 | (size method sys))) | |
| 45 | 45 | (size 0 :type fixnum :read-only t) |
| 46 | 46 | (method nil :read-only t) |
| 47 | sys ; array[match-eq-comp] | |
| 47 | sys ; array[match-eq-comp] | |
| 48 | 48 | no-more |
| 49 | 49 | (zero-matches nil)) |
| 50 | 50 | |
| 77 | 77 | (do ((t1 (car sub1) (car sub1)) |
| 78 | 78 | (t2 (car sub2) (car sub2))) |
| 79 | 79 | ((or (not sub1) (not sub2) |
| 80 | (term-is-variable? t1) | |
| 81 | (not (term-equational-equal t1 t2)))) | |
| 80 | (term-is-variable? t1) | |
| 81 | (not (term-equational-equal t1 t2)))) | |
| 82 | 82 | (pop sub1) |
| 83 | 83 | (pop sub2)) |
| 84 | 84 | (setq sub1 (nreverse sub1) |
| 85 | sub2 (nreverse sub2)) | |
| 85 | sub2 (nreverse sub2)) | |
| 86 | 86 | (do ((t1 (car sub1) (car sub1)) |
| 87 | 87 | (t2 (car sub2) (car sub2))) |
| 88 | 88 | ((or (not sub1) (not sub2) |
| 89 | (term-is-variable? t1) | |
| 90 | (not (term-equational-equal t1 t2)))) | |
| 89 | (term-is-variable? t1) | |
| 90 | (not (term-equational-equal t1 t2)))) | |
| 91 | 91 | (pop sub1) |
| 92 | 92 | (pop sub2)) |
| 93 | 93 | (values (nreverse sub1) (nreverse sub2))) |
| 100 | 100 | match-associativity-id-set-eq-state (sub1 sub2) |
| 101 | 101 | (declare (type list sub1 sub2)) |
| 102 | 102 | (let* ((sz1 (length sub1)) |
| 103 | (comp (alloc-svec-fixnum (if (= 0 (the fixnum sz1)) | |
| 104 | 0 | |
| 105 | (- (the fixnum sz1) 1))))) | |
| 103 | (comp (alloc-svec-fixnum (if (= 0 (the fixnum sz1)) | |
| 104 | 0 | |
| 105 | (- (the fixnum sz1) 1))))) | |
| 106 | 106 | (declare (type fixnum sz1) |
| 107 | (type #+GCL vector | |
| 108 | #-GCL simple-vector comp)) | |
| 107 | (type #+GCL vector | |
| 108 | #-GCL simple-vector comp)) | |
| 109 | 109 | (values (make-match-equation-comp |
| 110 | sz1 | |
| 111 | (make-array (the fixnum (length sub1)) :initial-contents sub1) | |
| 112 | (make-array (the fixnum (length sub2)) :initial-contents sub2) | |
| 113 | comp)))) | |
| 110 | sz1 | |
| 111 | (make-array (the fixnum (length sub1)) :initial-contents sub1) | |
| 112 | (make-array (the fixnum (length sub2)) :initial-contents sub2) | |
| 113 | comp)))) | |
| 114 | 114 | |
| 115 | 115 | ;;; op match-AZ-make-term : Operator Array[Term] Int Int -> Term |
| 116 | 116 | ;;; create a single term from a collection of terms |
| 119 | 119 | (#-GCL defun #+GCL si:define-inline-function |
| 120 | 120 | match-AZ-make-term (method vect first last) |
| 121 | 121 | (declare (type method method) |
| 122 | (type fixnum first last) | |
| 123 | (type #+GCL vector #-GCL simple-vector vect) | |
| 124 | (values term)) | |
| 122 | (type fixnum first last) | |
| 123 | (type #+GCL vector #-GCL simple-vector vect) | |
| 124 | (values term)) | |
| 125 | 125 | (cond |
| 126 | 126 | ((= first last) (values (term-make-zero method) t)) |
| 127 | 127 | ((= (1+ first) last) (values (%svref vect first) nil)) |
| 128 | 128 | (t (let ((res (%svref vect (1- last)))) |
| 129 | (do ((i (- last 2) (1- i))) | |
| 130 | ((< i first) res) | |
| 131 | (declare (type fixnum i)) | |
| 132 | (unless (term-is-zero-for-method (%svref vect i) method) | |
| 133 | (setq res (make-term-with-sort-check | |
| 134 | method (list (%svref vect i) res))))) | |
| 135 | (values res nil))))) | |
| 129 | (do ((i (- last 2) (1- i))) | |
| 130 | ((< i first) res) | |
| 131 | (declare (type fixnum i)) | |
| 132 | (unless (term-is-zero-for-method (%svref vect i) method) | |
| 133 | (setq res (make-term-with-sort-check | |
| 134 | method (list (%svref vect i) res))))) | |
| 135 | (values res nil))))) | |
| 136 | 136 | |
| 137 | 137 | ;;; try to increase with respect with the lexicographical order |
| 138 | 138 | ;;; on the arrays of integer the integer array "comp". These are |
| 148 | 148 | (#-GCL defun #+GCL si:define-inline-function |
| 149 | 149 | match-AZ-try-increase-lexico (comp max) |
| 150 | 150 | (declare (type #+GCL vector #-GCL simple-vector comp) |
| 151 | (type fixnum max) | |
| 152 | (values (or null t))) | |
| 151 | (type fixnum max) | |
| 152 | (values (or null t))) | |
| 153 | 153 | (let ((lim (the fixnum (1- (the fixnum (length comp)))))) |
| 154 | 154 | (declare (type fixnum lim)) |
| 155 | 155 | (do ((i lim (- i 1))) |
| 156 | ((< i 0) nil) | |
| 156 | ((< i 0) nil) | |
| 157 | 157 | (declare (type fixnum i)) |
| 158 | 158 | (let ((x (%svref comp i))) |
| 159 | (declare (type fixnum x)) | |
| 160 | (when (< x max) | |
| 161 | (setf (%svref comp i) (1+ x)) | |
| 162 | (do ((j (1+ i) (1+ j))) | |
| 163 | ((< lim j)) | |
| 164 | (declare (type fixnum j)) | |
| 165 | (setf (%svref comp j) (1+ x))) | |
| 166 | (return t)))))) | |
| 159 | (declare (type fixnum x)) | |
| 160 | (when (< x max) | |
| 161 | (setf (%svref comp i) (1+ x)) | |
| 162 | (do ((j (1+ i) (1+ j))) | |
| 163 | ((< lim j)) | |
| 164 | (declare (type fixnum j)) | |
| 165 | (setf (%svref comp j) (1+ x))) | |
| 166 | (return t)))))) | |
| 167 | 167 | |
| 168 | 168 | ;;; modify the match-AZ-state "AZ-st" by incrementing the state local to each |
| 169 | 169 | ;;; equation of the system in a "variable basis numeration" way |
| 175 | 175 | (declare (type match-az-state az-st)) |
| 176 | 176 | (block the-end |
| 177 | 177 | (let ((sz (match-AZ-state-size AZ-st)) |
| 178 | (sys (match-AZ-state-sys AZ-st))) | |
| 178 | (sys (match-AZ-state-sys AZ-st))) | |
| 179 | 179 | (declare (type fixnum sz)) |
| 180 | 180 | (let ((k 0) eq-comp) |
| 181 | (declare (type fixnum k)) | |
| 182 | (while (> sz k) | |
| 183 | (setq eq-comp (%svref sys k)) | |
| 184 | (when (match-AZ-try-increase-lexico | |
| 185 | (match-equation-comp-comp eq-comp) | |
| 186 | (length (match-equation-comp-right eq-comp))) | |
| 187 | ;; note that match-AZ-try-increase-lexico modify in this case | |
| 188 | ;; the "comp" of the current equation. | |
| 189 | ;; After that the previous composant are reset like in | |
| 190 | ;; 599 -> 600 | |
| 191 | (match-AZ-reset-equation-comp sys k) | |
| 192 | (return-from the-end (values nil))) | |
| 193 | ;;otherwise, try to increase the next equation | |
| 194 | (incf k))) | |
| 181 | (declare (type fixnum k)) | |
| 182 | (while (> sz k) | |
| 183 | (setq eq-comp (%svref sys k)) | |
| 184 | (when (match-AZ-try-increase-lexico | |
| 185 | (match-equation-comp-comp eq-comp) | |
| 186 | (length (match-equation-comp-right eq-comp))) | |
| 187 | ;; note that match-AZ-try-increase-lexico modify in this case | |
| 188 | ;; the "comp" of the current equation. | |
| 189 | ;; After that the previous composant are reset like in | |
| 190 | ;; 599 -> 600 | |
| 191 | (match-AZ-reset-equation-comp sys k) | |
| 192 | (return-from the-end (values nil))) | |
| 193 | ;;otherwise, try to increase the next equation | |
| 194 | (incf k))) | |
| 195 | 195 | ;; this "normal" exit of the loop means that none of the |
| 196 | 196 | ;; state has been increased so there is no more state |
| 197 | 197 | (setf (match-AZ-state-no-more AZ-st) t)))) |
| 205 | 205 | (let ((comp (match-equation-comp-comp eq-comp))) |
| 206 | 206 | (declare (type #+GCL vector #-GCL simple-vector comp)) |
| 207 | 207 | (dotimes-fixnum (x (1- (the fixnum |
| 208 | (match-equation-comp-sz-left eq-comp)))) | |
| 209 | ; x = 0,...,sz-left - 2 | |
| 208 | (match-equation-comp-sz-left eq-comp)))) | |
| 209 | ; x = 0,...,sz-left - 2 | |
| 210 | 210 | (setf (%svref comp x) 0)))) |
| 211 | 211 | |
| 212 | 212 | ;;; modifies the array "sys" of "equation-comp" in such a way that |
| 218 | 218 | (#-GCL defun #+GCL si:define-inline-function |
| 219 | 219 | match-AZ-reset-equation-comp (sys K) |
| 220 | 220 | (declare (type #+GCL vector #-GCL simple-vector sys)) |
| 221 | (dotimes-fixnum (i K) ; i = 0,...,K-1 | |
| 221 | (dotimes-fixnum (i K) ; i = 0,...,K-1 | |
| 222 | 222 | (match-AZ-reset-comp (%svref sys i)))) |
| 223 | 223 | |
| 224 | 224 | ;;; INITIALIZATION |
| 239 | 239 | (declare (type list sys env)) |
| 240 | 240 | (block no-match |
| 241 | 241 | (let* ((dim (size-of-m-system sys)) |
| 242 | (assoc-sys (alloc-svec dim)) | |
| 243 | (meth nil) | |
| 244 | (i 0) | |
| 245 | (az-state nil)) | |
| 242 | (assoc-sys (alloc-svec dim)) | |
| 243 | (meth nil) | |
| 244 | (i 0) | |
| 245 | (az-state nil)) | |
| 246 | 246 | (declare (type fixnum dim i) |
| 247 | (type #+GCL vector #-GCL simple-vector assoc-sys)) | |
| 247 | (type #+GCL vector #-GCL simple-vector assoc-sys)) | |
| 248 | 248 | (dolist (equation (m-system-to-list sys)) |
| 249 | (let ((t1 (equation-t1 equation)) | |
| 250 | (t2 (equation-t2 equation))) | |
| 251 | (setq meth (term-method t1)) | |
| 252 | (let ((sub1 (list-assoc-id-subterms t1 meth)) | |
| 253 | (sub1add nil) | |
| 254 | (sub2 (list-assoc-id-subterms t2 meth))) | |
| 255 | (declare (type list sub1 sub1add sub2)) | |
| 256 | (dolist (val sub1) | |
| 257 | (if (term-is-variable? val) | |
| 258 | (let ((ima (environment-image env val)) | |
| 259 | (head nil) ) | |
| 260 | (if (null ima) | |
| 261 | (push val sub1add) | |
| 262 | (if (term-is-variable? ima) | |
| 263 | (push ima sub1add) | |
| 264 | (if (and (term-is-application-form? ima) | |
| 265 | (method-is-of-same-operator+ meth | |
| 266 | (setq head | |
| 267 | (term-method ima)))) | |
| 268 | (setq sub1add | |
| 269 | (nconc (reverse | |
| 270 | (list-assoc-id-subterms ima head)) | |
| 271 | sub1add)) | |
| 272 | (push ima sub1add))))) | |
| 273 | (push val sub1add))) | |
| 274 | (setq sub1 (nreverse sub1add)) ; a bit tricky | |
| 275 | ;; pdl - the following is invalid in AZ case, since a big term with | |
| 276 | ;; ID's can shrink | |
| 277 | ;; (when (> (length sub1) (length sub2)) | |
| 278 | ;; (return-from no-match (values nil t))) | |
| 279 | (multiple-value-setq (sub1 sub2) | |
| 280 | (match-associative-id-simplify sub1 sub2)) | |
| 281 | ;; this never matches | |
| 282 | (when (and (null sub1) sub2) | |
| 283 | (return-from no-match (values nil t))) | |
| 284 | ;;31 Mar 88 sub1 may be nil but have modified match-AZ-$..set-eq-state | |
| 285 | (setf (%svref assoc-sys i) | |
| 286 | (match-associativity-id-set-eq-state sub1 sub2)))) | |
| 287 | (incf i)) | |
| 249 | (let ((t1 (equation-t1 equation)) | |
| 250 | (t2 (equation-t2 equation))) | |
| 251 | (setq meth (term-method t1)) | |
| 252 | (let ((sub1 (list-assoc-id-subterms t1 meth)) | |
| 253 | (sub1add nil) | |
| 254 | (sub2 (list-assoc-id-subterms t2 meth))) | |
| 255 | (declare (type list sub1 sub1add sub2)) | |
| 256 | (dolist (val sub1) | |
| 257 | (if (term-is-variable? val) | |
| 258 | (let ((ima (environment-image env val)) | |
| 259 | (head nil) ) | |
| 260 | (if (null ima) | |
| 261 | (push val sub1add) | |
| 262 | (if (term-is-variable? ima) | |
| 263 | (push ima sub1add) | |
| 264 | (if (and (term-is-application-form? ima) | |
| 265 | (method-is-of-same-operator+ meth | |
| 266 | (setq head | |
| 267 | (term-method ima)))) | |
| 268 | (setq sub1add | |
| 269 | (nconc (reverse | |
| 270 | (list-assoc-id-subterms ima head)) | |
| 271 | sub1add)) | |
| 272 | (push ima sub1add))))) | |
| 273 | (push val sub1add))) | |
| 274 | (setq sub1 (nreverse sub1add)) ; a bit tricky | |
| 275 | ;; pdl - the following is invalid in AZ case, since a big term with | |
| 276 | ;; ID's can shrink | |
| 277 | ;; (when (> (length sub1) (length sub2)) | |
| 278 | ;; (return-from no-match (values nil t))) | |
| 279 | (multiple-value-setq (sub1 sub2) | |
| 280 | (match-associative-id-simplify sub1 sub2)) | |
| 281 | ;; this never matches | |
| 282 | (when (and (null sub1) sub2) | |
| 283 | (return-from no-match (values nil t))) | |
| 284 | ;;31 Mar 88 sub1 may be nil but have modified match-AZ-$..set-eq-state | |
| 285 | (setf (%svref assoc-sys i) | |
| 286 | (match-associativity-id-set-eq-state sub1 sub2)))) | |
| 287 | (incf i)) | |
| 288 | 288 | ;; |
| 289 | 289 | (setq az-state (create-match-AZ-state dim meth assoc-sys)) |
| 290 | 290 | (when *match-debug* |
| 291 | (format t "~%** AZ: initial state") | |
| 292 | (match-az-state-unparse az-state)) | |
| 291 | (format t "~%** AZ: initial state") | |
| 292 | (match-az-state-unparse az-state)) | |
| 293 | 293 | (values az-state nil)))) |
| 294 | 294 | |
| 295 | 295 | ;;; NEXT AZ State |
| 297 | 297 | (defun match-AZ-next-state (AZ-st) |
| 298 | 298 | (declare (type match-az-state az-st)) |
| 299 | 299 | (let ((sys nil) |
| 300 | (state nil) | |
| 301 | (no-more (match-az-state-no-more az-st)) | |
| 302 | (zero nil)) | |
| 300 | (state nil) | |
| 301 | (no-more (match-az-state-no-more az-st)) | |
| 302 | (zero nil)) | |
| 303 | 303 | (if no-more |
| 304 | (let ((zeros (pop (match-az-state-zero-matches az-st)))) | |
| 305 | (if zeros | |
| 306 | (values zeros az-st nil) | |
| 307 | (values nil nil t))) | |
| 304 | (let ((zeros (pop (match-az-state-zero-matches az-st)))) | |
| 305 | (if zeros | |
| 306 | (values zeros az-st nil) | |
| 307 | (values nil nil t))) | |
| 308 | 308 | (progn |
| 309 | (loop | |
| 310 | (multiple-value-setq (sys state no-more zero) | |
| 311 | (match-az-next-state-aux az-st)) | |
| 312 | ;; skip zero | |
| 313 | (when no-more (return)) | |
| 314 | (when (not zero) (return)) | |
| 315 | (push sys (match-az-state-zero-matches az-st))) | |
| 316 | (if no-more | |
| 317 | (match-az-next-state az-st) | |
| 318 | (values sys state nil)))))) | |
| 309 | (loop | |
| 310 | (multiple-value-setq (sys state no-more zero) | |
| 311 | (match-az-next-state-aux az-st)) | |
| 312 | ;; skip zero | |
| 313 | (when no-more (return)) | |
| 314 | (when (not zero) (return)) | |
| 315 | (push sys (match-az-state-zero-matches az-st))) | |
| 316 | (if no-more | |
| 317 | (match-az-next-state az-st) | |
| 318 | (values sys state nil)))))) | |
| 319 | 319 | |
| 320 | 320 | (defun match-az-next-state-aux (az-st) |
| 321 | 321 | (let* ((new-sys (new-m-system)) |
| 322 | (sz (match-AZ-state-size AZ-st)) | |
| 323 | (sys (match-AZ-state-sys AZ-st)) | |
| 324 | (method (match-AZ-state-method AZ-st)) | |
| 325 | (made-zero nil)) | |
| 322 | (sz (match-AZ-state-size AZ-st)) | |
| 323 | (sys (match-AZ-state-sys AZ-st)) | |
| 324 | (method (match-AZ-state-method AZ-st)) | |
| 325 | (made-zero nil)) | |
| 326 | 326 | (declare (type list new-sys) |
| 327 | (type fixnum sz) | |
| 328 | (type method method)) | |
| 329 | (when (match-AZ-state-no-more AZ-st) | |
| 327 | (type fixnum sz) | |
| 328 | (type method method)) | |
| 329 | (when (match-AZ-state-no-more AZ-st) | |
| 330 | 330 | ;; there is no more match-AZ-state |
| 331 | 331 | (return-from match-az-next-state-aux (values nil nil t nil))) |
| 332 | 332 | ;; |
| 333 | (dotimes-fixnum (k sz) ; k = 0,...,sz-1 | |
| 333 | (dotimes-fixnum (k sz) ; k = 0,...,sz-1 | |
| 334 | 334 | ;; i.e. for each equation of the system |
| 335 | 335 | (let* ((eq-comp (%svref sys k)) |
| 336 | (sz-left (match-equation-comp-sz-left eq-comp)) | |
| 337 | (left (match-equation-comp-left eq-comp)) | |
| 338 | (right (match-equation-comp-right eq-comp)) | |
| 339 | (sz-right (length (the simple-vector right))) | |
| 340 | (comp (match-equation-comp-comp eq-comp))) | |
| 341 | (declare (type #-GCL simple-vector #+GCL vector comp)) | |
| 342 | (dotimes-fixnum (l sz-left) ; l = 0,...,sz-left - 1 | |
| 343 | ;; i.e. for each term of the left hand | |
| 344 | ;; side of the equation | |
| 345 | (let ((deb (if (= l 0) | |
| 346 | 0 | |
| 347 | (%svref comp (1- l)))) | |
| 348 | (fin (if (= l (1- sz-left)) | |
| 349 | sz-right | |
| 350 | (%svref comp l) | |
| 351 | ;; (1- (%svref comp l)) | |
| 352 | ))) | |
| 353 | (declare (type fixnum deb fin)) | |
| 354 | (multiple-value-bind (term zero?) | |
| 355 | (match-AZ-make-term method right deb fin) | |
| 356 | (when zero? (setq made-zero t)) | |
| 357 | (add-equation-to-m-system new-sys (make-equation (%svref left l) | |
| 358 | term))))))) | |
| 336 | (sz-left (match-equation-comp-sz-left eq-comp)) | |
| 337 | (left (match-equation-comp-left eq-comp)) | |
| 338 | (right (match-equation-comp-right eq-comp)) | |
| 339 | (sz-right (length (the simple-vector right))) | |
| 340 | (comp (match-equation-comp-comp eq-comp))) | |
| 341 | (declare (type #-GCL simple-vector #+GCL vector comp)) | |
| 342 | (dotimes-fixnum (l sz-left) ; l = 0,...,sz-left - 1 | |
| 343 | ;; i.e. for each term of the left hand | |
| 344 | ;; side of the equation | |
| 345 | (let ((deb (if (= l 0) | |
| 346 | 0 | |
| 347 | (%svref comp (1- l)))) | |
| 348 | (fin (if (= l (1- sz-left)) | |
| 349 | sz-right | |
| 350 | (%svref comp l) | |
| 351 | ;; (1- (%svref comp l)) | |
| 352 | ))) | |
| 353 | (declare (type fixnum deb fin)) | |
| 354 | (multiple-value-bind (term zero?) | |
| 355 | (match-AZ-make-term method right deb fin) | |
| 356 | (when zero? (setq made-zero t)) | |
| 357 | (add-equation-to-m-system new-sys (make-equation (%svref left l) | |
| 358 | term))))))) | |
| 359 | 359 | (increment-the-match-AZ-state AZ-st) |
| 360 | 360 | (when *match-debug* |
| 361 | 361 | (format t "~%** AZ: next state") |
| 378 | 378 | ;; |
| 379 | 379 | (if (term-is-applform? term2) |
| 380 | 380 | (let ((head1 (term-head term1)) |
| 381 | (head2 (term-head term2))) | |
| 382 | (if (method-is-of-same-operator head1 head2) | |
| 383 | (let ((sub1 (list-assoc-id-subterms term1 head1)) | |
| 384 | (sub2 (list-assoc-id-subterms term2 head2))) | |
| 385 | (declare (type list sub1 sub2)) | |
| 386 | (when (= (the fixnum (length sub1)) (the fixnum (length sub2))) | |
| 387 | (loop (unless sub1 (return-from match-az-equal t)) | |
| 388 | (unless (term-equational-equal (car sub1) (car sub2)) | |
| 389 | (return-from match-az-equal nil)) | |
| 390 | (setq sub1 (cdr sub1) | |
| 391 | sub2 (cdr sub2))))) | |
| 392 | nil)) | |
| 381 | (head2 (term-head term2))) | |
| 382 | (if (method-is-of-same-operator head1 head2) | |
| 383 | (let ((sub1 (list-assoc-id-subterms term1 head1)) | |
| 384 | (sub2 (list-assoc-id-subterms term2 head2))) | |
| 385 | (declare (type list sub1 sub2)) | |
| 386 | (when (= (the fixnum (length sub1)) (the fixnum (length sub2))) | |
| 387 | (loop (unless sub1 (return-from match-az-equal t)) | |
| 388 | (unless (term-equational-equal (car sub1) (car sub2)) | |
| 389 | (return-from match-az-equal nil)) | |
| 390 | (setq sub1 (cdr sub1) | |
| 391 | sub2 (cdr sub2))))) | |
| 392 | nil)) | |
| 393 | 393 | nil)) |
| 394 | 394 | |
| 395 | 395 | (defun match-AZ-state-unparse (AZ-st) |
| 396 | (format t "~&--AZ-state~%") | |
| 396 | (format t "~%--AZ-state~%") | |
| 397 | 397 | (princ "size: ")(prin1 (match-AZ-state-size AZ-st))(terpri) |
| 398 | 398 | (princ "operator: ")(prin1 (match-AZ-state-method AZ-st))(terpri) |
| 399 | 399 | (princ "sys: ")(dotimes (x (length (the simple-vector |
| 400 | (match-AZ-state-sys AZ-st)))) | |
| 401 | (match-equation-comp-unparse (%svref (match-AZ-state-sys AZ-st) x)) | |
| 402 | )(terpri) | |
| 400 | (match-AZ-state-sys AZ-st)))) | |
| 401 | (match-equation-comp-unparse (%svref (match-AZ-state-sys AZ-st) x)) | |
| 402 | )(terpri) | |
| 403 | 403 | (princ "no-more: ")(prin1 (match-AZ-state-no-more AZ-st))(terpri) |
| 404 | 404 | ) |
| 405 | 405 | |
| 407 | 407 | (princ "---unparse of: ")(prin1 eq-comp)(terpri)(terpri) |
| 408 | 408 | (princ "---sz-left: ")(prin1 (match-equation-comp-sz-left eq-comp))(terpri) |
| 409 | 409 | (princ "---left: ") (dotimes (x (length |
| 410 | (the simple-vector | |
| 411 | (match-equation-comp-left eq-comp)))) | |
| 412 | (prin1 (%svref (match-equation-comp-left eq-comp) x)) | |
| 413 | )(terpri) | |
| 410 | (the simple-vector | |
| 411 | (match-equation-comp-left eq-comp)))) | |
| 412 | (prin1 (%svref (match-equation-comp-left eq-comp) x)) | |
| 413 | )(terpri) | |
| 414 | 414 | (princ "---right; ") (dotimes (x (length |
| 415 | (the simple-vector | |
| 416 | (match-equation-comp-right eq-comp)))) | |
| 417 | (prin1 (%svref (match-equation-comp-right eq-comp) x)) | |
| 418 | )(terpri) | |
| 415 | (the simple-vector | |
| 416 | (match-equation-comp-right eq-comp)))) | |
| 417 | (prin1 (%svref (match-equation-comp-right eq-comp) x)) | |
| 418 | )(terpri) | |
| 419 | 419 | (princ "---comp")(prin1 (match-equation-comp-comp eq-comp))(terpri) |
| 420 | 420 | ) |
| 421 | 421 | |
| 0 | 0 | ;;;-*- Mode:Lisp; Syntax:CommonLisp; Package: CHAOS -*- |
| 1 | 1 | ;;; |
| 2 | ;;; Copyright (c) 2000-2014, Toshimi Sawada. All rights reserved. | |
| 2 | ;;; Copyright (c) 2000-2015, Toshimi Sawada. All rights reserved. | |
| 3 | 3 | ;;; |
| 4 | 4 | ;;; Redistribution and use in source and binary forms, with or without |
| 5 | 5 | ;;; modification, are permitted provided that the following conditions |
| 27 | 27 | ;;; |
| 28 | 28 | (in-package :chaos) |
| 29 | 29 | #|============================================================================== |
| 30 | System:Chaos | |
| 31 | Module:e-match | |
| 32 | File:match-c.lisp | |
| 30 | System:Chaos | |
| 31 | Module:e-match | |
| 32 | File:match-c.lisp | |
| 33 | 33 | ==============================================================================|# |
| 34 | 34 | #-:chaos-debug |
| 35 | 35 | (declaim (optimize (speed 3) (safety 0) #-GCL (debug 0))) |
| 47 | 47 | ;;; |
| 48 | 48 | |
| 49 | 49 | (defstruct (match-C-state |
| 50 | ; (:type vector) | |
| 51 | (:constructor create-match-C-state (count sys))) | |
| 50 | ; (:type vector) | |
| 51 | (:constructor create-match-C-state (count sys))) | |
| 52 | 52 | (count 0 :type fixnum) |
| 53 | 53 | (sys nil :type list)) |
| 54 | 54 | |
| 59 | 59 | |
| 60 | 60 | (defun match-C-state-initialize (sys env) |
| 61 | 61 | (declare (ignore env) |
| 62 | (type list sys)) | |
| 62 | (type list sys)) | |
| 63 | 63 | (block no-match |
| 64 | 64 | (dolist (equation (m-system-to-list sys)) |
| 65 | 65 | (unless (and (not (term-is-variable? (equation-t2 equation))) |
| 66 | (method-is-commutative-restriction-of | |
| 67 | (term-method (equation-t2 equation)) | |
| 68 | (term-method (equation-t1 equation)))) | |
| 69 | (return-from no-match (values nil t)))) | |
| 66 | (method-is-commutative-restriction-of | |
| 67 | (term-method (equation-t2 equation)) | |
| 68 | (term-method (equation-t1 equation)))) | |
| 69 | (return-from no-match (values nil t)))) | |
| 70 | 70 | (values (create-match-C-state 0 sys) |
| 71 | nil))) | |
| 71 | nil))) | |
| 72 | 72 | |
| 73 | 73 | ;;; NEXT STATE |
| 74 | 74 | |
| 75 | 75 | (defun match-C-next-state (C-st) |
| 76 | 76 | (declare (type match-c-state)) |
| 77 | 77 | (let* ((N (match-C-state-count C-st)) |
| 78 | (sys (match-C-state-sys C-st)) | |
| 79 | (q N) | |
| 80 | (r 0) | |
| 81 | (point (m-system-to-list sys)) | |
| 82 | (equation nil) | |
| 83 | (t1 nil) | |
| 84 | (t2 nil) | |
| 85 | (new-sys (new-m-system)) | |
| 86 | (lg (length point)) | |
| 87 | ) | |
| 78 | (sys (match-C-state-sys C-st)) | |
| 79 | (q N) | |
| 80 | (r 0) | |
| 81 | (point (m-system-to-list sys)) | |
| 82 | (equation nil) | |
| 83 | (t1 nil) | |
| 84 | (t2 nil) | |
| 85 | (new-sys (new-m-system)) | |
| 86 | (lg (length point)) | |
| 87 | ) | |
| 88 | 88 | (declare (type fixnum q r lg N) |
| 89 | (type list point)) | |
| 89 | (type list point)) | |
| 90 | 90 | (if (= N (the fixnum (expt2 (the fixnum lg)))) |
| 91 | ;; there is no more match-C-state | |
| 92 | (values nil nil t) | |
| 93 | (progn | |
| 94 | (dotimes-fixnum (k lg) | |
| 95 | #+KCL (setq r (rem q 2) q (truncate q 2)) | |
| 96 | #-KCL (multiple-value-setq (q r) (truncate q 2)) | |
| 97 | (setq equation (car point) | |
| 98 | point (cdr point) | |
| 99 | t1 (equation-t1 equation) | |
| 100 | t2 (equation-t2 equation)) | |
| 101 | (cond ((= r 0) | |
| 102 | (add-equation-to-m-system new-sys | |
| 103 | (make-equation (term-arg-1 t1) | |
| 104 | (term-arg-1 t2))) | |
| 105 | (add-equation-to-m-system new-sys | |
| 106 | (make-equation (term-arg-2 t1) | |
| 107 | (term-arg-2 t2)))) | |
| 108 | (t (add-equation-to-m-system new-sys | |
| 109 | (make-equation (term-arg-1 t1) | |
| 110 | (term-arg-2 t2))) | |
| 111 | (add-equation-to-m-system new-sys | |
| 112 | (make-equation (term-arg-2 t1) | |
| 113 | (term-arg-1 t2)))))) | |
| 114 | (setf (match-C-state-count C-st) (1+ N)) | |
| 115 | (values new-sys C-st nil) | |
| 116 | )))) | |
| 91 | ;; there is no more match-C-state | |
| 92 | (values nil nil t) | |
| 93 | (progn | |
| 94 | (dotimes-fixnum (k lg) | |
| 95 | #+KCL (setq r (rem q 2) q (truncate q 2)) | |
| 96 | #-KCL (multiple-value-setq (q r) (truncate q 2)) | |
| 97 | (setq equation (car point) | |
| 98 | point (cdr point) | |
| 99 | t1 (equation-t1 equation) | |
| 100 | t2 (equation-t2 equation)) | |
| 101 | (cond ((= r 0) | |
| 102 | (add-equation-to-m-system new-sys | |
| 103 | (make-equation (term-arg-1 t1) | |
| 104 | (term-arg-1 t2))) | |
| 105 | (add-equation-to-m-system new-sys | |
| 106 | (make-equation (term-arg-2 t1) | |
| 107 | (term-arg-2 t2)))) | |
| 108 | (t (add-equation-to-m-system new-sys | |
| 109 | (make-equation (term-arg-1 t1) | |
| 110 | (term-arg-2 t2))) | |
| 111 | (add-equation-to-m-system new-sys | |
| 112 | (make-equation (term-arg-2 t1) | |
| 113 | (term-arg-1 t2)))))) | |
| 114 | (setf (match-C-state-count C-st) (1+ N)) | |
| 115 | (values new-sys C-st nil) | |
| 116 | )))) | |
| 117 | 117 | |
| 118 | 118 | |
| 119 | 119 | ;;; EQUALITY |
| 124 | 124 | (declare (type term t1 t2)) |
| 125 | 125 | (if (term-is-applform? t2) |
| 126 | 126 | (if (method-is-of-same-operator (term-head t1) (term-head t2)) |
| 127 | (if (term-equational-equal (term-arg-1 t1) (term-arg-1 t2)) | |
| 128 | (term-equational-equal (term-arg-2 t1) (term-arg-2 t2)) | |
| 129 | (if (term-equational-equal (term-arg-1 t1) (term-arg-2 t2)) | |
| 130 | (term-equational-equal (term-arg-2 t1) (term-arg-1 t2)) | |
| 131 | nil)) | |
| 132 | nil) | |
| 127 | (if (term-equational-equal (term-arg-1 t1) (term-arg-1 t2)) | |
| 128 | (term-equational-equal (term-arg-2 t1) (term-arg-2 t2)) | |
| 129 | (if (term-equational-equal (term-arg-1 t1) (term-arg-2 t2)) | |
| 130 | (term-equational-equal (term-arg-2 t1) (term-arg-1 t2)) | |
| 131 | nil)) | |
| 132 | nil) | |
| 133 | 133 | nil)) |
| 134 | ||
| 134 | ||
| 135 | 135 | |
| 136 | 136 | ;;; EOF |
| 0 | 0 | ;;;-*- Mode:Lisp; Syntax:CommonLisp; Package: CHAOS -*- |
| 1 | 1 | ;;; |
| 2 | ;;; Copyright (c) 2000-2014, Toshimi Sawada. All rights reserved. | |
| 2 | ;;; Copyright (c) 2000-2015, Toshimi Sawada. All rights reserved. | |
| 3 | 3 | ;;; |
| 4 | 4 | ;;; Redistribution and use in source and binary forms, with or without |
| 5 | 5 | ;;; modification, are permitted provided that the following conditions |
| 27 | 27 | ;;; |
| 28 | 28 | (in-package :chaos) |
| 29 | 29 | #|============================================================================== |
| 30 | System:Chaos | |
| 31 | Module:e-match | |
| 32 | File:match-cz.lisp | |
| 30 | System:Chaos | |
| 31 | Module:e-match | |
| 32 | File:match-cz.lisp | |
| 33 | 33 | ==============================================================================|# |
| 34 | 34 | #-:chaos-debug |
| 35 | 35 | (declaim (optimize (speed 3) (safety 0) #-GCL (debug 0))) |
| 60 | 60 | |
| 61 | 61 | |
| 62 | 62 | (defstruct (match-CZ-state |
| 63 | (:constructor create-match-cz-state (n sys))) | |
| 63 | (:constructor create-match-cz-state (n sys))) | |
| 64 | 64 | (n 0 :type fixnum) |
| 65 | 65 | (sys nil :type list)) |
| 66 | 66 | |
| 70 | 70 | |
| 71 | 71 | (defun match-CZ-state-initialize (sys env) |
| 72 | 72 | (declare (ignore env) |
| 73 | (type list sys)) | |
| 73 | (type list sys)) | |
| 74 | 74 | ;; env : why isn't env used here or in C$? |
| 75 | 75 | (values (create-match-cz-state 0 sys) nil)) |
| 76 | 76 | |
| 85 | 85 | |
| 86 | 86 | (defun match-CZ-next-state (CZ-st) |
| 87 | 87 | (declare (type match-cz-state cz-st) |
| 88 | (values list (or null match-cz-state) (or null t))) | |
| 88 | (values list (or null match-cz-state) (or null t))) | |
| 89 | 89 | (let* ((sys (match-cz-state-sys CZ-st)) |
| 90 | (point (m-system-to-list sys)) | |
| 91 | (equation nil) | |
| 92 | (r 0) | |
| 93 | (t1 nil) | |
| 94 | (t2 nil) | |
| 95 | (new-sys (new-m-system)) | |
| 96 | (lg (length point)) | |
| 97 | (meth1 nil) | |
| 98 | (meth2 nil) | |
| 99 | ) | |
| 90 | (point (m-system-to-list sys)) | |
| 91 | (equation nil) | |
| 92 | (r 0) | |
| 93 | (t1 nil) | |
| 94 | (t2 nil) | |
| 95 | (new-sys (new-m-system)) | |
| 96 | (lg (length point)) | |
| 97 | (meth1 nil) | |
| 98 | (meth2 nil) | |
| 99 | ) | |
| 100 | 100 | (declare (type fixnum r lg) |
| 101 | (type list new-sys point)) | |
| 101 | (type list new-sys point)) | |
| 102 | 102 | (do* ((N (match-cz-state-n CZ-st)) |
| 103 | (q N N) | |
| 104 | ) | |
| 105 | ((or (not (m-system-is-empty? new-sys)) | |
| 106 | (>= N (the fixnum (expt 6 (the fixnum lg))))) | |
| 107 | (progn | |
| 108 | (setf (match-cz-state-n CZ-st) N) | |
| 109 | (if (not (m-system-is-empty? new-sys)) | |
| 110 | (values new-sys CZ-st nil) ;succes case | |
| 111 | (values nil nil t)))) ; fail case | |
| 103 | (q N N) | |
| 104 | ) | |
| 105 | ((or (not (m-system-is-empty? new-sys)) | |
| 106 | (>= N (the fixnum (expt 6 (the fixnum lg))))) | |
| 107 | (progn | |
| 108 | (setf (match-cz-state-n CZ-st) N) | |
| 109 | (if (not (m-system-is-empty? new-sys)) | |
| 110 | (values new-sys CZ-st nil) ;succes case | |
| 111 | (values nil nil t)))) ; fail case | |
| 112 | 112 | (declare (type fixnum n q)) |
| 113 | (incf N) ; try the next N | |
| 114 | (dotimes-fixnum (k lg) ; k = lg,...,1 | |
| 115 | ; this treats q as a bitvector in base 6 | |
| 116 | #+KCL (setq r (rem q 6) q (truncate q 6)) | |
| 117 | #-KCL (multiple-value-setq (q r) (truncate q 6)) | |
| 118 | (setq equation (car point) | |
| 119 | point (cdr point) | |
| 120 | t1 (equation-t1 equation) | |
| 121 | t2 (equation-t2 equation) | |
| 122 | meth1 (if (or (term-is-constant? t1) | |
| 123 | (term-is-variable? t1)) | |
| 124 | nil | |
| 125 | (term-method t1)) | |
| 126 | meth2 (if (or (term-is-constant? t2) | |
| 127 | (term-is-variable? t2)) | |
| 128 | nil | |
| 129 | (term-method t2))) | |
| 130 | (cond ((and (= r 0) ; as if no thoery applied - 11 22 | |
| 131 | meth1 meth2) | |
| 132 | (add-equation-to-m-system new-sys | |
| 133 | (make-equation (term-arg-1 t1) | |
| 134 | (term-arg-1 t2))) | |
| 135 | (add-equation-to-m-system new-sys | |
| 136 | (make-equation (term-arg-2 t1) | |
| 137 | (term-arg-2 t2)))) | |
| 138 | ((and (= r 1) ; comm - 12 21 | |
| 139 | meth1 meth2) ; | |
| 140 | (add-equation-to-m-system new-sys | |
| 141 | (make-equation (term-arg-1 t1) | |
| 142 | (term-arg-2 t2))) | |
| 143 | (add-equation-to-m-system new-sys | |
| 144 | (make-equation (term-arg-2 t1) | |
| 145 | (term-arg-1 t2)))) | |
| 146 | ((and (= r 2) | |
| 147 | meth1 ; term is non atomic | |
| 148 | (not (term-is-zero-for-method (term-arg-1 t1) meth1))) | |
| 149 | (add-equation-to-m-system new-sys | |
| 150 | (make-equation (term-arg-1 t1) | |
| 151 | (term-make-zero meth1))) | |
| 152 | (add-equation-to-m-system new-sys | |
| 153 | (make-equation (term-arg-2 t1) t2))) | |
| 154 | ((and (= r 3) | |
| 155 | meth1 ; term is non atomic | |
| 156 | (not (term-is-zero-for-method (term-arg-2 t1) meth1))) | |
| 157 | (add-equation-to-m-system new-sys | |
| 158 | (make-equation (term-arg-2 t1) | |
| 159 | (term-make-zero meth1))) | |
| 160 | (add-equation-to-m-system new-sys | |
| 161 | (make-equation (term-arg-1 t1) t2))) | |
| 162 | ;; note these are redundant if we have terms | |
| 163 | ;; in normal form (no identities). | |
| 164 | ((and (= r 4) | |
| 165 | meth2 ; term is non atomic | |
| 166 | (not (term-is-zero-for-method (term-arg-1 t2) meth2))) | |
| 167 | (let ((zero (term-make-zero meth2))) | |
| 168 | (when zero | |
| 169 | (add-equation-to-m-system new-sys | |
| 170 | (make-equation zero | |
| 171 | (term-arg-1 t2)))) | |
| 172 | (add-equation-to-m-system new-sys | |
| 173 | (make-equation t1 (term-arg-2 t2))))) | |
| 174 | ((and (= r 5) | |
| 175 | meth2 ; term is non atomic | |
| 176 | (not (term-is-zero-for-method (term-arg-2 t2) meth2))) | |
| 177 | (let ((zero (term-make-zero meth2))) | |
| 178 | (when zero | |
| 179 | (add-equation-to-m-system new-sys | |
| 180 | (make-equation zero | |
| 181 | (term-arg-2 t2)))) | |
| 182 | (add-equation-to-m-system new-sys | |
| 183 | (make-equation t1 (term-arg-1 t2))))) | |
| 184 | (t nil)))))) | |
| 113 | (incf N) ; try the next N | |
| 114 | (dotimes-fixnum (k lg) ; k = lg,...,1 | |
| 115 | ; this treats q as a bitvector in base 6 | |
| 116 | #+KCL (setq r (rem q 6) q (truncate q 6)) | |
| 117 | #-KCL (multiple-value-setq (q r) (truncate q 6)) | |
| 118 | (setq equation (car point) | |
| 119 | point (cdr point) | |
| 120 | t1 (equation-t1 equation) | |
| 121 | t2 (equation-t2 equation) | |
| 122 | meth1 (if (or (term-is-constant? t1) | |
| 123 | (term-is-variable? t1)) | |
| 124 | nil | |
| 125 | (term-method t1)) | |
| 126 | meth2 (if (or (term-is-constant? t2) | |
| 127 | (term-is-variable? t2)) | |
| 128 | nil | |
| 129 | (term-method t2))) | |
| 130 | (cond ((and (= r 0) ; as if no thoery applied - 11 22 | |
| 131 | meth1 meth2) | |
| 132 | (add-equation-to-m-system new-sys | |
| 133 | (make-equation (term-arg-1 t1) | |
| 134 | (term-arg-1 t2))) | |
| 135 | (add-equation-to-m-system new-sys | |
| 136 | (make-equation (term-arg-2 t1) | |
| 137 | (term-arg-2 t2)))) | |
| 138 | ((and (= r 1) ; comm - 12 21 | |
| 139 | meth1 meth2) ; | |
| 140 | (add-equation-to-m-system new-sys | |
| 141 | (make-equation (term-arg-1 t1) | |
| 142 | (term-arg-2 t2))) | |
| 143 | (add-equation-to-m-system new-sys | |
| 144 | (make-equation (term-arg-2 t1) | |
| 145 | (term-arg-1 t2)))) | |
| 146 | ((and (= r 2) | |
| 147 | meth1 ; term is non atomic | |
| 148 | (not (term-is-zero-for-method (term-arg-1 t1) meth1))) | |
| 149 | (add-equation-to-m-system new-sys | |
| 150 | (make-equation (term-arg-1 t1) | |
| 151 | (term-make-zero meth1))) | |
| 152 | (add-equation-to-m-system new-sys | |
| 153 | (make-equation (term-arg-2 t1) t2))) | |
| 154 | ((and (= r 3) | |
| 155 | meth1 ; term is non atomic | |
| 156 | (not (term-is-zero-for-method (term-arg-2 t1) meth1))) | |
| 157 | (add-equation-to-m-system new-sys | |
| 158 | (make-equation (term-arg-2 t1) | |
| 159 | (term-make-zero meth1))) | |
| 160 | (add-equation-to-m-system new-sys | |
| 161 | (make-equation (term-arg-1 t1) t2))) | |
| 162 | ;; note these are redundant if we have terms | |
| 163 | ;; in normal form (no identities). | |
| 164 | ((and (= r 4) | |
| 165 | meth2 ; term is non atomic | |
| 166 | (not (term-is-zero-for-method (term-arg-1 t2) meth2))) | |
| 167 | (let ((zero (term-make-zero meth2))) | |
| 168 | (when zero | |
| 169 | (add-equation-to-m-system new-sys | |
| 170 | (make-equation zero | |
| 171 | (term-arg-1 t2)))) | |
| 172 | (add-equation-to-m-system new-sys | |
| 173 | (make-equation t1 (term-arg-2 t2))))) | |
| 174 | ((and (= r 5) | |
| 175 | meth2 ; term is non atomic | |
| 176 | (not (term-is-zero-for-method (term-arg-2 t2) meth2))) | |
| 177 | (let ((zero (term-make-zero meth2))) | |
| 178 | (when zero | |
| 179 | (add-equation-to-m-system new-sys | |
| 180 | (make-equation zero | |
| 181 | (term-arg-2 t2)))) | |
| 182 | (add-equation-to-m-system new-sys | |
| 183 | (make-equation t1 (term-arg-1 t2))))) | |
| 184 | (t nil)))))) | |
| 185 | 185 | |
| 186 | 186 | |
| 187 | 187 | ;;; CZ Equality |
| 193 | 193 | |
| 194 | 194 | (defun match-CZ-equal (t1 t2) |
| 195 | 195 | (declare (type term t1 t2) |
| 196 | (values (or null t))) | |
| 196 | (values (or null t))) | |
| 197 | 197 | (let ((meth1 (term-head t1)) |
| 198 | (meth2 (term-head t2))) | |
| 199 | (or (term-is-similar? t1 t2) ; was equal | |
| 198 | (meth2 (term-head t2))) | |
| 199 | (or (term-is-similar? t1 t2) ; was equal | |
| 200 | 200 | (and (term-is-zero-for-method (term-arg-1 t1) meth1) |
| 201 | (term-equational-equal (term-arg-2 t1) t2)) | |
| 201 | (term-equational-equal (term-arg-2 t1) t2)) | |
| 202 | 202 | (and (term-is-zero-for-method (term-arg-2 t1) meth1) |
| 203 | (term-equational-equal (term-arg-1 t1) t2)) | |
| 203 | (term-equational-equal (term-arg-1 t1) t2)) | |
| 204 | 204 | (and (term-is-zero-for-method (term-arg-1 t2) meth2) |
| 205 | (term-equational-equal t1 (term-arg-2 t2))) | |
| 205 | (term-equational-equal t1 (term-arg-2 t2))) | |
| 206 | 206 | (and (term-is-zero-for-method (term-arg-2 t2) meth2) |
| 207 | (term-equational-equal t1 (term-arg-1 t2))) | |
| 207 | (term-equational-equal t1 (term-arg-1 t2))) | |
| 208 | 208 | (and (term-equational-equal (term-arg-1 t1) (term-arg-1 t2)) |
| 209 | (term-equational-equal (term-arg-2 t1) (term-arg-2 t2))) | |
| 209 | (term-equational-equal (term-arg-2 t1) (term-arg-2 t2))) | |
| 210 | 210 | (and (term-equational-equal (term-arg-1 t1) (term-arg-2 t2)) |
| 211 | (term-equational-equal (term-arg-2 t1) (term-arg-1 t2)))))) | |
| 211 | (term-equational-equal (term-arg-2 t1) (term-arg-1 t2)))))) | |
| 212 | 212 | |
| 213 | 213 | ;;; EOF |
| 0 | 0 | ;;;-*- Mode: Lisp; Syntax: CommonLisp Package: CHAOS -*- |
| 1 | 1 | ;;; |
| 2 | ;;; Copyright (c) 2000-2014, Toshimi Sawada. All rights reserved. | |
| 2 | ;;; Copyright (c) 2000-2015, Toshimi Sawada. All rights reserved. | |
| 3 | 3 | ;;; |
| 4 | 4 | ;;; Redistribution and use in source and binary forms, with or without |
| 5 | 5 | ;;; modification, are permitted provided that the following conditions |
| 27 | 27 | ;;; |
| 28 | 28 | (in-package :chaos) |
| 29 | 29 | #|============================================================================== |
| 30 | System:Chaos | |
| 31 | Module:e-match | |
| 32 | File:match-e.lisp | |
| 30 | System:Chaos | |
| 31 | Module:e-match | |
| 32 | File:match-e.lisp | |
| 33 | 33 | ==============================================================================|# |
| 34 | 34 | #-:chaos-debug |
| 35 | 35 | (declaim (optimize (speed 3) (safety 0) #-GCL (debug 0))) |
| 49 | 49 | ;;; 1 means that the decomposition has been already done and that there is |
| 50 | 50 | ;;; no more next state |
| 51 | 51 | |
| 52 | #| | |
| 53 | (defstruct (match-empty-state (:constructor create-match-empty-state (flag sys))) | |
| 54 | (flag 0 :type bit) | |
| 55 | sys ) | |
| 56 | ||
| 57 | (defmacro match-empty-state-flag (_s*) `(car ,_s*)) | |
| 58 | (defmacro match-empty-state-sys (s_*) `(cdr ,s_*)) | |
| 59 | (defmacro create-match-empty-state (_***flag _***sys) `(cons ,_***flag ,_***sys)) | |
| 60 | ||
| 61 | (defvar .match-empty-state. nil) | |
| 62 | (eval-when (:execute :load-toplevel) | |
| 63 | (setq .match-empty-state. (create-match-empty-state 0 nil))) | |
| 64 | ||
| 65 | (defun the-match-empty-state () .match-empty-state.) | |
| 66 | ||
| 67 | |# | |
| 68 | ||
| 69 | 52 | ;;; INITIALIZATION |
| 70 | 53 | |
| 71 | 54 | ;;; Initialize an empty state. It check if the top symbols of each equation of |
| 73 | 56 | ;;; |
| 74 | 57 | (defun match-empty-state-initialize (sys env) |
| 75 | 58 | (declare (ignore env) |
| 76 | (type list sys) | |
| 77 | (values (or null t) (or null t))) | |
| 59 | (type list sys) | |
| 60 | (values (or null t) (or null t))) | |
| 78 | 61 | (block no-match |
| 62 | (with-match-debug () | |
| 63 | (format t "~%[empty initialize]-----------~%") | |
| 64 | (print-match-equations (m-system-to-list sys))) | |
| 79 | 65 | (dolist (equation (m-system-to-list sys)) |
| 80 | 66 | (let ((lhs (equation-t1 equation)) |
| 81 | (rhs (equation-t2 equation))) | |
| 82 | #|| | |
| 83 | (when (or (term-is-builtin-constant? rhs) | |
| 84 | (term-is-variable? rhs)) | |
| 85 | (return-from no-match (values nil t))) | |
| 86 | ||# | |
| 87 | (unless (term-type-eq lhs rhs) | |
| 88 | (return-from no-match (values nil t))) | |
| 89 | (unless (or (match-empty-equal lhs rhs) | |
| 90 | (and (term-is-application-form? lhs) | |
| 91 | (method-is-of-same-operator+ (term-head lhs) | |
| 92 | (term-head rhs)))) | |
| 93 | (return-from no-match (values nil t)))) | |
| 94 | ) | |
| 67 | (rhs (equation-t2 equation))) | |
| 68 | (unless (term-type-eq lhs rhs) | |
| 69 | (return-from no-match (values nil t))) | |
| 70 | (unless (or (match-empty-equal lhs rhs) | |
| 71 | (and (term-is-application-form? lhs) | |
| 72 | (method-is-of-same-operator+ (term-head lhs) | |
| 73 | (term-head rhs)))) | |
| 74 | (return-from no-match (values nil t))))) | |
| 95 | 75 | (values (create-match-empty-state 0 sys) nil))) |
| 96 | ||
| 97 | 76 | |
| 98 | 77 | ;;; NEXT STATE |
| 99 | 78 | |
| 100 | 79 | (defun match-empty-next-state (empty-st) |
| 101 | (declare (type list empty-st) | |
| 102 | (values list list (or null t))) | |
| 103 | #|| | |
| 104 | (unless empty-st | |
| 105 | (with-output-chaos-warning () | |
| 106 | (format t "match empty next PANIC: illegal situation, the null state!")) | |
| 107 | (break) | |
| 108 | (return-from match-empty-next-state (values nil nil t))) | |
| 109 | ||# | |
| 80 | (declare (type list empty-st)) | |
| 110 | 81 | (let ((flag (match-empty-state-flag empty-st)) |
| 111 | (sys (match-empty-state-sys empty-st))) | |
| 82 | (sys (match-empty-state-sys empty-st))) | |
| 112 | 83 | (declare (type fixnum flag) |
| 113 | (type list sys)) | |
| 84 | (type list sys)) | |
| 85 | ||
| 86 | (with-match-debug () | |
| 87 | (format t "~%[empty-next-state] : given m-system~%") | |
| 88 | (print-match-system-sys sys)) | |
| 89 | ||
| 114 | 90 | (if (= flag 1) |
| 115 | ;; no more state | |
| 116 | (values nil nil t) | |
| 117 | (multiple-value-bind (new-m-sys no-match) | |
| 118 | (match-decompose&merge (create-match-system (new-environment) | |
| 119 | sys)) | |
| 120 | (if no-match | |
| 121 | (values nil nil t) | |
| 122 | (progn | |
| 123 | (setf (match-empty-state-flag empty-st) 1) | |
| 124 | (values (match-system-to-m-system new-m-sys) | |
| 125 | empty-st | |
| 126 | nil))))))) | |
| 91 | ;; no more state | |
| 92 | (values nil nil t) | |
| 93 | (multiple-value-bind (new-m-sys no-match) | |
| 94 | (match-decompose&merge (create-match-system (new-environment) | |
| 95 | sys)) | |
| 96 | (if no-match | |
| 97 | (values nil nil t) | |
| 98 | (progn | |
| 99 | (setf (match-empty-state-flag empty-st) 1) | |
| 100 | (values (match-system-to-m-system new-m-sys) | |
| 101 | empty-st | |
| 102 | nil))))))) | |
| 127 | 103 | |
| 128 | 104 | ;;; EQUALITY |
| 129 | 105 | |
| 132 | 108 | ;;; |
| 133 | 109 | (defun match-empty-equal (t1 t2) |
| 134 | 110 | (declare (type term t1 t2) |
| 135 | (values (or null t))) | |
| 111 | (values (or null t))) | |
| 136 | 112 | (cond ((term-is-builtin-constant? t1) |
| 137 | (term-builtin-equal t1 t2)) | |
| 138 | ((term-is-builtin-constant? t2) nil) | |
| 139 | (t (let ((head1 (term-head t1)) | |
| 140 | (head2 (term-head t2)) | |
| 141 | (subs1 (term-subterms t1)) | |
| 142 | (subs2 (term-subterms t2))) | |
| 143 | (if (null subs1) | |
| 144 | (and (null subs2) | |
| 145 | (eq head1 head2)) | |
| 146 | (if (method-is-of-same-operator head1 head2) | |
| 147 | (do* ((sub1 subs1 (cdr sub1)) | |
| 148 | (sub2 subs2 (cdr sub2)) | |
| 149 | (st1 nil) | |
| 150 | (st2 nil)) | |
| 151 | ((null sub1) t) | |
| 152 | (setq st1 (car sub1)) | |
| 153 | (setq st2 (car sub2)) | |
| 154 | ;; (unless st2 (return nil)) | |
| 155 | (cond ((term-is-variable? st1) | |
| 156 | (unless (variable= st1 st2) (return nil)) | |
| 157 | ) | |
| 158 | ((term-is-variable? st2) (return nil)) | |
| 159 | ((term-is-builtin-constant? st1) | |
| 160 | (unless (term-builtin-equal st1 st2) (return nil))) | |
| 161 | (t (unless (if (theory-info-empty-for-matching | |
| 162 | (method-theory-info-for-matching | |
| 163 | (term-method st1))) | |
| 164 | (match-empty-equal st1 st2) | |
| 165 | (term-equational-equal st1 st2)) | |
| 166 | (return nil))))) | |
| 167 | nil)))))) | |
| 113 | (term-builtin-equal t1 t2)) | |
| 114 | ((term-is-builtin-constant? t2) nil) | |
| 115 | (t (let ((head1 (term-head t1)) | |
| 116 | (head2 (term-head t2)) | |
| 117 | (subs1 (term-subterms t1)) | |
| 118 | (subs2 (term-subterms t2))) | |
| 119 | (if (null subs1) | |
| 120 | (and (null subs2) | |
| 121 | (eq head1 head2)) | |
| 122 | (if (method-is-of-same-operator head1 head2) | |
| 123 | (do* ((sub1 subs1 (cdr sub1)) | |
| 124 | (sub2 subs2 (cdr sub2)) | |
| 125 | (st1 nil) | |
| 126 | (st2 nil)) | |
| 127 | ((null sub1) t) | |
| 128 | (setq st1 (car sub1)) | |
| 129 | (setq st2 (car sub2)) | |
| 130 | ;; (unless st2 (return nil)) | |
| 131 | (cond ((term-is-variable? st1) | |
| 132 | (unless (variable= st1 st2) (return nil)) | |
| 133 | ) | |
| 134 | ((term-is-variable? st2) (return nil)) | |
| 135 | ((term-is-builtin-constant? st1) | |
| 136 | (unless (term-builtin-equal st1 st2) (return nil))) | |
| 137 | (t (unless (if (theory-info-empty-for-matching | |
| 138 | (method-theory-info-for-matching | |
| 139 | (term-method st1))) | |
| 140 | (match-empty-equal st1 st2) | |
| 141 | (term-equational-equal st1 st2)) | |
| 142 | (return nil))))) | |
| 143 | nil)))))) | |
| 168 | 144 | |
| 169 | 145 | ;;; EOF |
| 0 | 0 | ;;;-*- Mode:Lisp; Syntax:CommonLisp, Package:CHAOS; Base:10 -*- |
| 1 | 1 | ;;; |
| 2 | ;;; Copyright (c) 2000-2014, Toshimi Sawada. All rights reserved. | |
| 2 | ;;; Copyright (c) 2000-2015, Toshimi Sawada. All rights reserved. | |
| 3 | 3 | ;;; |
| 4 | 4 | ;;; Redistribution and use in source and binary forms, with or without |
| 5 | 5 | ;;; modification, are permitted provided that the following conditions |
| 27 | 27 | ;;; |
| 28 | 28 | (in-package :chaos) |
| 29 | 29 | #|============================================================================== |
| 30 | System:Chaos | |
| 31 | Module:e-match | |
| 32 | File:match-idem.lisp | |
| 30 | System:Chaos | |
| 31 | Module:e-match | |
| 32 | File:match-idem.lisp | |
| 33 | 33 | ==============================================================================|# |
| 34 | 34 | #-:chaos-debug |
| 35 | 35 | (declaim (optimize (speed 3) (safety 0) #-GCL (debug 0))) |
| 37 | 37 | (declaim (optimize (speed 1) (safety 3) #-GCL (debug 3))) |
| 38 | 38 | |
| 39 | 39 | |
| 40 | ;;; METHODS FOR IDEMPOTENT LIKE RULES: | |
| 40 | ;;; METHODS FOR IDEMPOTENT LIKE RULES: | |
| 41 | 41 | ;;; x + x = r |
| 42 | 42 | ;;; (x + x) + e = r + e -- extension |
| 43 | 43 | |
| 72 | 72 | (if (not (term-is-applform? t2)) |
| 73 | 73 | nil |
| 74 | 74 | (let* ((meth (term-head t2)) |
| 75 | (subs (list-AC-subterms t2 meth))) | |
| 76 | (declare (type list subs)) | |
| 77 | (if (oddp (length subs)) | |
| 78 | (values nil nil t nil) | |
| 79 | (let ((var (car (term-subterms t1))) | |
| 80 | (ms-tm (list-to-multiset subs #'term-equational-equal))) | |
| 81 | (if (dolist (x (multiset-elements ms-tm) t) | |
| 82 | (when (oddp (the fixnum (cdr x))) (return nil))) | |
| 83 | ;; if all even | |
| 84 | (values nil | |
| 85 | (list (cons var | |
| 86 | (make-right-assoc-normal-form-with-sort-check | |
| 87 | (term-head t1) | |
| 88 | (multiset-to-set ms-tm)))) | |
| 89 | nil | |
| 90 | nil) | |
| 91 | (values nil nil t nil)) | |
| 92 | ))))) | |
| 75 | (subs (list-AC-subterms t2 meth))) | |
| 76 | (declare (type list subs)) | |
| 77 | (if (oddp (length subs)) | |
| 78 | (values nil nil t nil) | |
| 79 | (let ((var (car (term-subterms t1))) | |
| 80 | (ms-tm (list-to-multiset subs #'term-equational-equal))) | |
| 81 | (if (dolist (x (multiset-elements ms-tm) t) | |
| 82 | (when (oddp (the fixnum (cdr x))) (return nil))) | |
| 83 | ;; if all even | |
| 84 | (values nil | |
| 85 | (list (cons var | |
| 86 | (make-right-assoc-normal-form-with-sort-check | |
| 87 | (term-head t1) | |
| 88 | (multiset-to-set ms-tm)))) | |
| 89 | nil | |
| 90 | nil) | |
| 91 | (values nil nil t nil)) | |
| 92 | ))))) | |
| 93 | 93 | |
| 94 | 94 | ;;; IDEM-EXT-MATCH : Term Term -> GlobalState Substitution NO-MATCH E-EQUAL |
| 95 | 95 | ;;;----------------------------------------------------------------------------- |
| 100 | 100 | (defun idem-ext-match (t1 t2) |
| 101 | 101 | (declare (type term t1 t2)) |
| 102 | 102 | (let* ((method (term-head t2)) |
| 103 | (subs (list-AC-subterms t2 method))) | |
| 103 | (subs (list-AC-subterms t2 method))) | |
| 104 | 104 | (declare (type list subs) |
| 105 | (type method method)) | |
| 105 | (type method method)) | |
| 106 | 106 | (if (< (the fixnum (length subs)) 3) |
| 107 | (values nil nil t nil) | |
| 108 | ;; assume that the rules is actually created in the form e + (x + x) | |
| 109 | (let* ((t1subs (term-subterms t1)) | |
| 110 | (evar (car t1subs)) | |
| 111 | (var (car (term-subterms (cadr t1subs)))) | |
| 112 | (ms-tm (list-to-multiset subs #'term-equational-equal))) | |
| 113 | (declare (type term evar var) | |
| 114 | (type list t1subs)) | |
| 115 | ;; if any odds that one from each goes in evar | |
| 116 | ;; if no odds then must put two in evar (evar has to match something) | |
| 117 | ;; if all 1, then fail (nothing to match var against) | |
| 118 | (let ((tl (multiset-elements ms-tm)) | |
| 119 | (singletons nil) | |
| 120 | (evens nil) | |
| 121 | (odds nil) | |
| 122 | (n nil) | |
| 123 | (fr nil) | |
| 124 | (it nil)) | |
| 125 | ;; split into singletons evens and odds (just categorize) | |
| 126 | (while tl | |
| 127 | (setq fr tl | |
| 128 | tl (cdr tl) | |
| 129 | it (car fr) | |
| 130 | n (cdr it)) | |
| 131 | (if (= 1 (the fixnum n)) | |
| 132 | (progn (rplacd fr singletons) (setq singletons fr)) | |
| 133 | (if (oddp n) | |
| 134 | (progn (rplacd fr odds) (setq odds fr)) | |
| 135 | (progn (rplacd fr evens) (setq evens fr))))) | |
| 136 | ;; | |
| 137 | (if (and (null evens) (null odds)) | |
| 138 | (values nil nil t nil) | |
| 139 | (progn | |
| 140 | ;; change form of singletons to simple list of terms | |
| 141 | (if (and (null singletons) (null odds)) | |
| 142 | (let ((fe (car evens))) | |
| 143 | (setq singletons (list (car fe) (car fe))) | |
| 144 | (let ((n (cdr fe))) | |
| 145 | (declare (type fixnum n)) | |
| 146 | (if (= 2 n) | |
| 147 | (setq evens (cdr evens)) | |
| 148 | (setf (the fixnum (cdr fe)) (- n 2))))) | |
| 149 | ;; else | |
| 150 | (let ((lst singletons)) | |
| 151 | (while lst | |
| 152 | (rplaca lst (caar lst)) | |
| 153 | (setq lst (cdr lst))))) | |
| 154 | ;; transfer odds to singletons and evens | |
| 155 | (while odds | |
| 156 | (setq fr odds | |
| 157 | odds (cdr odds) | |
| 158 | it (car fr)) | |
| 159 | (setq singletons (cons (car it) singletons)) | |
| 160 | ;; know that repetition count is 3 or larger | |
| 161 | (rplacd fr evens) | |
| 162 | (setq evens fr) | |
| 163 | (decf (the fixnum (cdr it)))) | |
| 164 | (values nil ; global state | |
| 165 | (list | |
| 166 | ;; evens | |
| 167 | (cons var | |
| 168 | (make-right-assoc-normal-form-with-sort-check | |
| 169 | (term-head t1) | |
| 170 | (mapcar #'car evens))) | |
| 171 | ;; singletons | |
| 172 | (cons evar | |
| 173 | (make-right-assoc-normal-form-with-sort-check | |
| 174 | (term-head t1) | |
| 175 | singletons))) | |
| 176 | nil | |
| 177 | nil) ;error indications | |
| 178 | ))) | |
| 179 | )))) | |
| 107 | (values nil nil t nil) | |
| 108 | ;; assume that the rules is actually created in the form e + (x + x) | |
| 109 | (let* ((t1subs (term-subterms t1)) | |
| 110 | (evar (car t1subs)) | |
| 111 | (var (car (term-subterms (cadr t1subs)))) | |
| 112 | (ms-tm (list-to-multiset subs #'term-equational-equal))) | |
| 113 | (declare (type term evar var) | |
| 114 | (type list t1subs)) | |
| 115 | ;; if any odds that one from each goes in evar | |
| 116 | ;; if no odds then must put two in evar (evar has to match something) | |
| 117 | ;; if all 1, then fail (nothing to match var against) | |
| 118 | (let ((tl (multiset-elements ms-tm)) | |
| 119 | (singletons nil) | |
| 120 | (evens nil) | |
| 121 | (odds nil) | |
| 122 | (n nil) | |
| 123 | (fr nil) | |
| 124 | (it nil)) | |
| 125 | ;; split into singletons evens and odds (just categorize) | |
| 126 | (while tl | |
| 127 | (setq fr tl | |
| 128 | tl (cdr tl) | |
| 129 | it (car fr) | |
| 130 | n (cdr it)) | |
| 131 | (if (= 1 (the fixnum n)) | |
| 132 | (progn (rplacd fr singletons) (setq singletons fr)) | |
| 133 | (if (oddp n) | |
| 134 | (progn (rplacd fr odds) (setq odds fr)) | |
| 135 | (progn (rplacd fr evens) (setq evens fr))))) | |
| 136 | ;; | |
| 137 | (if (and (null evens) (null odds)) | |
| 138 | (values nil nil t nil) | |
| 139 | (progn | |
| 140 | ;; change form of singletons to simple list of terms | |
| 141 | (if (and (null singletons) (null odds)) | |
| 142 | (let ((fe (car evens))) | |
| 143 | (setq singletons (list (car fe) (car fe))) | |
| 144 | (let ((n (cdr fe))) | |
| 145 | (declare (type fixnum n)) | |
| 146 | (if (= 2 n) | |
| 147 | (setq evens (cdr evens)) | |
| 148 | (setf (the fixnum (cdr fe)) (- n 2))))) | |
| 149 | ;; else | |
| 150 | (let ((lst singletons)) | |
| 151 | (while lst | |
| 152 | (rplaca lst (caar lst)) | |
| 153 | (setq lst (cdr lst))))) | |
| 154 | ;; transfer odds to singletons and evens | |
| 155 | (while odds | |
| 156 | (setq fr odds | |
| 157 | odds (cdr odds) | |
| 158 | it (car fr)) | |
| 159 | (setq singletons (cons (car it) singletons)) | |
| 160 | ;; know that repetition count is 3 or larger | |
| 161 | (rplacd fr evens) | |
| 162 | (setq evens fr) | |
| 163 | (decf (the fixnum (cdr it)))) | |
| 164 | (values nil ; global state | |
| 165 | (list | |
| 166 | ;; evens | |
| 167 | (cons var | |
| 168 | (make-right-assoc-normal-form-with-sort-check | |
| 169 | (term-head t1) | |
| 170 | (mapcar #'car evens))) | |
| 171 | ;; singletons | |
| 172 | (cons evar | |
| 173 | (make-right-assoc-normal-form-with-sort-check | |
| 174 | (term-head t1) | |
| 175 | singletons))) | |
| 176 | nil | |
| 177 | nil) ;error indications | |
| 178 | ))) | |
| 179 | )))) | |
| 180 | 180 | |
| 181 | 181 | ;;; EOF |
| 0 | 0 | ;;;-*- Mode:LISP; Package:CHAOS; Base:10; Syntax:Common-lisp -*- |
| 1 | 1 | ;;; |
| 2 | ;;; Copyright (c) 2000-2014, Toshimi Sawada. All rights reserved. | |
| 2 | ;;; Copyright (c) 2000-2015, Toshimi Sawada. All rights reserved. | |
| 3 | 3 | ;;; |
| 4 | 4 | ;;; Redistribution and use in source and binary forms, with or without |
| 5 | 5 | ;;; modification, are permitted provided that the following conditions |
| 27 | 27 | ;;; |
| 28 | 28 | (in-package :chaos) |
| 29 | 29 | #|============================================================================== |
| 30 | System:Chaos | |
| 31 | Module:e-match | |
| 32 | File:match-state.lisp | |
| 30 | System:Chaos | |
| 31 | Module:e-match | |
| 32 | File:match-state.lisp | |
| 33 | 33 | ==============================================================================|# |
| 34 | 34 | #-:chaos-debug |
| 35 | 35 | (declaim (optimize (speed 3) (safety 0) #-GCL (debug 0))) |
| 57 | 57 | |
| 58 | 58 | (defun print-global-state (gst) |
| 59 | 59 | (declare (type global-state gst) |
| 60 | (values t)) | |
| 60 | (values t)) | |
| 61 | 61 | (let ((cnt 0)) |
| 62 | 62 | (declare (type fixnum cnt)) |
| 63 | (format t "~&** global state:-------------------") | |
| 63 | (format t "~%** global state:-------------------") | |
| 64 | 64 | (dolist (ms gst) |
| 65 | 65 | (format t "~&[~d]" cnt) |
| 66 | 66 | (print-match-state ms) |
| 82 | 82 | `(funcall (theory-info-match-next-fun ,____theory-info?) ,____theory-state???)) |
| 83 | 83 | |
| 84 | 84 | (defstruct (match-state |
| 85 | (:constructor create-match-state | |
| 86 | (is-new match-system sys-to-solve theory-info | |
| 87 | theory-state))) | |
| 85 | (:constructor create-match-state | |
| 86 | (is-new match-system sys-to-solve theory-info | |
| 87 | theory-state))) | |
| 88 | 88 | (is-new nil :type (or null t)) |
| 89 | 89 | (match-system nil :type match-system) |
| 90 | 90 | (sys-to-solve nil :type list) |
| 92 | 92 | (theory-state nil :type t)) |
| 93 | 93 | |
| 94 | 94 | (defun print-match-state (ms) |
| 95 | (format t "~&--Match state, match-system-env : ") | |
| 95 | (format t "~%--Match state, match-system-env : ") | |
| 96 | 96 | (dolist (env (match-system-env (match-state-match-system ms))) |
| 97 | 97 | (terpri) |
| 98 | 98 | (princ " lhs = ")(term-print-with-sort (equation-t1 env)) |
| 124 | 124 | ;;; Initialize a match-state in which a match system "m-sys" has been inserted. |
| 125 | 125 | ;;; "m-s" is supposed to be merged and ready for mutation i.e. decomposed |
| 126 | 126 | ;;; |
| 127 | ;;; *NOT-USED* | |
| 128 | ;;;(defun match-state-initialize (t1 t2) | |
| 129 | ;;; (multiple-value-bind (m-sys no-match) | |
| 130 | ;;; (match-system.dec-merg (match-system.new t1 t2)) | |
| 131 | ;;; (if no-match | |
| 132 | ;;; (values nil t) | |
| 133 | ;;; (multiple-value-bind (sys th-info) | |
| 134 | ;;; (match-system.extract-one-system m-sys) | |
| 135 | ;;; (values (match-state-create | |
| 136 | ;;; m-sys sys th-info (theory-state-match-initialize th-info sys)) | |
| 137 | ;;; nil) | |
| 138 | ;;; )))) | |
| 139 | 127 | |
| 140 | 128 | ;;; EMPTY-STATE, see "match-e.lisp" |
| 141 | 129 | |
| 159 | 147 | ;;; |
| 160 | 148 | (defun next-match-state (st) |
| 161 | 149 | (declare (type match-state st) |
| 162 | (values (or null match-state) (or null t))) | |
| 150 | (values (or null match-state) (or null t))) | |
| 163 | 151 | (let ((theory-info (match-state-theory-info st)) |
| 164 | (th-match-state (match-state-theory-state st))) | |
| 152 | (th-match-state (match-state-theory-state st))) | |
| 165 | 153 | ;; computes the next solution of th-match-state we quit this loop either if |
| 166 | 154 | ;; there is no more new th-match-state or a new match system has been computed. |
| 167 | 155 | (loop |
| 168 | (multiple-value-bind (sys new-th-match-state no-more) | |
| 169 | (theory-state-match-next-state theory-info th-match-state) | |
| 170 | (declare (type list sys) | |
| 171 | (type t new-th-match-state) | |
| 172 | (type (or null t) no-more)) | |
| 173 | (if no-more | |
| 174 | (return (values nil t)) | |
| 175 | ;; "match-add-m-system" performs the decomposition and merging | |
| 176 | ;; and must not destroy the current match system. | |
| 177 | (multiple-value-bind (new-m-sys no-match) | |
| 178 | ;; create a new merged match-system containing the old one | |
| 179 | ;; and add sys. | |
| 180 | (match-add-m-system (match-state-match-system st) sys) | |
| 181 | ;; if there is no-match, continue (the loop) | |
| 182 | ;; else try to returns the new match-state. | |
| 183 | (unless no-match | |
| 184 | (multiple-value-bind (sys-to-solve theory-info) | |
| 185 | (m-system-extract-one-system (match-system-sys new-m-sys)) | |
| 186 | (declare (type list sys-to-solve) | |
| 187 | (type theory-info theory-info)) | |
| 188 | (if (null sys-to-solve) | |
| 189 | (return (values (match-state-create new-m-sys | |
| 190 | nil | |
| 191 | (theory-info *the-empty-theory*) | |
| 192 | (the-match-empty-state)) | |
| 193 | nil)) | |
| 194 | (multiple-value-bind (th-st no-match) | |
| 195 | (theory-state-match-initialize theory-info | |
| 196 | sys-to-solve | |
| 197 | (match-system-env new-m-sys)) | |
| 198 | ;; if no match, try another theory-state | |
| 199 | (unless no-match | |
| 200 | ;; else modify the th-match-state of st | |
| 201 | (setf (match-state-theory-state st) new-th-match-state) | |
| 202 | ;; and returns | |
| 203 | (return (values (match-state-create | |
| 204 | (match-system-modif-m-sys | |
| 205 | new-m-sys | |
| 206 | sys-to-solve) | |
| 207 | sys-to-solve | |
| 208 | theory-info | |
| 209 | th-st) | |
| 210 | nil)))))))) | |
| 211 | ))))) | |
| 156 | (multiple-value-bind (sys new-th-match-state no-more) | |
| 157 | (theory-state-match-next-state theory-info th-match-state) | |
| 158 | (declare (type list sys) | |
| 159 | (type t new-th-match-state) | |
| 160 | (type (or null t) no-more)) | |
| 161 | (if no-more | |
| 162 | (return (values nil t)) | |
| 163 | ;; "match-add-m-system" performs the decomposition and merging | |
| 164 | ;; and must not destroy the current match system. | |
| 165 | (multiple-value-bind (new-m-sys no-match) | |
| 166 | ;; create a new merged match-system containing the old one | |
| 167 | ;; and add sys. | |
| 168 | (match-add-m-system (match-state-match-system st) sys) | |
| 169 | ;; | |
| 170 | (with-match-debug () | |
| 171 | (let ((fun (theory-info-match-next-fun theory-info))) | |
| 172 | (format t "~%<--[Match-next-state] funcalled ~s" fun))) | |
| 173 | ;; if there is no-match, continue (the loop) | |
| 174 | ;; else try to returns the new match-state. | |
| 175 | (with-match-debug () | |
| 176 | (if no-match | |
| 177 | (format t "[NEXT-MATCH-STATE] retun with no-match."))) | |
| 178 | (unless no-match | |
| 179 | (multiple-value-bind (sys-to-solve theory-info) | |
| 180 | (m-system-extract-one-system (match-system-sys new-m-sys)) | |
| 181 | (declare (type list sys-to-solve) | |
| 182 | (type theory-info theory-info)) | |
| 183 | (if (null sys-to-solve) | |
| 184 | (return (values (match-state-create new-m-sys | |
| 185 | nil | |
| 186 | (theory-info *the-empty-theory*) | |
| 187 | (the-match-empty-state)) | |
| 188 | nil)) | |
| 189 | (multiple-value-bind (th-st no-match) | |
| 190 | (theory-state-match-initialize theory-info | |
| 191 | sys-to-solve | |
| 192 | (match-system-env new-m-sys)) | |
| 193 | ;; if no match, try another theory-state | |
| 194 | (unless no-match | |
| 195 | ;; else modify the th-match-state of st | |
| 196 | (setf (match-state-theory-state st) new-th-match-state) | |
| 197 | ;; and returns | |
| 198 | (return (values (match-state-create (match-system-modif-m-sys new-m-sys sys-to-solve) | |
| 199 | sys-to-solve | |
| 200 | theory-info | |
| 201 | th-st) | |
| 202 | nil)))))))) | |
| 203 | ))))) | |
| 212 | 204 | ;;; EOF |
| 0 | 0 | ;;;-*- Mode:LISP; Package:CHAOS; Base:10; Syntax:Common-lisp -*- |
| 1 | 1 | ;;; |
| 2 | ;;; Copyright (c) 2000-2014, Toshimi Sawada. All rights reserved. | |
| 2 | ;;; Copyright (c) 2000-2015, Toshimi Sawada. All rights reserved. | |
| 3 | 3 | ;;; |
| 4 | 4 | ;;; Redistribution and use in source and binary forms, with or without |
| 5 | 5 | ;;; modification, are permitted provided that the following conditions |
| 27 | 27 | ;;; |
| 28 | 28 | (in-package :chaos) |
| 29 | 29 | #|============================================================================= |
| 30 | System:CHAOS | |
| 31 | Module:e-match | |
| 32 | File:match-system.lisp | |
| 30 | System:CHAOS | |
| 31 | Module:e-match | |
| 32 | File:match-system.lisp | |
| 33 | 33 | Based on the implementation of OBJ3 system. |
| 34 | 34 | =============================================================================|# |
| 35 | 35 | #-:chaos-debug |
| 37 | 37 | #+:chaos-debug |
| 38 | 38 | (declaim (optimize (speed 1) (safety 3) #-GCL (debug 3))) |
| 39 | 39 | |
| 40 | ;;; The Mach System | |
| 40 | ;;; The Mach System | |
| 41 | 41 | ;;; (defvar *match-debug* nil) |
| 42 | 42 | ;;;----------------------------------------------------------------------------- |
| 43 | 43 | ;;; A match system is a system of oriented equations which first term may |
| 81 | 81 | (4) Mutation. |
| 82 | 82 | |
| 83 | 83 | t1 == t2 & U |
| 84 | --------------------- if t1, t2 \in E (in some sense ) | |
| 84 | --------------------- if t1, t2 \in E (in some sense ) | |
| 85 | 85 | MUT(E)(t1 == t2 & U) |
| 86 | 86 | |
| 87 | 87 | (5) Coalesce. |
| 88 | 88 | |
| 89 | 89 | x:s == y:s' & U |
| 90 | ------------------ if x,y \in Var(U) and s' <= s | |
| 90 | ------------------ if x,y \in Var(U) and s' <= s | |
| 91 | 91 | x == y & U{x -> y} |
| 92 | 92 | |
| 93 | 93 | (6) Merge - there is a merge operation - which I have yet to properly formulate |
| 142 | 142 | |
| 143 | 143 | (defun !match-decompose-on-demand (t1 t2 result) |
| 144 | 144 | (declare (type term t1 t2) |
| 145 | (type list result) | |
| 146 | (values (or null t))) | |
| 145 | (type list result) | |
| 146 | (values (or null t))) | |
| 147 | 147 | ;; perform on-demand reduction of t2, then try decompose. |
| 148 | 148 | ;; returns t on failure. |
| 149 | 149 | (if (term-is-on-demand? t2) |
| 150 | 150 | ;; `normalize-term' may destructively rewrites t2, |
| 151 | 151 | ;; returns T iff it did not perform rewriting. |
| 152 | 152 | (progn |
| 153 | (mark-term-as-not-on-demand t2) | |
| 154 | (if (normalize-term t2) | |
| 155 | t | |
| 156 | (!match-decompose t1 t2 result))) | |
| 153 | (mark-term-as-not-on-demand t2) | |
| 154 | (if (normalize-term t2) | |
| 155 | t | |
| 156 | (!match-decompose t1 t2 result))) | |
| 157 | 157 | t) |
| 158 | 158 | ) |
| 159 | 159 | |
| 160 | 160 | (defun occurs-in (v term) |
| 161 | 161 | (cond ((term-is-variable? term) |
| 162 | (variable-eq v term)) | |
| 163 | ((term-is-application-form? term) | |
| 164 | (dolist (sub (term-subterms term)) | |
| 165 | (when (occurs-in v sub) | |
| 166 | (return-from occurs-in t))) | |
| 167 | nil) | |
| 168 | (t nil))) | |
| 162 | (variable-eq v term)) | |
| 163 | ((term-is-application-form? term) | |
| 164 | (dolist (sub (term-subterms term)) | |
| 165 | (when (occurs-in v sub) | |
| 166 | (return-from occurs-in t))) | |
| 167 | nil) | |
| 168 | (t nil))) | |
| 169 | 169 | |
| 170 | 170 | |
| 171 | 171 | (defun !match-decompose (t1 t2 res) |
| 180 | 180 | |
| 181 | 181 | (defun !match-decompose-unify (t1 t2 res) |
| 182 | 182 | (declare (type term t1 t2) |
| 183 | (type list res) | |
| 184 | (values (or null t))) | |
| 183 | (type list res) | |
| 184 | (values (or null t))) | |
| 185 | 185 | (cond ((term-is-variable? t1) |
| 186 | ;; [1] t1 is variable | |
| 187 | ;; OS sort check. | |
| 188 | (when (variable-eq t1 t2) | |
| 189 | ;; trivial equation, discard. | |
| 190 | (return-from !match-decompose-unify nil)) | |
| 191 | (when (occurs-in t1 t2) | |
| 192 | (return-from !match-decompose-unify t)) | |
| 193 | ;; | |
| 194 | (if | |
| 195 | #|| | |
| 196 | (is-in-same-connected-component (term-sort t1) | |
| 197 | (term-sort t2) | |
| 198 | *current-sort-order*) | |
| 199 | ||# | |
| 200 | (sort<= (term-sort t2) (term-sort t1) *current-sort-order*) | |
| 201 | (let ((cval (variable-image (cdr res) t1))) | |
| 202 | (if cval | |
| 203 | (progn | |
| 204 | #|| | |
| 205 | (with-output-simple-msg () | |
| 206 | (format t "* rec!match-dec: t1=") | |
| 207 | (term-print t1) | |
| 208 | (print-next) | |
| 209 | (format t " t2 = ") | |
| 210 | (term-print t2) | |
| 211 | (print-next) | |
| 212 | (print-substitution (cdr res))) | |
| 213 | ||# | |
| 214 | (!match-decompose-unify cval t2 res) | |
| 215 | ) | |
| 216 | (cond ((term-is-variable? t2) | |
| 217 | (setq cval (variable-image (cdr res) t2)) | |
| 218 | (if (not cval) | |
| 219 | (push (make-equation t1 t2) (cdr res)) | |
| 220 | (unless (variable-eq t1 cval) | |
| 221 | (push (make-equation t1 t2) (cdr res)))) | |
| 222 | nil) | |
| 223 | (t (push (make-equation t1 t2) (cdr res)) | |
| 224 | nil)) | |
| 225 | )) ; success | |
| 226 | ;; incomparable sorts | |
| 227 | t)) ; fail | |
| 228 | ||
| 229 | ;; [2] t1 is not variable, t2 is variable. | |
| 230 | ((term-is-variable? t2) | |
| 231 | (!match-decompose-unify t2 t1 res)) | |
| 186 | ;; [1] t1 is variable | |
| 187 | ;; OS sort check. | |
| 188 | (when (variable-eq t1 t2) | |
| 189 | ;; trivial equation, discard. | |
| 190 | (return-from !match-decompose-unify nil)) | |
| 191 | (when (occurs-in t1 t2) | |
| 192 | (return-from !match-decompose-unify t)) | |
| 193 | ;; | |
| 194 | (if (sort<= (term-sort t2) (term-sort t1) *current-sort-order*) | |
| 195 | (let ((cval (variable-image (cdr res) t1))) | |
| 196 | (if cval | |
| 197 | (progn | |
| 198 | (!match-decompose-unify cval t2 res)) | |
| 199 | (cond ((term-is-variable? t2) | |
| 200 | (setq cval (variable-image (cdr res) t2)) | |
| 201 | (if (not cval) | |
| 202 | (push (make-equation t1 t2) (cdr res)) | |
| 203 | (unless (variable-eq t1 cval) | |
| 204 | (push (make-equation t1 t2) (cdr res)))) | |
| 205 | nil) | |
| 206 | (t (push (make-equation t1 t2) (cdr res)) | |
| 207 | nil)) | |
| 208 | )) ; success | |
| 209 | ;; incomparable sorts | |
| 210 | t)) ; fail | |
| 211 | ||
| 212 | ;; [2] t1 is not variable, t2 is variable. | |
| 213 | ((term-is-variable? t2) | |
| 214 | (!match-decompose-unify t2 t1 res)) | |
| 232 | 215 | |
| 233 | ;; [3] t1 or t2 is builtin constant. | |
| 234 | ||
| 235 | ((term-is-builtin-constant? t1) | |
| 236 | (not (term-builtin-equal t1 t2))) | |
| 237 | ||
| 238 | #|| | |
| 239 | ((term-is-builtin-constant? t2) | |
| 240 | t) | |
| 241 | ||# | |
| 242 | ||
| 243 | ;; [4] t1 & t2 is application form. | |
| 244 | (t (let* ((t1-top (term-head t1)) | |
| 245 | (t2-top (term-head t2)) | |
| 246 | (th-info (method-theory-info-for-matching! t1-top))) | |
| 247 | ;; since it is OS-matching, we only | |
| 248 | ;; test the equality of the operator. | |
| 249 | (if (method-is-of-same-operator+ t1-top t2-top) | |
| 250 | ;; f(x, y, z ...) = f(x',y',z'...) | |
| 251 | (if (theory-info-empty-for-matching th-info) | |
| 252 | ;; | |
| 253 | ;; the empty theory, do the full decompose. | |
| 254 | ;; | |
| 255 | (let ((t1-subterms (term-subterms t1)) | |
| 256 | (t2-subterms (term-subterms t2))) | |
| 257 | (declare (type list t1-subterms t2-subterms)) | |
| 258 | (loop ; for each subterm try decomposition. | |
| 259 | (unless t1-subterms (return nil)) | |
| 260 | (let ((ng (!match-decompose-unify (car t1-subterms) | |
| 261 | (car t2-subterms) | |
| 262 | res))) | |
| 263 | (when ng | |
| 264 | (return-from !match-decompose-unify t))) | |
| 265 | (setf t1-subterms (cdr t1-subterms) | |
| 266 | t2-subterms (cdr t2-subterms))) | |
| 267 | nil) | |
| 268 | ;; | |
| 269 | ;; if the theory has equational theory, we do not | |
| 270 | ;; perform full decomposition. | |
| 271 | ;; | |
| 272 | (progn | |
| 273 | (push (make-equation t1 t2) (cdr res)) | |
| 274 | nil)) | |
| 275 | ;; | |
| 276 | ;; the different top level | |
| 277 | ;; possibly maches only when zero case... | |
| 278 | ;; | |
| 279 | ;; #|| | |
| 280 | (if (or (test-theory .Z. (theory-info-code th-info)) | |
| 281 | (test-theory .Z. (theory-info-code | |
| 282 | (method-theory-info-for-matching! | |
| 283 | (term-head t2))))) | |
| 284 | (progn (push (make-equation t1 t2) (cdr res)) | |
| 285 | nil) | |
| 286 | ;; will never match | |
| 287 | t) | |
| 288 | ;;||# | |
| 289 | ;;t | |
| 290 | ) | |
| 291 | )))) | |
| 216 | ;; [3] t1 or t2 is builtin constant. | |
| 217 | ||
| 218 | ((term-is-builtin-constant? t1) | |
| 219 | (not (term-builtin-equal t1 t2))) | |
| 220 | ||
| 221 | ;; [4] t1 & t2 is application form. | |
| 222 | (t (let* ((t1-top (term-head t1)) | |
| 223 | (t2-top (term-head t2)) | |
| 224 | (th-info (method-theory-info-for-matching! t1-top))) | |
| 225 | ;; since it is OS-matching, we only | |
| 226 | ;; test the equality of the operator. | |
| 227 | (if (method-is-of-same-operator+ t1-top t2-top) | |
| 228 | ;; f(x, y, z ...) = f(x',y',z'...) | |
| 229 | (if (theory-info-empty-for-matching th-info) | |
| 230 | ;; | |
| 231 | ;; the empty theory, do the full decompose. | |
| 232 | ;; | |
| 233 | (let ((t1-subterms (term-subterms t1)) | |
| 234 | (t2-subterms (term-subterms t2))) | |
| 235 | (declare (type list t1-subterms t2-subterms)) | |
| 236 | (loop ; for each subterm try decomposition. | |
| 237 | (unless t1-subterms (return nil)) | |
| 238 | (let ((ng (!match-decompose-unify (car t1-subterms) | |
| 239 | (car t2-subterms) | |
| 240 | res))) | |
| 241 | (when ng | |
| 242 | (return-from !match-decompose-unify t))) | |
| 243 | (setf t1-subterms (cdr t1-subterms) | |
| 244 | t2-subterms (cdr t2-subterms))) | |
| 245 | nil) | |
| 246 | ;; | |
| 247 | ;; if the theory has equational theory, we do not | |
| 248 | ;; perform full decomposition. | |
| 249 | ;; | |
| 250 | (progn | |
| 251 | (push (make-equation t1 t2) (cdr res)) | |
| 252 | nil)) | |
| 253 | ;; | |
| 254 | ;; the different top level | |
| 255 | ;; possibly maches only when zero case... | |
| 256 | (if (or (test-theory .Z. (theory-info-code th-info)) | |
| 257 | (test-theory .Z. (theory-info-code | |
| 258 | (method-theory-info-for-matching! | |
| 259 | (term-head t2))))) | |
| 260 | (progn (push (make-equation t1 t2) (cdr res)) | |
| 261 | nil) | |
| 262 | ;; will never match | |
| 263 | t)))))) | |
| 292 | 264 | |
| 293 | 265 | (defun !match-decompose-match (t1 t2 res) |
| 294 | 266 | (declare (type term t1 t2) |
| 295 | (type list res) | |
| 296 | (values (or null t))) | |
| 267 | (type list res) | |
| 268 | (values (or null t))) | |
| 269 | (with-match-debug () | |
| 270 | (format t "~%** !match-decompose-match:") | |
| 271 | (print-next) | |
| 272 | (princ "-t1: ") (term-print-with-sort t1) | |
| 273 | (print-next) | |
| 274 | (princ "-t2: ") (term-print-with-sort t2)) | |
| 297 | 275 | (cond |
| 298 | 276 | ;; [1] t1 is variable |
| 299 | 277 | ((term-is-variable? t1) |
| 300 | 278 | ;; OS sort check. |
| 301 | 279 | (if (sort<= (term-sort t2) (term-sort t1) *current-sort-order*) |
| 302 | (progn (push (make-equation t1 t2) (cdr res)) | |
| 303 | nil) | |
| 280 | (progn | |
| 281 | (push (make-equation t1 t2) (cdr res)) | |
| 282 | nil) | |
| 304 | 283 | ;; try again after possible on-demand reduction of t2. |
| 305 | 284 | (!match-decompose-on-demand t1 t2 res))) |
| 306 | 285 | |
| 307 | 286 | ;; [2] t1 is not variable, t2 is variable. |
| 308 | ||
| 309 | 287 | ((term-is-variable? t2) |
| 310 | 288 | (if *one-way-match* |
| 311 | t ; fail | |
| 312 | (!match-decompose-match t2 t1 res)) | |
| 313 | ) | |
| 289 | (progn | |
| 290 | (with-match-debug () | |
| 291 | (print-next) | |
| 292 | (princ ">> FAIL for t2 is variable.")) | |
| 293 | t) ; fail | |
| 294 | (!match-decompose-match t2 t1 res))) | |
| 314 | 295 | |
| 315 | 296 | ;; [3] t1 or t2 is builtin constant. |
| 316 | ||
| 317 | 297 | ((term-is-builtin-constant? t1) |
| 318 | (not (term-builtin-equal t1 t2))) | |
| 319 | ||
| 320 | #|| | |
| 321 | ((term-is-builtin-constant? t2) | |
| 322 | t) | |
| 323 | ||# | |
| 298 | (let ((ans (not (term-builtin-equal t1 t2)))) | |
| 299 | (with-match-debug () | |
| 300 | (print-next) | |
| 301 | (if ans | |
| 302 | (princ ">> SUCCESS, builtin-equal.") | |
| 303 | (princ ">> FAIL, builtin not equal."))) | |
| 304 | ans)) | |
| 324 | 305 | |
| 325 | 306 | ;; [4] t1 is an application form. |
| 326 | 307 | (t (let* ((t1-top (term-head t1)) |
| 327 | (th-info (method-theory-info-for-matching! t1-top))) | |
| 328 | (if (term-is-builtin-constant? t2) | |
| 329 | (if (not (theory-info-empty-for-matching th-info)) | |
| 330 | (progn (push (make-equation t1 t2) (cdr res)) | |
| 331 | nil) | |
| 332 | t) | |
| 333 | ;; t2 also is an application form. | |
| 334 | (let ((t2-top (term-head t2))) | |
| 335 | ;; since it is OS-matching, we only | |
| 336 | ;; test the equality of the operator. | |
| 337 | (if (method-is-of-same-operator+ t1-top t2-top) | |
| 338 | ;; f(x, y, z ...) = f(x',y',z'...) | |
| 339 | (if (theory-info-empty-for-matching th-info) | |
| 340 | ;; | |
| 341 | ;; the empty theory, do the full decompose. | |
| 342 | ;; | |
| 343 | (let ((t1-subterms (term-subterms t1)) | |
| 344 | (t2-subterms (term-subterms t2))) | |
| 345 | (declare (type list t1-subterms t2-subterms)) | |
| 346 | (loop ; for each subterm try decomposition. | |
| 347 | (unless t1-subterms (return nil)) | |
| 348 | (let ((ng (!match-decompose-match (car t1-subterms) | |
| 349 | (car t2-subterms) | |
| 350 | res))) | |
| 351 | (when (and ng | |
| 352 | (!match-decompose-on-demand t1 t2 res)) | |
| 353 | (return-from !match-decompose-match t))) | |
| 354 | (setf t1-subterms (cdr t1-subterms) | |
| 355 | t2-subterms (cdr t2-subterms))) | |
| 356 | nil) | |
| 357 | ;; | |
| 358 | ;; if the theory has equational theory, we do not | |
| 359 | ;; perform full decomposition. | |
| 360 | ;; | |
| 361 | (progn | |
| 362 | (push (make-equation t1 t2) (cdr res)) | |
| 363 | nil)) | |
| 364 | ||
| 365 | ;; | |
| 366 | ;; the different top level | |
| 367 | ;; possibly maches only when zero case or on-demand. | |
| 368 | ;; | |
| 369 | ;; #|| too danderous: many cases of rewriting rush into infinite loop. | |
| 370 | (if (term-is-on-demand? t2) | |
| 371 | (progn | |
| 372 | (mark-term-as-not-on-demand t2) | |
| 373 | (if (normalize-term t2) | |
| 374 | ;; no reduction has been performed. | |
| 375 | (if (or (test-theory .Z. (theory-info-code th-info)) | |
| 376 | (test-theory .Z. (theory-info-code | |
| 377 | (method-theory-info-for-matching! | |
| 378 | (term-head t2))))) | |
| 379 | (progn (push (make-equation t1 t2) (cdr res)) | |
| 380 | nil) | |
| 381 | ;; will never match | |
| 382 | t) | |
| 383 | ;; t2 is rewritten | |
| 384 | (!match-decompose t1 t2 res))) | |
| 385 | ;; t2 is not on demand. | |
| 386 | (if (or (test-theory .Z. (theory-info-code th-info)) | |
| 387 | (test-theory .Z. (theory-info-code | |
| 388 | (method-theory-info-for-matching! | |
| 389 | (term-head t2))))) | |
| 390 | (progn (push (make-equation t1 t2) (cdr res)) | |
| 391 | nil) | |
| 392 | ;; will never match | |
| 393 | t)) ))))))) | |
| 394 | ||
| 395 | ;; (declaim (inline match-decompose-equation)) | |
| 308 | (th-info (method-theory-info-for-matching! t1-top))) | |
| 309 | (if (term-is-builtin-constant? t2) | |
| 310 | (if (not (theory-info-empty-for-matching th-info)) | |
| 311 | (progn (push (make-equation t1 t2) (cdr res)) | |
| 312 | nil) | |
| 313 | (progn | |
| 314 | (with-match-debug () | |
| 315 | (print-next) | |
| 316 | (princ ">> FAIL, t2 is builtin.")) | |
| 317 | t)) | |
| 318 | ;; t2 also is an application form. | |
| 319 | (let ((t2-top (term-head t2))) | |
| 320 | ;; since it is OS-matching, we only | |
| 321 | ;; test the equality of the operator. | |
| 322 | (if (method-is-of-same-operator+ t1-top t2-top) | |
| 323 | ;; f(x, y, z ...) = f(x',y',z'...) | |
| 324 | (if (theory-info-empty-for-matching th-info) | |
| 325 | ;; | |
| 326 | ;; the empty theory, do the full decompose. | |
| 327 | ;; | |
| 328 | (let ((t1-subterms (term-subterms t1)) | |
| 329 | (t2-subterms (term-subterms t2))) | |
| 330 | (declare (type list t1-subterms t2-subterms)) | |
| 331 | (with-match-debug () | |
| 332 | (format t "~%>> empty theory: do the full decompose...")) | |
| 333 | (loop ; for each subterm try decomposition. | |
| 334 | (unless t1-subterms (return nil)) | |
| 335 | (let ((ng (!match-decompose-match (car t1-subterms) | |
| 336 | (car t2-subterms) | |
| 337 | res))) | |
| 338 | (when (and ng | |
| 339 | (!match-decompose-on-demand t1 t2 res)) | |
| 340 | (return-from !match-decompose-match t))) | |
| 341 | (setf t1-subterms (cdr t1-subterms) | |
| 342 | t2-subterms (cdr t2-subterms))) | |
| 343 | nil) | |
| 344 | ;; | |
| 345 | ;; if the theory has equational theory, we do not | |
| 346 | ;; perform full decomposition. | |
| 347 | ;; | |
| 348 | (progn | |
| 349 | (with-match-debug () | |
| 350 | (format t "~%>> has theory: add their pair.")) | |
| 351 | (push (make-equation t1 t2) (cdr res)) | |
| 352 | nil)) | |
| 353 | ||
| 354 | ;; | |
| 355 | ;; the different top level | |
| 356 | ;; possibly maches only when zero case or on-demand. | |
| 357 | ;; | |
| 358 | (if (term-is-on-demand? t2) | |
| 359 | (progn | |
| 360 | (with-match-debug () | |
| 361 | (format t "~%>> term t2 is on demand.")) | |
| 362 | (mark-term-as-not-on-demand t2) | |
| 363 | (if (normalize-term t2) | |
| 364 | ;; no reduction has been performed. | |
| 365 | (if (or (test-theory .Z. (theory-info-code th-info)) | |
| 366 | (test-theory .Z. (theory-info-code | |
| 367 | (method-theory-info-for-matching! | |
| 368 | (term-head t2))))) | |
| 369 | (progn (push (make-equation t1 t2) (cdr res)) | |
| 370 | nil) | |
| 371 | ;; will never match | |
| 372 | t) | |
| 373 | ;; t2 is rewritten | |
| 374 | (!match-decompose t1 t2 res))) | |
| 375 | ;; t2 is not on demand. | |
| 376 | (if (or (test-theory .Z. (theory-info-code th-info)) | |
| 377 | (test-theory .Z. (theory-info-code | |
| 378 | (method-theory-info-for-matching! | |
| 379 | (term-head t2))))) | |
| 380 | (progn | |
| 381 | (with-match-debug () | |
| 382 | (format t "~%>> theory Z.")) | |
| 383 | (push (make-equation t1 t2) (cdr res)) | |
| 384 | nil) | |
| 385 | ;; will never match | |
| 386 | t)) ))))))) | |
| 387 | ||
| 396 | 388 | |
| 397 | 389 | (defun match-decompose-equation (t1 t2 &optional (sigma nil)) |
| 398 | 390 | (declare (type term t1 t2)) |
| 399 | 391 | (when sigma |
| 400 | 392 | (setq sigma (copy-list sigma))) |
| 401 | 393 | (let* ((list-of-decomposed-equation (cons nil sigma)) |
| 402 | (no-match (if *do-unify* | |
| 403 | (!match-decompose-unify t1 t2 list-of-decomposed-equation) | |
| 404 | (!match-decompose-match t1 t2 list-of-decomposed-equation)))) | |
| 394 | (no-match (if *do-unify* | |
| 395 | (!match-decompose-unify t1 t2 list-of-decomposed-equation) | |
| 396 | (!match-decompose-match t1 t2 list-of-decomposed-equation)))) | |
| 405 | 397 | (declare (type list list-of-decomposed-equation) |
| 406 | (type (or null t) no-match)) | |
| 398 | (type (or null t) no-match)) | |
| 407 | 399 | (cond (no-match (values (cdr list-of-decomposed-equation) t)) ; no match |
| 408 | (t (if (cdr list-of-decomposed-equation) | |
| 409 | (let ((new-subst | |
| 410 | (normal-form-sub (cdr list-of-decomposed-equation) nil))) | |
| 411 | (if new-subst | |
| 412 | (values new-subst no-match) | |
| 413 | ;; | |
| 414 | (values (cdr list-of-decomposed-equation) no-match))) | |
| 415 | (values nil nil)))))) ; equational equal | |
| 400 | (t (if (cdr list-of-decomposed-equation) | |
| 401 | (let ((new-subst | |
| 402 | (normal-form-sub (cdr list-of-decomposed-equation) nil))) | |
| 403 | (if new-subst | |
| 404 | (values new-subst no-match) | |
| 405 | ;; | |
| 406 | (values (cdr list-of-decomposed-equation) no-match))) | |
| 407 | (values nil nil)))))) ; equational equal | |
| 416 | 408 | |
| 417 | 409 | (defun normal-form-sub (sub ans) |
| 418 | 410 | (if sub |
| 419 | 411 | ;; occur check here |
| 420 | 412 | (let* ((v1 (caar sub)) |
| 421 | (t1 (apply-subst ans (cdar sub))) | |
| 422 | (new-pair (make-equation v1 t1))) | |
| 423 | (if (occurs-in v1 t1) | |
| 424 | nil | |
| 425 | (normal-form-sub | |
| 426 | (cdr sub) | |
| 427 | (cons new-pair | |
| 428 | (mapcar #'(lambda (x) | |
| 429 | (make-equation | |
| 430 | (apply-subst (list new-pair) | |
| 431 | (equation-t1 x)) | |
| 432 | (apply-subst (list new-pair) | |
| 433 | (equation-t2 x)))) | |
| 434 | ans))))) | |
| 413 | (t1 (apply-subst ans (cdar sub))) | |
| 414 | (new-pair (make-equation v1 t1))) | |
| 415 | (if (occurs-in v1 t1) | |
| 416 | nil | |
| 417 | (normal-form-sub | |
| 418 | (cdr sub) | |
| 419 | (cons new-pair | |
| 420 | (mapcar #'(lambda (x) | |
| 421 | (make-equation | |
| 422 | (apply-subst (list new-pair) | |
| 423 | (equation-t1 x)) | |
| 424 | (apply-subst (list new-pair) | |
| 425 | (equation-t2 x)))) | |
| 426 | ans))))) | |
| 435 | 427 | ans)) |
| 436 | 428 | |
| 437 | 429 | #|| |
| 438 | 430 | (defun apply-subst (sigma term) |
| 439 | 431 | (if sigma |
| 440 | 432 | (cond ((term-is-variable? term) |
| 441 | (let ((im (variable-image sigma term))) | |
| 442 | (if im ; i.e. im = sigma(term) | |
| 443 | (values im t) | |
| 444 | (values term nil)))) | |
| 445 | ((term-is-builtin-constant? term) term) | |
| 446 | ((term-is-lisp-form? term) term) | |
| 447 | ((term-is-application-form? term) | |
| 448 | (let ((l-result nil) | |
| 449 | (modif-sort nil)) | |
| 450 | (dolist (s-t (term-subterms term)) | |
| 451 | (multiple-value-bind (image-s-t same-sort) | |
| 452 | (apply-subst sigma s-t) | |
| 453 | (unless same-sort | |
| 454 | ;; (update-lowest-parse s-t) | |
| 455 | (setq modif-sort t)) | |
| 456 | (push image-s-t l-result))) | |
| 457 | (setq l-result (nreverse l-result)) | |
| 458 | (if modif-sort | |
| 459 | (let ((term-image (make-term-with-sort-check (term-head term) | |
| 460 | l-result))) | |
| 461 | (values term-image | |
| 462 | (sort= (term-sort term) | |
| 463 | (term-sort term-image)))) | |
| 464 | (values (make-applform (term-sort term) | |
| 465 | (term-head term) | |
| 466 | l-result) | |
| 467 | t)))) | |
| 468 | (t (with-output-panic-message () | |
| 469 | (princ "apply-subst: encoutered illegual term") | |
| 470 | (terpri) | |
| 471 | (term-print term)))) | |
| 433 | (let ((im (variable-image sigma term))) | |
| 434 | (if im ; i.e. im = sigma(term) | |
| 435 | (values im t) | |
| 436 | (values term nil)))) | |
| 437 | ((term-is-builtin-constant? term) term) | |
| 438 | ((term-is-lisp-form? term) term) | |
| 439 | ((term-is-application-form? term) | |
| 440 | (let ((l-result nil) | |
| 441 | (modif-sort nil)) | |
| 442 | (dolist (s-t (term-subterms term)) | |
| 443 | (multiple-value-bind (image-s-t same-sort) | |
| 444 | (apply-subst sigma s-t) | |
| 445 | (unless same-sort | |
| 446 | ;; (update-lowest-parse s-t) | |
| 447 | (setq modif-sort t)) | |
| 448 | (push image-s-t l-result))) | |
| 449 | (setq l-result (nreverse l-result)) | |
| 450 | (if modif-sort | |
| 451 | (let ((term-image (make-term-with-sort-check (term-head term) | |
| 452 | l-result))) | |
| 453 | (values term-image | |
| 454 | (sort= (term-sort term) | |
| 455 | (term-sort term-image)))) | |
| 456 | (values (make-applform (term-sort term) | |
| 457 | (term-head term) | |
| 458 | l-result) | |
| 459 | t)))) | |
| 460 | (t (with-output-panic-message () | |
| 461 | (princ "apply-subst: encoutered illegual term") | |
| 462 | (terpri) | |
| 463 | (term-print term)))) | |
| 472 | 464 | term)) |
| 473 | 465 | ||# |
| 474 | 466 | |
| 475 | 467 | (defun apply-subst (sigma term) |
| 476 | 468 | (cond ((term-is-variable? term) |
| 477 | (let ((im (variable-image sigma term))) | |
| 478 | (if im ; i.e. im = sigma(term) | |
| 479 | (values im t) | |
| 480 | (values term nil)))) | |
| 481 | ((term-is-builtin-constant? term) term) | |
| 482 | ((term-is-lisp-form? term) term) | |
| 483 | ((term-is-application-form? term) | |
| 484 | (let ((l-result nil) | |
| 485 | (modif-sort nil)) | |
| 486 | (dolist (s-t (term-subterms term)) | |
| 487 | (multiple-value-bind (image-s-t same-sort) | |
| 488 | (apply-subst sigma s-t) | |
| 489 | (unless same-sort | |
| 490 | ;; (update-lowest-parse s-t) | |
| 491 | (setq modif-sort t)) | |
| 492 | (push image-s-t l-result))) | |
| 493 | (setq l-result (nreverse l-result)) | |
| 494 | (if modif-sort | |
| 495 | (let ((term-image (make-term-with-sort-check (term-head term) | |
| 496 | l-result))) | |
| 497 | (values term-image | |
| 498 | (sort= (term-sort term) | |
| 499 | (term-sort term-image)))) | |
| 500 | (values (make-applform (term-sort term) | |
| 501 | (term-head term) | |
| 502 | l-result) | |
| 503 | t)))) | |
| 504 | (t (with-output-panic-message () | |
| 505 | (princ "apply-subst: encoutered illegual term") | |
| 506 | (print-next) | |
| 507 | (term-print-with-sort term)))) | |
| 469 | (let ((im (variable-image sigma term))) | |
| 470 | (if im ; i.e. im = sigma(term) | |
| 471 | (values im t) | |
| 472 | (values term nil)))) | |
| 473 | ((term-is-builtin-constant? term) term) | |
| 474 | ((term-is-lisp-form? term) term) | |
| 475 | ((term-is-application-form? term) | |
| 476 | (let ((l-result nil) | |
| 477 | (modif-sort nil)) | |
| 478 | (dolist (s-t (term-subterms term)) | |
| 479 | (multiple-value-bind (image-s-t same-sort) | |
| 480 | (apply-subst sigma s-t) | |
| 481 | (unless same-sort | |
| 482 | ;; (update-lowest-parse s-t) | |
| 483 | (setq modif-sort t)) | |
| 484 | (push image-s-t l-result))) | |
| 485 | (setq l-result (nreverse l-result)) | |
| 486 | (if modif-sort | |
| 487 | (let ((term-image (make-term-with-sort-check (term-head term) | |
| 488 | l-result))) | |
| 489 | (values term-image | |
| 490 | (sort= (term-sort term) | |
| 491 | (term-sort term-image)))) | |
| 492 | (values (make-applform (term-sort term) | |
| 493 | (term-head term) | |
| 494 | l-result) | |
| 495 | t)))) | |
| 496 | (t (with-output-panic-message () | |
| 497 | (princ "apply-subst: encoutered illegual term") | |
| 498 | (print-next) | |
| 499 | (term-print-with-sort term)))) | |
| 508 | 500 | ) |
| 509 | 501 | |
| 510 | 502 | ;;; M-SYSTEM-TO-SOLVE ========================================================== |
| 533 | 525 | |
| 534 | 526 | (defun print-m-system (m) |
| 535 | 527 | (declare (type msystem m) |
| 536 | (values t)) | |
| 528 | (values t)) | |
| 537 | 529 | (dolist (e m) |
| 538 | 530 | (let ((t1 (equation-t1 e)) |
| 539 | (t2 (equation-t2 e))) | |
| 540 | (format t "~&===========") | |
| 531 | (t2 (equation-t2 e))) | |
| 532 | (format t "~%[m-system]===========") | |
| 541 | 533 | (format t "~&t1 = ") (term-print-with-sort t1) |
| 542 | 534 | (format t "~&t2 = ") (term-print-with-sort t2)))) |
| 543 | 535 | |
| 554 | 546 | (defmacro m-system-to-list (??_sys) |
| 555 | 547 | (once-only (??_sys) |
| 556 | 548 | ` (if (m-system-is-empty? ,??_sys) |
| 557 | (cdr ,??_sys) | |
| 549 | (cdr ,??_sys) | |
| 558 | 550 | ,??_sys))) |
| 559 | 551 | |
| 560 | 552 | (defmacro size-of-m-system (!_?sys) |
| 561 | 553 | (once-only (!_?sys) |
| 562 | 554 | ` (if (m-system-is-empty? ,!_?sys) |
| 563 | (length (the list (cdr ,!_?sys))) | |
| 564 | (length ,!_?sys)))) | |
| 555 | (length (the list (cdr ,!_?sys))) | |
| 556 | (length ,!_?sys)))) | |
| 565 | 557 | |
| 566 | 558 | ;;; Add an equation to the system. |
| 567 | 559 | ;;; |
| 568 | 560 | (defun add-equation-to-m-system (sys eq) |
| 569 | 561 | (declare (type list sys) |
| 570 | (type t eq) | |
| 571 | (values t)) | |
| 562 | (type t eq) | |
| 563 | (values t)) | |
| 572 | 564 | (unless (member eq sys :test #'eq) |
| 573 | 565 | (if (m-system-is-empty? sys) |
| 574 | (rplaca sys eq) ; remove the nil on top | |
| 575 | (rplacd sys (cons eq (cdr sys)))))) | |
| 566 | (rplaca sys eq) ; remove the nil on top | |
| 567 | (rplacd sys (cons eq (cdr sys)))))) | |
| 576 | 568 | |
| 577 | 569 | ;;; Returns a system from two list of equations. One of the two lists should be |
| 578 | 570 | ;;; non empty. Assumes each equation-t1 is not a variable. |
| 581 | 573 | |
| 582 | 574 | (defun make-m-system (l1 l2) |
| 583 | 575 | (declare (type list l1 l2) |
| 584 | (values msystem)) | |
| 576 | (values msystem)) | |
| 585 | 577 | (if (null (car l1)) |
| 586 | 578 | (union (cdr l1) l2) |
| 587 | 579 | (if (null (car l2)) |
| 588 | (union l1 (cdr l2)) | |
| 589 | (union l1 l2)))) | |
| 580 | (union l1 (cdr l2)) | |
| 581 | (union l1 l2)))) | |
| 590 | 582 | |
| 591 | 583 | ;;; Returns the biggest system extracted from "sys", which is homogenous with |
| 592 | 584 | ;;; respect to the current theory. |
| 603 | 595 | |
| 604 | 596 | (defun m-system-extract-one-system (sys) |
| 605 | 597 | (declare (type list sys) |
| 606 | (values list theory-info)) | |
| 598 | (values list theory-info)) | |
| 607 | 599 | (let ((extracted-sys nil) |
| 608 | (theory-is-empty nil) | |
| 609 | (disc-method nil)) | |
| 600 | (theory-is-empty nil) | |
| 601 | (disc-method nil)) | |
| 610 | 602 | (dolist (eq (m-system-to-list sys)) |
| 611 | 603 | (let ((t1 (equation-t1 eq))) |
| 612 | (declare (type term t1)) | |
| 613 | (if (term-is-application-form? t1) | |
| 614 | (let ((t1-top (term-method t1))) | |
| 615 | (cond | |
| 616 | ;; t1-top has no specific theory for matching. | |
| 617 | ((theory-info-empty-for-matching | |
| 618 | (method-theory-info-for-matching! t1-top)) | |
| 619 | (when disc-method | |
| 620 | (unless (theory-info-empty-for-matching | |
| 621 | (method-theory-info-for-matching! disc-method)) | |
| 622 | ;; The greatest priority is given to the empty theory. | |
| 623 | ;; The extracted system is reset. | |
| 624 | (setq disc-method t1-top) | |
| 625 | (setq extracted-sys nil))) | |
| 626 | (setq theory-is-empty t) | |
| 627 | (push eq extracted-sys)) | |
| 628 | ||
| 629 | ;; t1-top has non empty theory. | |
| 630 | (t (if disc-method | |
| 631 | ;; Gather homogenous ones. | |
| 632 | (when (method-is-of-same-operator+ disc-method t1-top) | |
| 633 | (push eq extracted-sys)) | |
| 634 | (unless theory-is-empty | |
| 635 | (setq disc-method t1-top) | |
| 636 | (push eq extracted-sys)))))) | |
| 637 | (progn | |
| 638 | (setq theory-is-empty t) | |
| 639 | (push eq extracted-sys) | |
| 640 | (setq disc-method nil))))) | |
| 604 | (declare (type term t1)) | |
| 605 | (if (term-is-application-form? t1) | |
| 606 | (let ((t1-top (term-method t1))) | |
| 607 | (cond | |
| 608 | ;; t1-top has no specific theory for matching. | |
| 609 | ((theory-info-empty-for-matching | |
| 610 | (method-theory-info-for-matching! t1-top)) | |
| 611 | (when disc-method | |
| 612 | (unless (theory-info-empty-for-matching | |
| 613 | (method-theory-info-for-matching! disc-method)) | |
| 614 | ;; The greatest priority is given to the empty theory. | |
| 615 | ;; The extracted system is reset. | |
| 616 | (setq disc-method t1-top) | |
| 617 | (setq extracted-sys nil))) | |
| 618 | (setq theory-is-empty t) | |
| 619 | (push eq extracted-sys)) | |
| 620 | ||
| 621 | ;; t1-top has non empty theory. | |
| 622 | (t (if disc-method | |
| 623 | ;; Gather homogenous ones. | |
| 624 | (when (method-is-of-same-operator+ disc-method t1-top) | |
| 625 | (push eq extracted-sys)) | |
| 626 | (unless theory-is-empty | |
| 627 | (setq disc-method t1-top) | |
| 628 | (push eq extracted-sys)))))) | |
| 629 | (progn | |
| 630 | (setq theory-is-empty t) | |
| 631 | (push eq extracted-sys) | |
| 632 | (setq disc-method nil))))) | |
| 641 | 633 | (values extracted-sys |
| 642 | (if disc-method | |
| 643 | (method-theory-info-for-matching! disc-method) | |
| 644 | (theory-info *the-empty-theory*))))) | |
| 634 | (if disc-method | |
| 635 | (method-theory-info-for-matching! disc-method) | |
| 636 | (theory-info *the-empty-theory*))))) | |
| 645 | 637 | |
| 646 | 638 | ;;; MATCH ENVIRONMENT ========================================================== |
| 647 | 639 | |
| 672 | 664 | (once-only (?_!env) |
| 673 | 665 | `(if (null (car ,?_!env)) |
| 674 | 666 | (cdr ,?_!env) |
| 675 | ,?_!env))) | |
| 667 | ,?_!env))) | |
| 676 | 668 | |
| 677 | 669 | (defun add-equation-to-environment (env eq) |
| 678 | 670 | (if (null (car env)) |
| 679 | 671 | (rplaca env eq) |
| 680 | (rplacd env (push eq (cdr env))))) | |
| 672 | (rplacd env (push eq (cdr env))))) | |
| 681 | 673 | |
| 682 | 674 | (defmacro environment-copy1 (___?env) `(copy-list ,___?env)) |
| 683 | 675 | |
| 687 | 679 | (once-only (??_?env ??_?var) |
| 688 | 680 | `(if (null (car ,??_?env)) |
| 689 | 681 | (cdr (assoc ,??_?var (cdr ,??_?env) :test #'variable-eq)) |
| 690 | (cdr (assoc ,??_?var ,??_?env :test #'variable-eq))))) | |
| 682 | (cdr (assoc ,??_?var ,??_?env :test #'variable-eq))))) | |
| 691 | 683 | |
| 692 | 684 | ;;; { ... x == t ...} U { ... x == t' ...} |
| 693 | 685 | ;;; |
| 698 | 690 | ;;; must not be modified. |
| 699 | 691 | ;;; U: used by "match-system.dec-merg" and "match-add-m-system" |
| 700 | 692 | |
| 701 | (defun match-insert-if-coherent-with (new-env test-env new-sys eq-list | |
| 702 | &optional check-match) | |
| 693 | (defun match-insert-if-coherent-with (new-env test-env new-sys eq-list &optional (check-match nil)) | |
| 703 | 694 | ;; note that new-env and new-sys are both initialy of the form (nil.nil) |
| 704 | 695 | (block the-end |
| 705 | (when *match-debug* | |
| 706 | (format T "~&insert:--------------------------------------") | |
| 707 | (format t "~& new-env = ") | |
| 696 | (with-match-debug () | |
| 697 | (format T "~%insert:--------------------------------------") | |
| 698 | (print-next) | |
| 699 | (format t "new-env = ") | |
| 708 | 700 | (if (car new-env) |
| 709 | (dolist (eq new-env) | |
| 710 | (format t "~% LHS = ") (term-print-with-sort (equation-t1 eq))(terpri) | |
| 711 | (format t "~% RHS = ") (term-print-with-sort (equation-t2 eq))(terpri)) | |
| 712 | (princ "empty")) | |
| 713 | (format t "~& test-env = ") | |
| 701 | (dolist (eq new-env) | |
| 702 | (print-next) | |
| 703 | (format t "~% LHS = ") (term-print-with-sort (equation-t1 eq)) | |
| 704 | (print-next) | |
| 705 | (format t " RHS = ") (term-print-with-sort (equation-t2 eq)) | |
| 706 | (princ "empty"))) | |
| 707 | (print-next) | |
| 708 | (format t "test-env = ") | |
| 714 | 709 | (if (car test-env) |
| 715 | (dolist (eq test-env) | |
| 716 | (format t "~% LHS = ") (term-print-with-sort (equation-t1 eq)) (terpri) | |
| 717 | (format t "~% RHS = ") (term-print-with-sort (equation-t2 eq)) (terpri)) | |
| 718 | (princ "empty"))) | |
| 710 | (dolist (eq test-env) | |
| 711 | (format t "~% LHS = ") (term-print-with-sort (equation-t1 eq)) | |
| 712 | (print-next) | |
| 713 | (format t " RHS = ") (term-print-with-sort (equation-t2 eq))) | |
| 714 | (princ "empty")) | |
| 715 | (terpri)) | |
| 719 | 716 | (dolist (eq eq-list) |
| 720 | 717 | (let ((t1 (equation-t1 eq)) |
| 721 | (t2 (equation-t2 eq))) | |
| 722 | (when *match-debug* | |
| 723 | (format t "~& t1 = ") (term-print-with-sort t1) (terpri) | |
| 724 | (format t "~& t2 = ") (term-print-with-sort t2) (terpri)) | |
| 725 | (cond ((term-is-variable? t1) | |
| 726 | ;; checking of the sort information; redundant with | |
| 727 | ;; `decompose-equation'. | |
| 728 | (unless (sort<= (term-sort t2) (variable-sort t1) | |
| 729 | *current-sort-order*) | |
| 730 | (when *match-debug* | |
| 731 | (format t "~&-- non coherent, sort match fail.")) | |
| 732 | (return-from the-end t)) | |
| 733 | ;; new-env may be modified. | |
| 734 | (let ((image-of-t1 (variable-image test-env t1))) | |
| 735 | (if image-of-t1 | |
| 736 | (unless (term-equational-equal image-of-t1 t2) | |
| 737 | (when *match-debug* | |
| 738 | (format t "~&-- non coherent, var binding conflicts in env.")) | |
| 739 | (return-from the-end t)) ; i.e no-coherent | |
| 740 | (let ((image-of-t1-in-new (variable-image new-env t1))) | |
| 741 | (if image-of-t1-in-new | |
| 742 | (unless (term-equational-equal image-of-t1-in-new | |
| 743 | t2) | |
| 744 | (when *match-debug* | |
| 745 | (format t "~&-- non coherent, var binding in new-env.")) | |
| 746 | (return-from the-end t)) | |
| 747 | (add-equation-to-environment new-env eq)))))) | |
| 748 | (check-match | |
| 749 | (when (term-is-variable? t2) | |
| 750 | (return-from the-end t)) | |
| 751 | (if (and (term-is-applform? t2) | |
| 752 | (term-is-applform? t1)) | |
| 753 | (let ((t1-head (term-head t1)) | |
| 754 | (t2-head (term-head t2))) | |
| 755 | (if (method-is-of-same-operator+ t1-head t2-head) | |
| 756 | (add-equation-to-m-system new-sys eq) | |
| 757 | (let ((match-info (method-theory-info-for-matching! t1-head))) | |
| 758 | (if (test-theory .Z. (theory-info-code match-info)) | |
| 759 | (add-equation-to-m-system new-sys eq) | |
| 760 | (progn | |
| 761 | (when *match-debug* | |
| 762 | (format t "~&-- non coherent, func conflict.")) | |
| 763 | (return-from the-end t)))))) | |
| 764 | (add-equation-to-m-system new-sys eq))) | |
| 765 | ;; | |
| 766 | (t (add-equation-to-m-system new-sys eq))))) | |
| 718 | (t2 (equation-t2 eq))) | |
| 719 | (cond ((term-is-variable? t1) | |
| 720 | ;; checking of the sort information; redundant with | |
| 721 | ;; `decompose-equation'. | |
| 722 | (unless (sort<= (term-sort t2) (variable-sort t1) | |
| 723 | *current-sort-order*) | |
| 724 | (with-match-debug () | |
| 725 | (print-next) | |
| 726 | (format t "-- non coherent, sort match fail.")) | |
| 727 | (return-from the-end t)) | |
| 728 | ;; new-env may be modified. | |
| 729 | (let ((image-of-t1 (variable-image test-env t1))) | |
| 730 | (if image-of-t1 | |
| 731 | (unless (term-equational-equal image-of-t1 t2) | |
| 732 | (with-match-debug () | |
| 733 | (format t "~%-- non coherent, var binding conflicts in env.")) | |
| 734 | (return-from the-end t)) ; i.e no-coherent | |
| 735 | (let ((image-of-t1-in-new (variable-image new-env t1))) | |
| 736 | (if image-of-t1-in-new | |
| 737 | (unless (term-equational-equal image-of-t1-in-new | |
| 738 | t2) | |
| 739 | (with-match-debug () | |
| 740 | (format t "~%-- non coherent, var binding in new-env.")) | |
| 741 | (return-from the-end t)) | |
| 742 | (add-equation-to-environment new-env eq)))))) | |
| 743 | (check-match | |
| 744 | (when (term-is-variable? t2) | |
| 745 | (with-match-debug () | |
| 746 | (format t "~%-- non coherent, t2 is variable.")) | |
| 747 | (return-from the-end t)) | |
| 748 | (if (and (term-is-applform? t2) | |
| 749 | (term-is-applform? t1)) | |
| 750 | (let ((t1-head (term-head t1)) | |
| 751 | (t2-head (term-head t2))) | |
| 752 | (if (method-is-of-same-operator+ t1-head t2-head) | |
| 753 | (add-equation-to-m-system new-sys eq) | |
| 754 | (let ((match-info (method-theory-info-for-matching! t1-head))) | |
| 755 | (if (test-theory .Z. (theory-info-code match-info)) | |
| 756 | (add-equation-to-m-system new-sys eq) | |
| 757 | (progn | |
| 758 | (with-match-debug () | |
| 759 | (format t "~%-- non coherent, func conflict.")) | |
| 760 | (return-from the-end t)))))) | |
| 761 | (add-equation-to-m-system new-sys eq))) | |
| 762 | ;; | |
| 763 | (t (add-equation-to-m-system new-sys eq))))) | |
| 767 | 764 | |
| 768 | 765 | ;; add now all the equation of test-env into new-env (copy test-env) |
| 769 | 766 | (cond ((null (car test-env)) ()) |
| 770 | ((null (car new-env)) | |
| 771 | (let ((l (environment-copy1 test-env))) | |
| 772 | (rplaca new-env (car l)) | |
| 773 | (rplacd new-env (cdr l))) ) | |
| 774 | (t (nconc new-env test-env))) | |
| 775 | (when *match-debug* | |
| 776 | (format t "~& insert: return -- coherent -------------------")) | |
| 777 | nil ; i.e. the new-env is coherent | |
| 767 | ((null (car new-env)) | |
| 768 | (let ((l (environment-copy1 test-env))) | |
| 769 | (rplaca new-env (car l)) | |
| 770 | (rplacd new-env (cdr l))) ) | |
| 771 | (t (nconc new-env test-env))) | |
| 772 | (with-match-debug () | |
| 773 | (format t "~%insert: return -- coherent -------------------") | |
| 774 | ||
| 775 | ) | |
| 776 | nil ; i.e. the new-env is coherent | |
| 778 | 777 | )) |
| 779 | 778 | |
| 779 | #|| | |
| 780 | (defun match-insert-if-coherent-with (new-env test-env new-sys eq-list &optional (check-match nil)) | |
| 781 | ;; note that new-env and new-sys are both initialy of the form (nil.nil) | |
| 782 | (block the-end | |
| 783 | (dolist (eq eq-list) | |
| 784 | (let ((t1 (equation-t1 eq)) | |
| 785 | (t2 (equation-t2 eq))) | |
| 786 | (cond ((term-is-variable? t1) | |
| 787 | ;; checking of the sort information; redundant with | |
| 788 | ;; `decompose-equation'. | |
| 789 | (unless (sort<= (term-sort t2) (variable-sort t1) | |
| 790 | *current-sort-order*) | |
| 791 | (return-from the-end t)) | |
| 792 | ;; new-env may be modified. | |
| 793 | (let ((image-of-t1 (variable-image test-env t1))) | |
| 794 | (if image-of-t1 | |
| 795 | (unless (term-equational-equal image-of-t1 t2) | |
| 796 | (return-from the-end t)) ; i.e no-coherent | |
| 797 | (let ((image-of-t1-in-new (variable-image new-env t1))) | |
| 798 | (if image-of-t1-in-new | |
| 799 | (unless (term-equational-equal image-of-t1-in-new t2) | |
| 800 | (return-from the-end t)) | |
| 801 | (add-equation-to-environment new-env eq)))))) | |
| 802 | (check-match | |
| 803 | (when (term-is-variable? t2) | |
| 804 | (return-from the-end t)) | |
| 805 | (if (and (term-is-applform? t2) | |
| 806 | (term-is-applform? t1)) | |
| 807 | (let ((t1-head (term-head t1)) | |
| 808 | (t2-head (term-head t2))) | |
| 809 | (if (method-is-of-same-operator+ t1-head t2-head) | |
| 810 | (add-equation-to-m-system new-sys eq) | |
| 811 | (let ((match-info (method-theory-info-for-matching! t1-head))) | |
| 812 | (if (test-theory .Z. (theory-info-code match-info)) | |
| 813 | (add-equation-to-m-system new-sys eq) | |
| 814 | (progn | |
| 815 | (return-from the-end t)))))) | |
| 816 | (add-equation-to-m-system new-sys eq))) | |
| 817 | ;; | |
| 818 | (t (add-equation-to-m-system new-sys eq))))) | |
| 819 | ||
| 820 | ;; add now all the equation of test-env into new-env (copy test-env) | |
| 821 | (cond ((null (car test-env)) ()) | |
| 822 | ((null (car new-env)) | |
| 823 | (let ((l (environment-copy1 test-env))) | |
| 824 | (rplaca new-env (car l)) | |
| 825 | (rplacd new-env (cdr l))) ) | |
| 826 | (t (nconc new-env test-env))) | |
| 827 | nil ; i.e. the new-env is coherent | |
| 828 | )) | |
| 829 | ||# | |
| 830 | ||
| 780 | 831 | ;;; MATCH-SYSTEM =========================================================== |
| 781 | 832 | ;;; |
| 782 | 833 | ;;; The pair of environment and m-system . |
| 783 | 834 | ;;; |
| 784 | 835 | (defstruct (match-system |
| 785 | (:constructor create-match-system (environment system-to-solve))) | |
| 786 | (environment (new-environment) :type list) | |
| 836 | (:constructor create-match-system (environment system-to-solve))) | |
| 837 | (environment (new-environment) :type list) | |
| 787 | 838 | (system-to-solve (new-m-system) :type list)) |
| 788 | 839 | |
| 789 | 840 | (defmacro match-system-sys (ms___?) `(match-system-system-to-solve ,ms___?)) |
| 823 | 874 | (defun print-match-equations (eqs) |
| 824 | 875 | (dolist (e eqs) |
| 825 | 876 | (if (null e) (princ "NIL") |
| 826 | (print-match-equation e)) | |
| 877 | (print-match-equation e)) | |
| 827 | 878 | (print-next)) |
| 828 | 879 | ) |
| 829 | 880 | |
| 839 | 890 | (declaim (inline new-match-system)) |
| 840 | 891 | (defun new-match-system (term1 term2) |
| 841 | 892 | (declare (type term term1 term2) |
| 842 | (values match-system)) | |
| 893 | (values match-system)) | |
| 843 | 894 | (if (term-is-variable? term1) |
| 844 | 895 | (create-match-system (create-environment term1 term2) |
| 845 | (new-m-system)) | |
| 846 | (create-match-system (new-environment) | |
| 847 | (create-m-system term1 term2)))) | |
| 896 | (new-m-system)) | |
| 897 | (create-match-system (new-environment) | |
| 898 | (create-m-system term1 term2)))) | |
| 848 | 899 | |
| 849 | 900 | ;;; returns from a match-system a system (equivalent) |
| 850 | 901 | ;;; |
| 851 | 902 | (defmacro match-system-to-m-system (__?m-sys?) |
| 852 | 903 | (once-only (__?m-sys?) |
| 853 | 904 | ` (make-m-system (m-system-to-list (match-system-sys ,__?m-sys?)) |
| 854 | (environment-to-list (match-system-env ,__?m-sys?))))) | |
| 905 | (environment-to-list (match-system-env ,__?m-sys?))))) | |
| 855 | 906 | |
| 856 | 907 | |
| 857 | 908 | ;;; MATCH-SYSTEM-E-EQUAL : math-system -> bool |
| 860 | 911 | ;;; |
| 861 | 912 | (defun match-system-e-equal (match-system) |
| 862 | 913 | (declare (type match-system match-system) |
| 863 | (values (or t null))) | |
| 914 | (values (or t null))) | |
| 864 | 915 | (and (dolist (eq (m-system-to-list (match-system-sys match-system)) t) |
| 865 | (unless (term-equational-equal (equation-t1 eq) (equation-t2 eq)) | |
| 866 | (return nil))) | |
| 916 | (unless (term-equational-equal (equation-t1 eq) (equation-t2 eq)) | |
| 917 | (return nil))) | |
| 867 | 918 | (dolist (eq (environment-to-list (match-system-environment match-system)) t) |
| 868 | (unless (term-equational-equal (equation-t1 eq) (equation-t2 eq)) | |
| 869 | (return nil))))) | |
| 919 | (unless (term-equational-equal (equation-t1 eq) (equation-t2 eq)) | |
| 920 | (return nil))))) | |
| 870 | 921 | |
| 871 | 922 | ;;; add try to returns a NEW match-system containing the (set) union of "sys" |
| 872 | 923 | ;;; and "m-sys". For this purpose, it inserts in a new match-system the equation |
| 880 | 931 | (defun match-add-m-system (match-system m-sys) |
| 881 | 932 | (block no-match |
| 882 | 933 | (let* ((old-environment (match-system-environment match-system)) |
| 883 | (new-environment (new-environment)) | |
| 884 | (new-system (new-m-system))) | |
| 934 | (new-environment (new-environment)) | |
| 935 | (new-system (new-m-system))) | |
| 885 | 936 | ;; then we insert all the equations of "system" in this new system if |
| 886 | 937 | ;; they are compatible with match-system and copy the environment. |
| 887 | 938 | (when (match-insert-if-coherent-with new-environment |
| 888 | old-environment | |
| 889 | new-system | |
| 890 | (m-system-to-list m-sys) | |
| 891 | ) | |
| 892 | (return-from no-match (values nil t))) | |
| 939 | old-environment | |
| 940 | new-system | |
| 941 | (m-system-to-list m-sys) | |
| 942 | ) | |
| 943 | (return-from no-match (values nil t))) | |
| 944 | ||
| 945 | (with-match-debug () | |
| 946 | (format t "~%[Match-add-m-system]: given ---------------~%") | |
| 947 | (print-match-system match-system) | |
| 948 | (format t "~% m-sys") | |
| 949 | (dolist (eq (m-system-to-list m-sys)) | |
| 950 | (let ((t1 (equation-t1 eq)) | |
| 951 | (t2 (equation-t2 eq))) | |
| 952 | (print-next) | |
| 953 | (princ "t1: ")(term-print-with-sort t1) | |
| 954 | (print-next) | |
| 955 | (princ "t2: ")(term-print-with-sort t2)))) | |
| 893 | 956 | |
| 894 | 957 | ;; new-system is modified but not match-system |
| 895 | 958 | (setq new-system (add-m-system new-system (match-system-sys match-system))) |
| 896 | (return-from no-match | |
| 897 | (values (create-match-system new-environment | |
| 898 | new-system) | |
| 899 | nil))))) | |
| 959 | (let ((nsys (create-match-system new-environment new-system))) | |
| 960 | (with-match-debug () | |
| 961 | (format t "~%[MATCH-ADD-M-SYSTEM]: generated new sys ----~%") | |
| 962 | (print-match-system nsys)) | |
| 963 | (return-from no-match (values nsys nil)))))) | |
| 900 | 964 | |
| 901 | 965 | ;;; Decompose&Merge |
| 902 | 966 | ;;; Returns the decompose and merging of the given match-system |
| 904 | 968 | (defun match-decompose&merge (m-sys &optional sigma) |
| 905 | 969 | (block no-match |
| 906 | 970 | (let ((sys (match-system-sys m-sys)) |
| 907 | (env (match-system-env m-sys)) | |
| 908 | (new-env (new-environment) ) | |
| 909 | (new-sys (new-m-system))) | |
| 971 | (env (match-system-env m-sys)) | |
| 972 | (new-env (new-environment) ) | |
| 973 | (new-sys (new-m-system))) | |
| 910 | 974 | (declare (type list new-env new-sys)) |
| 911 | 975 | (dolist (eq (m-system-to-list sys)) |
| 912 | (multiple-value-bind (eq-list clash-of-symbol) | |
| 913 | (match-decompose-equation (equation-t1 eq) (equation-t2 eq) sigma) | |
| 914 | (if clash-of-symbol | |
| 915 | (return-from no-match (values nil t)) | |
| 916 | (when (match-insert-if-coherent-with new-env | |
| 917 | env | |
| 918 | new-sys | |
| 919 | eq-list) | |
| 920 | (return-from no-match (values nil t)))))) | |
| 921 | (values (create-match-system new-env | |
| 922 | new-sys) | |
| 923 | nil)))) | |
| 976 | (multiple-value-bind (eq-list clash-of-symbol) | |
| 977 | (match-decompose-equation (equation-t1 eq) (equation-t2 eq) sigma) | |
| 978 | (if clash-of-symbol | |
| 979 | (return-from no-match (values nil t)) | |
| 980 | (when (match-insert-if-coherent-with new-env | |
| 981 | env | |
| 982 | new-sys | |
| 983 | eq-list) | |
| 984 | (return-from no-match (values nil t)))))) | |
| 985 | (let ((msys (create-match-system new-env new-sys))) | |
| 986 | (with-match-debug () | |
| 987 | (format t "~%[Match-Decompose&Merge]: match system created: ----~%") | |
| 988 | (print-match-system msys)) | |
| 989 | (values msys nil))))) | |
| 990 | ||
| 924 | 991 | |
| 925 | 992 | ;;; Extracts from the non fully decomposed part of "m-s" the biggest system to |
| 926 | 993 | ;;; be solved into the theory "th". "th" and "sys" are returned. |
| 929 | 996 | (declare (inline m-system-extract-one-system)) |
| 930 | 997 | (let ((sys (match-system-sys m-s))) |
| 931 | 998 | (if (m-system-is-empty? sys) |
| 932 | (values nil (theory-info *the-empty-theory*)) | |
| 933 | (m-system-extract-one-system sys)))) | |
| 999 | (values nil (theory-info *the-empty-theory*)) | |
| 1000 | (m-system-extract-one-system sys)))) | |
| 934 | 1001 | |
| 935 | 1002 | ;;; returns a new match-system with the same environment that "m-sys" but with a |
| 936 | 1003 | ;;; system equal to the system of m-sys except the elements in "sys". |
| 938 | 1005 | ;;; |
| 939 | 1006 | (defun match-system-modif-m-sys (m-sys sys) |
| 940 | 1007 | (declare (type match-system m-sys) |
| 941 | (type list sys) | |
| 942 | (values match-system)) | |
| 1008 | (type list sys) | |
| 1009 | (values match-system)) | |
| 943 | 1010 | (flet ((difference-eq (x y) |
| 944 | (let ((res nil)) | |
| 945 | (dolist (xe x res) | |
| 946 | (unless (dolist (ye y nil) (when (eq xe ye) (return t))) | |
| 947 | (push xe res)))))) | |
| 1011 | (let ((res nil)) | |
| 1012 | (dolist (xe x res) | |
| 1013 | (unless (dolist (ye y nil) (when (eq xe ye) (return t))) | |
| 1014 | (push xe res)))))) | |
| 948 | 1015 | (create-match-system (environment-copy1 (match-system-env m-sys)) |
| 949 | (difference-eq (m-system-to-list (match-system-sys m-sys)) | |
| 950 | sys)))) | |
| 1016 | (difference-eq (m-system-to-list (match-system-sys m-sys)) | |
| 1017 | sys)))) | |
| 951 | 1018 | |
| 952 | 1019 | ;;; EOF |
| 0 | ;;;-*- Mode:LISP; Package:CAFEIN; Base:10; Syntax:Common-lisp -*- | |
| 0 | ;;;-*- Mode:LISP; Package:CHAOS; Base:10; Syntax:Common-lisp -*- | |
| 1 | 1 | ;;; |
| 2 | ;;; Copyright (c) 2000-2014, Toshimi Sawada. All rights reserved. | |
| 2 | ;;; Copyright (c) 2000-2015, Toshimi Sawada. All rights reserved. | |
| 3 | 3 | ;;; |
| 4 | 4 | ;;; Redistribution and use in source and binary forms, with or without |
| 5 | 5 | ;;; modification, are permitted provided that the following conditions |
| 27 | 27 | ;;; |
| 28 | 28 | (in-package :chaos) |
| 29 | 29 | #|============================================================================== |
| 30 | System:Chaos | |
| 31 | Module:e-match | |
| 32 | File:match-utils.lisp | |
| 30 | System:Chaos | |
| 31 | Module:e-match | |
| 32 | File:match-utils.lisp | |
| 33 | 33 | ==============================================================================|# |
| 34 | 34 | #-:chaos-debug |
| 35 | 35 | (declaim (optimize (speed 3) (safety 0) #-GCL (debug 0))) |
| 36 | 36 | #+:chaos-debug |
| 37 | 37 | (declaim (optimize (speed 1) (safety 3) #-GCL (debug 3))) |
| 38 | ||
| 39 | ;;; For Debug | |
| 40 | ;;; | |
| 41 | (defmacro with-match-debug (&rest body) | |
| 42 | `(when *match-debug* | |
| 43 | (let ((*print-indent* (+ 2 *print-indent*)) | |
| 44 | (*print-line-limit* 90)) | |
| 45 | (declare (type fixnum *print-indent* *print-line-limit*)) | |
| 46 | ,@body))) | |
| 38 | 47 | |
| 39 | 48 | ;;; POSSIBLY-MATCHES : PATTERN TARGET -> BOOL |
| 40 | 49 | ;;;----------------------------------------------------------------------------- |
| 46 | 55 | ;;; |
| 47 | 56 | (defun possibly-matches-nonvar (t1 t2) |
| 48 | 57 | (declare (type term t1 t2) |
| 49 | (values (or null t))) | |
| 58 | (values (or null t))) | |
| 50 | 59 | (cond ((term-is-builtin-constant? t1) |
| 51 | (term-builtin-equal t1 t2)) | |
| 52 | ((term-is-builtin-constant? t2) nil) | |
| 53 | (t | |
| 54 | (let* ((meth1 (term-head t1)) | |
| 55 | (meth2 (term-head t2)) | |
| 56 | (th-info-1 (method-theory-info-for-matching meth1)) | |
| 57 | (th-info-2 (method-theory-info-for-matching meth2))) | |
| 58 | (if (not (method-is-of-same-operator+ meth1 meth2)) | |
| 59 | ;; built-in identity matching requires a change here | |
| 60 | ;; somehow the usage of theories seems messy here. | |
| 61 | (if (test-theory .Z. (theory-info-code th-info-1)) | |
| 62 | ;; too costly? | |
| 63 | (or (possibly-matches (term-arg-1 t1) t2) | |
| 64 | (possibly-matches (term-arg-2 t1) t2)) | |
| 65 | nil) | |
| 66 | (let ((chk1 (theory-info-empty-for-matching th-info-1)) | |
| 67 | (chk2 (theory-info-empty-for-matching th-info-2))) | |
| 68 | (if (and chk1 chk2) | |
| 69 | (let ((subs1 (term-subterms t1)) | |
| 70 | (subs2 (term-subterms t2)) | |
| 71 | (ok? t)) | |
| 72 | (while subs1 | |
| 73 | (unless (possibly-matches (car subs1) (car subs2)) | |
| 74 | (setq ok? nil) | |
| 75 | (return)) | |
| 76 | (setq subs1 (cdr subs1) | |
| 77 | subs2 (cdr subs2))) | |
| 78 | ok?) | |
| 79 | t))))))) | |
| 60 | (term-builtin-equal t1 t2)) | |
| 61 | ((term-is-builtin-constant? t2) nil) | |
| 62 | (t | |
| 63 | (let* ((meth1 (term-head t1)) | |
| 64 | (meth2 (term-head t2)) | |
| 65 | (th-info-1 (method-theory-info-for-matching meth1)) | |
| 66 | (th-info-2 (method-theory-info-for-matching meth2))) | |
| 67 | (if (not (method-is-of-same-operator+ meth1 meth2)) | |
| 68 | ;; built-in identity matching requires a change here | |
| 69 | ;; somehow the usage of theories seems messy here. | |
| 70 | (if (test-theory .Z. (theory-info-code th-info-1)) | |
| 71 | ;; too costly? | |
| 72 | (or (possibly-matches (term-arg-1 t1) t2) | |
| 73 | (possibly-matches (term-arg-2 t1) t2)) | |
| 74 | nil) | |
| 75 | (let ((chk1 (theory-info-empty-for-matching th-info-1)) | |
| 76 | (chk2 (theory-info-empty-for-matching th-info-2))) | |
| 77 | (if (and chk1 chk2) | |
| 78 | (let ((subs1 (term-subterms t1)) | |
| 79 | (subs2 (term-subterms t2)) | |
| 80 | (ok? t)) | |
| 81 | (while subs1 | |
| 82 | (unless (possibly-matches (car subs1) (car subs2)) | |
| 83 | (setq ok? nil) | |
| 84 | (return)) | |
| 85 | (setq subs1 (cdr subs1) | |
| 86 | subs2 (cdr subs2))) | |
| 87 | ok?) | |
| 88 | t))))))) | |
| 80 | 89 | |
| 81 | 90 | ;;; could improve on this |
| 82 | 91 | ;;; t1 : pattern |
| 83 | 92 | ;;; t2 : term |
| 84 | 93 | (defun possibly-matches (t1 t2) |
| 85 | 94 | (declare (type term t1 t2) |
| 86 | (values (or null t))) | |
| 95 | (values (or null t))) | |
| 87 | 96 | (cond ((term-is-variable? t1) t) |
| 88 | ((term-is-variable? t2) nil) | |
| 89 | (t (possibly-matches-nonvar t1 t2)))) | |
| 97 | ((term-is-variable? t2) nil) | |
| 98 | (t (possibly-matches-nonvar t1 t2)))) | |
| 90 | 99 | |
| 91 | 100 | ;;; EOF |
| 0 | 0 | ;;;-*- Mode:Lisp; Syntax:CommonLisp; Package:CHAOS -*- |
| 1 | 1 | ;;; |
| 2 | ;;; Copyright (c) 2000-2014, Toshimi Sawada. All rights reserved. | |
| 2 | ;;; Copyright (c) 2000-2015, Toshimi Sawada. All rights reserved. | |
| 3 | 3 | ;;; |
| 4 | 4 | ;;; Redistribution and use in source and binary forms, with or without |
| 5 | 5 | ;;; modification, are permitted provided that the following conditions |
| 27 | 27 | ;;; |
| 28 | 28 | (in-package :chaos) |
| 29 | 29 | #|============================================================================== |
| 30 | System:Chaos | |
| 31 | Module:e-match | |
| 32 | File:match-z.lisp | |
| 30 | System:Chaos | |
| 31 | Module:e-match | |
| 32 | File:match-z.lisp | |
| 33 | 33 | ==============================================================================|# |
| 34 | 34 | #-:chaos-debug |
| 35 | 35 | (declaim (optimize (speed 3) (safety 0) #-GCL (debug 0))) |
| 41 | 41 | ;;; |
| 42 | 42 | |
| 43 | 43 | (defstruct (match-z-state |
| 44 | (:constructor create-match-z-state (n sys))) | |
| 44 | (:constructor create-match-z-state (n sys))) | |
| 45 | 45 | (n 0 :type fixnum) |
| 46 | (sys nil :type list) ; match system | |
| 46 | (sys nil :type list) ; match system | |
| 47 | 47 | ) |
| 48 | 48 | |
| 49 | 49 | ;;; INITIALIZATION |
| 59 | 59 | |
| 60 | 60 | (defun match-Z-next-state (Z-st) |
| 61 | 61 | (let* ((sys (match-z-state-sys Z-st)) |
| 62 | (point (m-system-to-list sys)) | |
| 63 | (equation nil) | |
| 64 | (r 0) | |
| 65 | (t1 nil) | |
| 66 | (t2 nil) | |
| 67 | (new-sys (new-m-system)) | |
| 68 | (lg (length point)) | |
| 69 | (meth1 nil) | |
| 70 | (meth2 nil) | |
| 71 | ) | |
| 62 | (point (m-system-to-list sys)) | |
| 63 | (equation nil) | |
| 64 | (r 0) | |
| 65 | (t1 nil) | |
| 66 | (t2 nil) | |
| 67 | (new-sys (new-m-system)) | |
| 68 | (lg (length point)) | |
| 69 | (meth1 nil) | |
| 70 | (meth2 nil) | |
| 71 | ) | |
| 72 | 72 | (declare (type fixnum r lg) |
| 73 | (type list point new-sys)) | |
| 73 | (type list point new-sys)) | |
| 74 | 74 | (do* ((N (match-z-state-n Z-st)) |
| 75 | (q N N) | |
| 76 | (point2 point point)) | |
| 77 | ((or (not (m-system-is-empty? new-sys)) | |
| 78 | (>= N (the fixnum (expt 5 (the fixnum lg))))) | |
| 79 | (progn (setf (match-z-state-n Z-st) N) | |
| 80 | (if (not (m-system-is-empty? new-sys)) | |
| 81 | (values new-sys Z-st nil) ;success case | |
| 82 | (values nil nil t)))) ; fail case | |
| 75 | (q N N) | |
| 76 | (point2 point point)) | |
| 77 | ((or (not (m-system-is-empty? new-sys)) | |
| 78 | (>= N (the fixnum (expt 5 (the fixnum lg))))) | |
| 79 | (progn (setf (match-z-state-n Z-st) N) | |
| 80 | (if (not (m-system-is-empty? new-sys)) | |
| 81 | (values new-sys Z-st nil) ;success case | |
| 82 | (values nil nil t)))) ; fail case | |
| 83 | 83 | (declare (type fixnum n q)) |
| 84 | (incf N) ; try the next N | |
| 85 | (dotimes (k lg) ; k = lg,...,1 | |
| 86 | (declare (type fixnum k)) ; this treats q as a bitvector in base 5 | |
| 87 | (multiple-value-setq (q r) (truncate q 5)) | |
| 88 | (setq equation (car point2) | |
| 89 | point2 (cdr point2) | |
| 90 | t1 (equation-t1 equation) | |
| 91 | t2 (equation-t2 equation) | |
| 92 | meth1 (if (term-is-constant? t1) ; note veriable also returns t | |
| 93 | nil | |
| 94 | (term-method t1)) | |
| 95 | meth2 (if (term-is-constant? t2) | |
| 96 | nil | |
| 97 | (term-method t2))) | |
| 98 | ;; | |
| 99 | (when *match-debug* | |
| 100 | (format t "~%z-next-state: k = ~d, r = ~d" k r) | |
| 101 | (format t "~% term1 = ") | |
| 102 | (print-chaos-object t1) | |
| 103 | (format t "~% meth1 = ") | |
| 104 | (print-chaos-object meth1) | |
| 105 | (format t "~% term2 = ") | |
| 106 | (print-chaos-object t2) | |
| 107 | (format t "~% meth2 = ") | |
| 108 | (print-chaos-object meth2)) | |
| 109 | ;; | |
| 110 | (cond ((and (= r 0) ; as if no thoery applied - 11 22 | |
| 111 | meth1 meth2 | |
| 112 | (method-is-of-same-operator+ meth1 meth2)) | |
| 113 | (add-equation-to-m-system new-sys | |
| 114 | (make-equation (term-arg-1 t1) | |
| 115 | (term-arg-1 t2))) | |
| 116 | (add-equation-to-m-system new-sys | |
| 117 | (make-equation (term-arg-2 t1) | |
| 118 | (term-arg-2 t2)))) | |
| 119 | ((and (= r 1) | |
| 120 | meth1 ; term is non atomic | |
| 121 | (not (term-is-zero-for-method (term-arg-1 t1) meth1))) | |
| 122 | (let ((zero (term-make-zero meth1))) | |
| 123 | (when zero | |
| 124 | (add-equation-to-m-system new-sys | |
| 125 | (make-equation (term-arg-1 t1) | |
| 126 | (term-make-zero meth1))) | |
| 127 | (add-equation-to-m-system new-sys | |
| 128 | (make-equation (term-arg-2 t1) t2))))) | |
| 129 | ((and (= r 2) | |
| 130 | meth1 ; term is non atomic | |
| 131 | (not (term-is-zero-for-method (term-arg-2 t1) meth1))) | |
| 132 | (let ((zero (term-make-zero meth1))) | |
| 133 | (when zero | |
| 134 | (add-equation-to-m-system new-sys | |
| 135 | (make-equation (term-arg-2 t1) | |
| 136 | zero)) | |
| 137 | (add-equation-to-m-system new-sys | |
| 138 | (make-equation (term-arg-1 t1) t2))))) | |
| 139 | ;; note these are redundant if we have terms | |
| 140 | ;; in normal form (no identities). | |
| 141 | ((and (= r 3) | |
| 142 | meth2 ; term is non atomic | |
| 143 | (not (term-is-zero-for-method (term-arg-1 t2) meth2))) | |
| 144 | (let ((zero (term-make-zero meth2))) | |
| 145 | (when zero | |
| 146 | (add-equation-to-m-system new-sys | |
| 147 | (make-equation zero | |
| 148 | (term-arg-1 t2))) | |
| 149 | (add-equation-to-m-system new-sys | |
| 150 | (make-equation t1 (term-arg-2 t2)))))) | |
| 151 | ((and (= r 4) | |
| 152 | meth2 ; term is non atomic | |
| 153 | (not (term-is-zero-for-method (term-arg-2 t2) meth2))) | |
| 154 | (let ((zero (term-make-zero meth2))) | |
| 155 | (when zero | |
| 156 | (add-equation-to-m-system new-sys | |
| 157 | (make-equation zero | |
| 158 | (term-arg-2 t2))) | |
| 159 | (add-equation-to-m-system new-sys | |
| 160 | (make-equation t1 (term-arg-1 t2)))))) | |
| 161 | (t nil)))))) | |
| 84 | (incf N) ; try the next N | |
| 85 | (dotimes (k lg) ; k = lg,...,1 | |
| 86 | (declare (type fixnum k)) ; this treats q as a bitvector in base 5 | |
| 87 | (multiple-value-setq (q r) (truncate q 5)) | |
| 88 | (setq equation (car point2) | |
| 89 | point2 (cdr point2) | |
| 90 | t1 (equation-t1 equation) | |
| 91 | t2 (equation-t2 equation) | |
| 92 | meth1 (if (term-is-constant? t1) ; note veriable also returns t | |
| 93 | nil | |
| 94 | (term-method t1)) | |
| 95 | meth2 (if (term-is-constant? t2) | |
| 96 | nil | |
| 97 | (term-method t2))) | |
| 98 | ;; | |
| 99 | (when *match-debug* | |
| 100 | (format t "~%z-next-state: k = ~d, r = ~d" k r) | |
| 101 | (format t "~% term1 = ") | |
| 102 | (print-chaos-object t1) | |
| 103 | (format t "~% meth1 = ") | |
| 104 | (print-chaos-object meth1) | |
| 105 | (format t "~% term2 = ") | |
| 106 | (print-chaos-object t2) | |
| 107 | (format t "~% meth2 = ") | |
| 108 | (print-chaos-object meth2)) | |
| 109 | ;; | |
| 110 | (cond ((and (= r 0) ; as if no thoery applied - 11 22 | |
| 111 | meth1 meth2 | |
| 112 | (method-is-of-same-operator+ meth1 meth2)) | |
| 113 | (add-equation-to-m-system new-sys | |
| 114 | (make-equation (term-arg-1 t1) | |
| 115 | (term-arg-1 t2))) | |
| 116 | (add-equation-to-m-system new-sys | |
| 117 | (make-equation (term-arg-2 t1) | |
| 118 | (term-arg-2 t2)))) | |
| 119 | ((and (= r 1) | |
| 120 | meth1 ; term is non atomic | |
| 121 | (not (term-is-zero-for-method (term-arg-1 t1) meth1))) | |
| 122 | (let ((zero (term-make-zero meth1))) | |
| 123 | (when zero | |
| 124 | (add-equation-to-m-system new-sys | |
| 125 | (make-equation (term-arg-1 t1) | |
| 126 | (term-make-zero meth1))) | |
| 127 | (add-equation-to-m-system new-sys | |
| 128 | (make-equation (term-arg-2 t1) t2))))) | |
| 129 | ((and (= r 2) | |
| 130 | meth1 ; term is non atomic | |
| 131 | (not (term-is-zero-for-method (term-arg-2 t1) meth1))) | |
| 132 | (let ((zero (term-make-zero meth1))) | |
| 133 | (when zero | |
| 134 | (add-equation-to-m-system new-sys | |
| 135 | (make-equation (term-arg-2 t1) | |
| 136 | zero)) | |
| 137 | (add-equation-to-m-system new-sys | |
| 138 | (make-equation (term-arg-1 t1) t2))))) | |
| 139 | ;; note these are redundant if we have terms | |
| 140 | ;; in normal form (no identities). | |
| 141 | ((and (= r 3) | |
| 142 | meth2 ; term is non atomic | |
| 143 | (not (term-is-zero-for-method (term-arg-1 t2) meth2))) | |
| 144 | (let ((zero (term-make-zero meth2))) | |
| 145 | (when zero | |
| 146 | (add-equation-to-m-system new-sys | |
| 147 | (make-equation zero | |
| 148 | (term-arg-1 t2))) | |
| 149 | (add-equation-to-m-system new-sys | |
| 150 | (make-equation t1 (term-arg-2 t2)))))) | |
| 151 | ((and (= r 4) | |
| 152 | meth2 ; term is non atomic | |
| 153 | (not (term-is-zero-for-method (term-arg-2 t2) meth2))) | |
| 154 | (let ((zero (term-make-zero meth2))) | |
| 155 | (when zero | |
| 156 | (add-equation-to-m-system new-sys | |
| 157 | (make-equation zero | |
| 158 | (term-arg-2 t2))) | |
| 159 | (add-equation-to-m-system new-sys | |
| 160 | (make-equation t1 (term-arg-1 t2)))))) | |
| 161 | (t nil)))))) | |
| 162 | 162 | |
| 163 | 163 | ;;; EQUALITY |
| 164 | 164 | |
| 167 | 167 | ;;; |
| 168 | 168 | (defun match-Z-equal (t1 t2) |
| 169 | 169 | (declare (type term t1 t2) |
| 170 | (values (or null t))) | |
| 170 | (values (or null t))) | |
| 171 | 171 | (if (term-is-applform? t2) |
| 172 | 172 | (let ((meth1 (term-head t1)) |
| 173 | (meth2 (term-head t2))) | |
| 174 | (if (method-is-of-same-operator meth1 meth2) | |
| 175 | (or | |
| 176 | (and (term-is-zero-for-method (term-arg-1 t1) meth1) | |
| 177 | (term-equational-equal (term-arg-2 t1) t2)) | |
| 178 | (and (term-is-zero-for-method (term-arg-2 t1) meth1) | |
| 179 | (term-equational-equal (term-arg-1 t1) t2)) | |
| 180 | (and (term-is-zero-for-method (term-arg-1 t2) meth2) | |
| 181 | (term-equational-equal t1 (term-arg-2 t2))) | |
| 182 | (and (term-is-zero-for-method (term-arg-2 t2) meth2) | |
| 183 | (term-equational-equal t1 (term-arg-1 t2))) | |
| 184 | (and (term-equational-equal (term-arg-1 t1) (term-arg-1 t2)) | |
| 185 | (term-equational-equal (term-arg-2 t1) (term-arg-2 t2)))) | |
| 186 | nil)) | |
| 173 | (meth2 (term-head t2))) | |
| 174 | (if (method-is-of-same-operator meth1 meth2) | |
| 175 | (or | |
| 176 | (and (term-is-zero-for-method (term-arg-1 t1) meth1) | |
| 177 | (term-equational-equal (term-arg-2 t1) t2)) | |
| 178 | (and (term-is-zero-for-method (term-arg-2 t1) meth1) | |
| 179 | (term-equational-equal (term-arg-1 t1) t2)) | |
| 180 | (and (term-is-zero-for-method (term-arg-1 t2) meth2) | |
| 181 | (term-equational-equal t1 (term-arg-2 t2))) | |
| 182 | (and (term-is-zero-for-method (term-arg-2 t2) meth2) | |
| 183 | (term-equational-equal t1 (term-arg-1 t2))) | |
| 184 | (and (term-equational-equal (term-arg-1 t1) (term-arg-1 t2)) | |
| 185 | (term-equational-equal (term-arg-2 t1) (term-arg-2 t2)))) | |
| 186 | nil)) | |
| 187 | 187 | nil)) |
| 188 | 188 | |
| 189 | 189 | ;;; EOF |
| 0 | 0 | ;;;-*- Mode:LISP; Package:CHAOS; Base:10; Syntax:Common-lisp -*- |
| 1 | 1 | ;;; |
| 2 | ;;; Copyright (c) 2000-2014, Toshimi Sawada. All rights reserved. | |
| 2 | ;;; Copyright (c) 2000-2015, Toshimi Sawada. All rights reserved. | |
| 3 | 3 | ;;; |
| 4 | 4 | ;;; Redistribution and use in source and binary forms, with or without |
| 5 | 5 | ;;; modification, are permitted provided that the following conditions |
| 27 | 27 | ;;; |
| 28 | 28 | (in-package :chaos) |
| 29 | 29 | #|============================================================================== |
| 30 | System:Chaos | |
| 31 | Module:e-match | |
| 32 | File:match.lisp | |
| 30 | System:Chaos | |
| 31 | Module:e-match | |
| 32 | File:match.lisp | |
| 33 | 33 | ==============================================================================|# |
| 34 | 34 | #-:chaos-debug |
| 35 | 35 | (declaim (optimize (speed 3) (safety 0) #-GCL (debug 0))) |
| 37 | 37 | (declaim (optimize (speed 1) (safety 3) #-GCL (debug 3))) |
| 38 | 38 | |
| 39 | 39 | #| |
| 40 | EQUATIONAL TERM MATCHING TOP LEVEL ROUTINES | |
| 40 | EQUATIONAL TERM MATCHING TOP LEVEL ROUTINES | |
| 41 | 41 | |# |
| 42 | 42 | |
| 43 | 43 | ;;; OBSOLETE COMMENTS: |
| 72 | 72 | |
| 73 | 73 | (defun first-match (t1 t2 &optional (sigma nil)) |
| 74 | 74 | (declare (type term t1 t2) |
| 75 | (values list list (or null t) (or null t))) | |
| 76 | (when *match-debug* | |
| 77 | (format t "~&* First Match --------------------------------~%") | |
| 78 | (princ " t1 = ") (term-print-with-sort t1) | |
| 79 | (terpri) | |
| 80 | (princ " t2 = ") (term-print-with-sort t2) | |
| 81 | (terpri) | |
| 82 | (format t " unify? = ~s" *do-unify*) | |
| 83 | (terpri) | |
| 84 | (format t " one way match? = ~s" *one-way-match*) | |
| 75 | (values list list (or null t) (or null t))) | |
| 76 | (with-match-debug () | |
| 77 | (format t "~%* First Match --------------------------------") | |
| 78 | (print-next) | |
| 79 | (princ "t1 = ") (term-print-with-sort t1) | |
| 80 | (print-next) | |
| 81 | (princ "t2 = ") (term-print-with-sort t2) | |
| 82 | (print-next) | |
| 83 | (format t "unify? = ~s" *do-unify*) | |
| 84 | (print-next) | |
| 85 | (format t "one way match? = ~s" *one-way-match*) | |
| 85 | 86 | (force-output)) |
| 86 | 87 | ;; |
| 87 | 88 | (multiple-value-bind (m-sys no-match) |
| 88 | 89 | ;; (match-decompose&merge (new-match-system t1 t2)) |
| 89 | 90 | (match-decompose&merge (create-match-system (new-environment) |
| 90 | (create-m-system t1 t2)) | |
| 91 | sigma) | |
| 92 | (when *match-debug* | |
| 93 | (format t "~&result of match-deocmpose&merge, no-match=~a" no-match) | |
| 91 | (create-m-system t1 t2)) | |
| 92 | sigma) | |
| 93 | (with-match-debug() | |
| 94 | (format t "~%result of match-deocmpose&merge, no-match=~a" no-match) | |
| 94 | 95 | (force-output)) |
| 95 | 96 | ;; Note: if the two terms are similar then "m-sys" is empty. |
| 96 | 97 | (if no-match |
| 97 | (values nil nil t nil) ; no match | |
| 98 | (values nil nil t nil) ; no match | |
| 98 | 99 | (let ((gst (new-global-state))) |
| 99 | (declare (type list gst)) | |
| 100 | (cond ((m-system-is-empty? (match-system-sys m-sys)) | |
| 101 | (when *match-debug* | |
| 102 | (format t "~& return with success")) | |
| 103 | (let ((subst (match-system-to-substitution m-sys))) | |
| 104 | (when *match-debug* | |
| 105 | (print-substitution subst)) | |
| 106 | (values gst | |
| 107 | subst | |
| 108 | nil | |
| 109 | (null (car subst))))) | |
| 110 | ((match-system-e-equal m-sys) | |
| 111 | (values nil nil nil t)) | |
| 112 | (t (multiple-value-bind (sys theory-info) | |
| 113 | (match-system-extract-one m-sys) | |
| 114 | (declare (type list sys) (type theory-info theory-info)) | |
| 115 | (when *match-debug* | |
| 116 | (format t "~& extracted a system ") | |
| 117 | (print-m-system sys)) | |
| 118 | ;; the matching system is not modified, | |
| 119 | ;; thus we create a new match-system | |
| 120 | (multiple-value-bind (th-st no-match) | |
| 121 | (theory-state-match-initialize theory-info | |
| 122 | sys | |
| 123 | (match-system-env m-sys)) | |
| 124 | (declare (type t th-st) (type (or null t) no-match)) | |
| 125 | (if no-match | |
| 126 | (values nil nil t nil) | |
| 127 | (let ((next-gst nil)) | |
| 128 | (when *match-debug* | |
| 129 | (format t "~&First match calls next-match") | |
| 130 | (format t "~% old gst: ") | |
| 131 | (print-global-state gst) | |
| 132 | ) | |
| 133 | (setq next-gst | |
| 134 | (global-state-push gst | |
| 135 | (match-state-create | |
| 136 | (match-system-modif-m-sys | |
| 137 | m-sys sys) | |
| 138 | sys | |
| 139 | theory-info | |
| 140 | th-st))) | |
| 141 | (when *match-debug* | |
| 142 | (format t "~& next gst :") | |
| 143 | (print-global-state next-gst)) | |
| 144 | (multiple-value-bind (new-gst subst no-match) | |
| 145 | (next-match next-gst) | |
| 146 | (values new-gst subst no-match nil))))))) | |
| 147 | ))))) | |
| 100 | (declare (type list gst)) | |
| 101 | (cond ((m-system-is-empty? (match-system-sys m-sys)) | |
| 102 | (with-match-debug () | |
| 103 | (format t "~% return with success")) | |
| 104 | (let ((subst (match-system-to-substitution m-sys))) | |
| 105 | (with-match-debug () | |
| 106 | (print-substitution subst)) | |
| 107 | (values gst | |
| 108 | subst | |
| 109 | nil | |
| 110 | (null (car subst))))) | |
| 111 | ((match-system-e-equal m-sys) | |
| 112 | (values nil nil nil t)) | |
| 113 | (t (multiple-value-bind (sys theory-info) | |
| 114 | (match-system-extract-one m-sys) | |
| 115 | (declare (type list sys) (type theory-info theory-info)) | |
| 116 | (with-match-debug() | |
| 117 | (format t "~% extracted a system ") | |
| 118 | (print-m-system sys) | |
| 119 | (format t "~% theory = ") | |
| 120 | (pr-theory-info theory-info)) | |
| 121 | ;; the matching system is not modified, | |
| 122 | ;; thus we create a new match-system | |
| 123 | (multiple-value-bind (th-st no-match) | |
| 124 | (theory-state-match-initialize theory-info | |
| 125 | sys | |
| 126 | (match-system-env m-sys)) | |
| 127 | (declare (type t th-st) (type (or null t) no-match)) | |
| 128 | (if no-match | |
| 129 | (values nil nil t nil) | |
| 130 | (let ((next-gst nil)) | |
| 131 | (with-match-debug () | |
| 132 | (format t "~%First match calls next-match") | |
| 133 | (format t "~% old gst: ") | |
| 134 | (print-global-state gst) | |
| 135 | ) | |
| 136 | (setq next-gst | |
| 137 | (global-state-push gst | |
| 138 | (match-state-create | |
| 139 | (match-system-modif-m-sys | |
| 140 | m-sys sys) | |
| 141 | sys | |
| 142 | theory-info | |
| 143 | th-st))) | |
| 144 | (with-match-debug () | |
| 145 | (format t "~% next gst :") | |
| 146 | (print-global-state next-gst)) | |
| 147 | (multiple-value-bind (new-gst subst no-match) | |
| 148 | (next-match next-gst) | |
| 149 | (values new-gst subst no-match nil)))))))))))) | |
| 148 | 150 | |
| 149 | 151 | ;;; NEXT-MATCH : GLOBAL-STATE -> GLOBAL-STATE SUBSTITUTION NO-MATCH-FLAG |
| 150 | 152 | ;;;----------------------------------------------------------------------------- |
| 153 | 155 | |
| 154 | 156 | (defun next-match (gst) |
| 155 | 157 | (declare (type list gst) |
| 156 | (values list list (or null t))) | |
| 158 | (values list list (or null t))) | |
| 157 | 159 | (block the-end |
| 158 | 160 | (let (st) |
| 159 | 161 | (while (global-state-is-not-empty gst) |
| 160 | (when *match-debug* | |
| 161 | (format t "~&* Next-match : global-state = ") | |
| 162 | (print-global-state gst)) | |
| 163 | (setq st (global-state-top gst)) | |
| 164 | (multiple-value-bind (new-st no-more) | |
| 165 | (next-match-state st) | |
| 166 | (declare (type (or null match-state) new-st) | |
| 167 | (type (or null t) no-more)) | |
| 168 | (when *match-debug* | |
| 169 | (format t "~&** Next-match : next-match-state returns no-more = ~a" no-more) | |
| 170 | (unless no-more | |
| 171 | (format t "~&-- new state =") | |
| 172 | (print-match-state new-st))) | |
| 173 | (if no-more | |
| 174 | (setq gst (global-state-pop gst)) | |
| 175 | ;; else | |
| 176 | (progn | |
| 177 | (setq gst (global-state-push gst new-st)) | |
| 178 | (let* ((m-sys (match-state-match-system new-st)) | |
| 179 | (sys (match-system-sys m-sys))) | |
| 180 | (when (and (m-system-is-empty? sys) | |
| 181 | (m-system-is-empty? (match-state-sys-to-solve new-st))) | |
| 182 | ;; popping: the reasoning is that a successful state | |
| 183 | ;; also terminates . | |
| 184 | (setq gst (global-state-pop gst)) | |
| 185 | (when *match-debug* | |
| 186 | (format t "~&* Next-match : return-with subst")) | |
| 187 | (return-from the-end | |
| 188 | (values gst | |
| 189 | (match-system-to-substitution m-sys) | |
| 190 | nil)))))) | |
| 191 | ))) | |
| 192 | (when *match-debug* | |
| 193 | (format t "~&* Next-match : return with no-match")) | |
| 162 | (with-match-debug() | |
| 163 | (format t "~%* Next-match : global-state = ") | |
| 164 | (print-global-state gst)) | |
| 165 | (setq st (global-state-top gst)) | |
| 166 | (multiple-value-bind (new-st no-more) | |
| 167 | (next-match-state st) | |
| 168 | (declare (type (or null match-state) new-st) | |
| 169 | (type (or null t) no-more)) | |
| 170 | (with-match-debug () | |
| 171 | (format t "~%** Next-match : next-match-state returns no-more = ~a" no-more) | |
| 172 | (unless no-more | |
| 173 | (format t "~%-- new state =") | |
| 174 | (print-match-state new-st))) | |
| 175 | (if no-more | |
| 176 | (setq gst (global-state-pop gst)) | |
| 177 | ;; else | |
| 178 | (progn | |
| 179 | (setq gst (global-state-push gst new-st)) | |
| 180 | (let* ((m-sys (match-state-match-system new-st)) | |
| 181 | (sys (match-system-sys m-sys))) | |
| 182 | (when (and (m-system-is-empty? sys) | |
| 183 | (m-system-is-empty? (match-state-sys-to-solve new-st))) | |
| 184 | ;; popping: the reasoning is that a successful state | |
| 185 | ;; also terminates . | |
| 186 | (setq gst (global-state-pop gst)) | |
| 187 | (with-match-debug () | |
| 188 | (format t "~%* Next-match : return-with subst")) | |
| 189 | (return-from the-end | |
| 190 | (values gst | |
| 191 | (match-system-to-substitution m-sys) | |
| 192 | nil))))))))) | |
| 193 | (with-match-debug () | |
| 194 | (format t "~%* Next-match : return with no-match")) | |
| 194 | 195 | ;; no match |
| 195 | 196 | (values nil nil t))) |
| 196 | 197 | |
| 199 | 200 | ;;; |
| 200 | 201 | (defun empty-match (t1 t2) |
| 201 | 202 | (declare (type term t1 t2) |
| 202 | (values list (or null t))) | |
| 203 | (values list (or null t))) | |
| 203 | 204 | (multiple-value-bind (m-sys no-match) |
| 204 | 205 | (match-decompose&merge (new-match-system t1 t2)) |
| 205 | 206 | (if no-match |
| 206 | (values nil t) ; no match | |
| 207 | (cond ((m-system-is-empty? (match-system-sys m-sys)) | |
| 208 | (values (match-system-to-substitution m-sys) nil)) | |
| 209 | (t (values nil t)))))) ; no match | |
| 207 | (values nil t) ; no match | |
| 208 | (cond ((m-system-is-empty? (match-system-sys m-sys)) | |
| 209 | (values (match-system-to-substitution m-sys) nil)) | |
| 210 | (t (values nil t)))))) ; no match | |
| 210 | 211 | |
| 211 | 212 | ;;; MATCHES? : PATTERN TARGET -> BOOL |
| 212 | 213 | ;;;----------------------------------------------------------------------------- |
| 213 | 214 | ;;; |
| 214 | 215 | (defun matches? (t1 t2) |
| 215 | 216 | (declare (type term t1 t2) |
| 216 | (values (or null t))) | |
| 217 | (values (or null t))) | |
| 217 | 218 | (multiple-value-bind (gs subst no eeq) |
| 218 | 219 | (first-match t1 t2) |
| 219 | 220 | (declare (ignore gs subst)) |
| 227 | 228 | ;;; |
| 228 | 229 | (defun first-match-with-theory (theory-info t1 t2) |
| 229 | 230 | (declare (type theory-info theory-info) |
| 230 | (type term t1 t2) | |
| 231 | ;; (optimize (debug 3)) | |
| 232 | ) | |
| 231 | (type term t1 t2) | |
| 232 | ;; (optimize (debug 3)) | |
| 233 | ) | |
| 233 | 234 | (multiple-value-bind (m-sys no-match) |
| 234 | 235 | (match-decompose&merge (new-match-system t1 t2)) |
| 235 | 236 | ;; Note that is the two terms are similar then "m-sys" is empty. |
| 236 | 237 | ;; In the current code it is not signaled "E-equal", it must be corrected. |
| 237 | 238 | (if no-match |
| 238 | (values nil nil t nil) ; no match | |
| 239 | (let ((gst (new-global-state))) | |
| 240 | (declare (type list)) | |
| 241 | (cond ((m-system-is-empty? (match-system-sys m-sys)) | |
| 242 | (values gst | |
| 243 | (match-system-to-substitution m-sys) | |
| 244 | nil | |
| 245 | nil)) | |
| 246 | ;; ((match-system-E-equal m-sys) | |
| 247 | ;; (values nil nil nil t)) ; match & e-equal | |
| 248 | (t (multiple-value-bind (sys th-ign) | |
| 249 | (match-system-extract-one m-sys) | |
| 250 | (declare (ignore th-ign)) | |
| 251 | ;; the matching system is not modified, | |
| 252 | ;; thus we create a new match-system | |
| 253 | (multiple-value-bind (th-st no-match) | |
| 254 | (theory-state-match-initialize theory-info | |
| 255 | sys | |
| 256 | (match-system-env m-sys)) | |
| 257 | (if no-match | |
| 258 | (values nil nil t nil) ; no match | |
| 259 | (multiple-value-bind (new-gst subst no-match) | |
| 260 | (next-match (global-state-push | |
| 261 | gst | |
| 262 | (match-state-create | |
| 263 | (match-system-modif-m-sys m-sys sys) | |
| 264 | sys | |
| 265 | theory-info | |
| 266 | th-st))) | |
| 267 | (values new-gst subst no-match nil nil)))))) | |
| 268 | ))))) | |
| 239 | (values nil nil t nil) ; no match | |
| 240 | (let ((gst (new-global-state))) | |
| 241 | (declare (type list)) | |
| 242 | (cond ((m-system-is-empty? (match-system-sys m-sys)) | |
| 243 | (values gst | |
| 244 | (match-system-to-substitution m-sys) | |
| 245 | nil | |
| 246 | nil)) | |
| 247 | ;; ((match-system-E-equal m-sys) | |
| 248 | ;; (values nil nil nil t)) ; match & e-equal | |
| 249 | (t (multiple-value-bind (sys th-ign) | |
| 250 | (match-system-extract-one m-sys) | |
| 251 | (declare (ignore th-ign)) | |
| 252 | ;; the matching system is not modified, | |
| 253 | ;; thus we create a new match-system | |
| 254 | (multiple-value-bind (th-st no-match) | |
| 255 | (theory-state-match-initialize theory-info | |
| 256 | sys | |
| 257 | (match-system-env m-sys)) | |
| 258 | (if no-match | |
| 259 | (values nil nil t nil) ; no match | |
| 260 | (multiple-value-bind (new-gst subst no-match) | |
| 261 | (next-match (global-state-push | |
| 262 | gst | |
| 263 | (match-state-create | |
| 264 | (match-system-modif-m-sys m-sys sys) | |
| 265 | sys | |
| 266 | theory-info | |
| 267 | th-st))) | |
| 268 | (values new-gst subst no-match nil nil)))))) | |
| 269 | ))))) | |
| 269 | 270 | |
| 270 | 271 | ;;; EOF |
| 0 | 0 | ;;;-*- Mode:LISP; Package:CAFEIN; Base:10; Syntax:Common-lisp -*- |
| 1 | 1 | ;;; |
| 2 | ;;; Copyright (c) 2000-2014, Toshimi Sawada. All rights reserved. | |
| 2 | ;;; Copyright (c) 2000-2015, Toshimi Sawada. All rights reserved. | |
| 3 | 3 | ;;; |
| 4 | 4 | ;;; Redistribution and use in source and binary forms, with or without |
| 5 | 5 | ;;; modification, are permitted provided that the following conditions |
| 27 | 27 | ;;; |
| 28 | 28 | (in-package :chaos) |
| 29 | 29 | #|============================================================================== |
| 30 | System:Chaos | |
| 31 | Module:e-match | |
| 32 | File:match2.lisp | |
| 30 | System:Chaos | |
| 31 | Module:e-match | |
| 32 | File:match2.lisp | |
| 33 | 33 | ==============================================================================|# |
| 34 | 34 | #-:chaos-debug |
| 35 | 35 | (declaim (optimize (speed 3) (safety 0) #-GCL (debug 0))) |
| 54 | 54 | ;;; |
| 55 | 55 | (defun simple-match-e-ok? (pattern cond) |
| 56 | 56 | (declare (type term pattern cond) |
| 57 | (values (or null t))) | |
| 57 | (values (or null t))) | |
| 58 | 58 | (or (is-empty-theory-term? pattern) |
| 59 | 59 | (and (is-true? cond) |
| 60 | (is-linear-general-pattern? pattern)))) | |
| 60 | (is-linear-general-pattern? pattern)))) | |
| 61 | 61 | |
| 62 | 62 | (defun is-empty-theory-term? (term) |
| 63 | 63 | (declare (type term term) |
| 64 | (values (or null t))) | |
| 64 | (values (or null t))) | |
| 65 | 65 | (if (or (term-is-variable? term) |
| 66 | (term-is-builtin-constant? term)) | |
| 66 | (term-is-builtin-constant? term)) | |
| 67 | 67 | t |
| 68 | 68 | (let ((meth (term-method term))) |
| 69 | (if (or (not (= 2 (the fixnum | |
| 70 | (operator-num-args (method-operator meth))))) | |
| 71 | (theory-info-empty-for-matching | |
| 72 | (method-theory-info-for-matching meth))) | |
| 73 | (dolist (st (term-subterms term) t) | |
| 74 | (unless (is-empty-theory-term? st) | |
| 75 | (return nil))) | |
| 76 | nil)))) | |
| 69 | (if (or (not (= 2 (the fixnum | |
| 70 | (operator-num-args (method-operator meth))))) | |
| 71 | (theory-info-empty-for-matching | |
| 72 | (method-theory-info-for-matching meth))) | |
| 73 | (dolist (st (term-subterms term) t) | |
| 74 | (unless (is-empty-theory-term? st) | |
| 75 | (return nil))) | |
| 76 | nil)))) | |
| 77 | 77 | |
| 78 | 78 | ;;; liner & general pattern means that |
| 79 | 79 | ;;; 1) subterms of the pattern are all variables and their sorts |
| 82 | 82 | ;;; |
| 83 | 83 | (defun is-linear-general-pattern? (pattern) |
| 84 | 84 | (declare (type term pattern) |
| 85 | (values (or null t))) | |
| 85 | (values (or null t))) | |
| 86 | 86 | (or (term-is-variable? pattern) |
| 87 | 87 | ;; general pattern? |
| 88 | 88 | (and |
| 89 | 89 | ;; subterms of the pattern are all variables and their sorts |
| 90 | 90 | ;; matches to the arity of the top method. |
| 91 | 91 | (every #'(lambda (x y) |
| 92 | (declare (type term x) (type sort* y) | |
| 93 | (values (or null t))) | |
| 94 | (and (term-is-variable? x) | |
| 95 | (sort= (variable-sort x) y))) | |
| 96 | (term-subterms pattern) | |
| 97 | (method-arity (term-method pattern))) | |
| 92 | (declare (type term x) (type sort* y) | |
| 93 | (values (or null t))) | |
| 94 | (and (term-is-variable? x) | |
| 95 | (sort= (variable-sort x) y))) | |
| 96 | (term-subterms pattern) | |
| 97 | (method-arity (term-method pattern))) | |
| 98 | 98 | ;; check linearlity |
| 99 | 99 | (do* ((lst (term-subterms pattern) (cdr lst)) |
| 100 | (elt (car lst) (car lst))) | |
| 101 | ((null lst) t) | |
| 102 | (when (member elt (cdr lst)) (return nil)))))) | |
| 100 | (elt (car lst) (car lst))) | |
| 101 | ((null lst) t) | |
| 102 | (when (member elt (cdr lst)) (return nil)))))) | |
| 103 | 103 | |
| 104 | 104 | ;;; SIMPLE-MATCH-E : PATTERN TERM -> SUBSTITUTION NO-MATCH-FLAG |
| 105 | 105 | ;;;----------------------------------------------------------------------------- |
| 125 | 125 | ;;; useful for effeciency, but .. |
| 126 | 126 | ;;; |
| 127 | 127 | (declaim (special .empty-direct-subst.)) |
| 128 | (defvar .empty-direct-subst. nil) ; substitution | |
| 128 | (defvar .empty-direct-subst. nil) ; substitution | |
| 129 | 129 | |
| 130 | 130 | (defun simp-match* (pattern term) |
| 131 | 131 | (declare (type term pattern term) |
| 132 | (values (or null t))) | |
| 133 | ;; (unless term ; really happen this? NO! | |
| 132 | (values (or null t))) | |
| 133 | ;; (unless term ; really happen this? NO! | |
| 134 | 134 | ;; (return-from simp-match* (values subst nil))) |
| 135 | 135 | (macrolet ((lookup-substitution (____sub _**term) |
| 136 | `(cdr (assq ,_**term ,____sub)) | |
| 137 | ;;`(let ((val (assq ,term ,sub))) | |
| 138 | ;; (if val (cdr val) nil)) | |
| 139 | )) | |
| 136 | `(cdr (assq ,_**term ,____sub)) | |
| 137 | ;;`(let ((val (assq ,term ,sub))) | |
| 138 | ;; (if val (cdr val) nil)) | |
| 139 | )) | |
| 140 | 140 | (cond ((term-is-applform? pattern) |
| 141 | (if (term-is-applform? term) | |
| 142 | (let ((head1 (term-head pattern)) | |
| 143 | (head2 (term-head term)) | |
| 144 | (subs1 (term-subterms pattern)) | |
| 145 | (subs2 (term-subterms term))) | |
| 146 | (if (null subs1) | |
| 147 | (and (null subs2) | |
| 148 | (method-is-of-same-operator head1 head2)) | |
| 149 | (if (method-is-of-same-operator+ head1 head2) | |
| 150 | (do* ((lspattern subs1 (cdr lspattern)) | |
| 151 | (i1 (car lspattern) (car lspattern)) | |
| 152 | (lsterm subs2 (cdr lsterm)) | |
| 153 | (i2 (car lsterm) (car lsterm))) | |
| 154 | ((null lspattern) (null lsterm)) | |
| 155 | (declare (type list lspattern lsterm)) | |
| 156 | (unless (simp-match* i1 i2) (return nil))) | |
| 157 | nil))) | |
| 158 | nil)) | |
| 159 | ((term-is-variable? pattern) | |
| 160 | (let ((sl (lookup-substitution .empty-direct-subst. pattern))) | |
| 161 | (if sl | |
| 162 | (term-equational-equal sl term) | |
| 163 | (if (sort<= (term-sort term) | |
| 164 | (variable-sort pattern) *current-sort-order*) | |
| 165 | (progn | |
| 166 | (setf .empty-direct-subst. | |
| 167 | (cons (cons pattern term) .empty-direct-subst.)) | |
| 168 | t) | |
| 169 | nil)))) | |
| 170 | ((term-is-variable? term) nil) | |
| 171 | ((term-is-builtin-constant? pattern) (term-builtin-equal pattern term)) | |
| 172 | (t nil)) | |
| 141 | (if (term-is-applform? term) | |
| 142 | (let ((head1 (term-head pattern)) | |
| 143 | (head2 (term-head term)) | |
| 144 | (subs1 (term-subterms pattern)) | |
| 145 | (subs2 (term-subterms term))) | |
| 146 | (if (null subs1) | |
| 147 | (and (null subs2) | |
| 148 | (method-is-of-same-operator head1 head2)) | |
| 149 | (if (method-is-of-same-operator+ head1 head2) | |
| 150 | (do* ((lspattern subs1 (cdr lspattern)) | |
| 151 | (i1 (car lspattern) (car lspattern)) | |
| 152 | (lsterm subs2 (cdr lsterm)) | |
| 153 | (i2 (car lsterm) (car lsterm))) | |
| 154 | ((null lspattern) (null lsterm)) | |
| 155 | (declare (type list lspattern lsterm)) | |
| 156 | (unless (simp-match* i1 i2) (return nil))) | |
| 157 | nil))) | |
| 158 | nil)) | |
| 159 | ((term-is-variable? pattern) | |
| 160 | (let ((sl (lookup-substitution .empty-direct-subst. pattern))) | |
| 161 | (if sl | |
| 162 | (term-equational-equal sl term) | |
| 163 | (if (sort<= (term-sort term) | |
| 164 | (variable-sort pattern) *current-sort-order*) | |
| 165 | (progn | |
| 166 | (setf .empty-direct-subst. | |
| 167 | (cons (cons pattern term) .empty-direct-subst.)) | |
| 168 | t) | |
| 169 | nil)))) | |
| 170 | ((term-is-variable? term) nil) | |
| 171 | ((term-is-builtin-constant? pattern) (term-builtin-equal pattern term)) | |
| 172 | (t nil)) | |
| 173 | 173 | )) |
| 174 | 174 | |
| 175 | 175 | (defun simp-match-e (pattern term) |
| 176 | 176 | (declare (type term pattern term) |
| 177 | (inline simp-match*) | |
| 178 | (values list list (or null t) (or null t))) | |
| 177 | (inline simp-match*) | |
| 178 | (values list list (or null t) (or null t))) | |
| 179 | 179 | (let ((.empty-direct-subst. nil)) |
| 180 | 180 | (let ((match? (simp-match* pattern term))) |
| 181 | 181 | (when *match-debug* |
| 182 | (with-output-simple-msg() | |
| 183 | (format t "-- result : ~a" match?))) | |
| 182 | (with-output-simple-msg() | |
| 183 | (format t "-- result : ~a" match?))) | |
| 184 | 184 | (values nil .empty-direct-subst. (null match?) nil)))) |
| 185 | 185 | |
| 186 | 186 | ;;; Simplified A, AC Matching -------------------------------------------------- |
| 201 | 201 | ;;; |
| 202 | 202 | (defun is-simple-AC-match-ok? (pattern cond &optional (so *current-sort-order*)) |
| 203 | 203 | (declare (type term pattern cond) |
| 204 | (type sort-order so) | |
| 205 | (values (or null t))) | |
| 204 | (type sort-order so) | |
| 205 | (values (or null t))) | |
| 206 | 206 | (block exit |
| 207 | 207 | (unless (is-true? cond) (return-from exit nil)) ; must be non conditional. |
| 208 | (when (term-is-variable? pattern) ; pattern itself must be no-variable. | |
| 208 | (when (term-is-variable? pattern) ; pattern itself must be no-variable. | |
| 209 | 209 | (return-from exit nil)) |
| 210 | 210 | |
| 211 | 211 | (let* ((meth (term-method pattern)) |
| 212 | (op (method-operator meth))) | |
| 212 | (op (method-operator meth))) | |
| 213 | 213 | ;; operator must be AC. |
| 214 | 214 | (unless (and (operator-is-associative op) (operator-is-commutative op)) |
| 215 | (return-from exit nil)) | |
| 215 | (return-from exit nil)) | |
| 216 | 216 | |
| 217 | 217 | (let ((subs (list-AC-subterms pattern meth)) |
| 218 | (non-vars nil) | |
| 219 | (indep nil) | |
| 220 | (dep nil) | |
| 221 | (accum-vars nil) | |
| 222 | (top-vars nil) | |
| 223 | (indep-vars nil) | |
| 224 | (dep-vars nil) | |
| 225 | ) | |
| 226 | ||
| 227 | ;; first separate out the variables. | |
| 228 | (dolist (tm subs) | |
| 229 | (if (term-is-variable? tm) | |
| 230 | (push tm top-vars) | |
| 231 | (push tm non-vars))) | |
| 232 | (setq non-vars (nreverse non-vars)) | |
| 233 | ||
| 234 | ;; split non-vars into indep and dep parts. | |
| 235 | (let ((all-vars nil)) ;all variables contained in non-vars. | |
| 236 | (dolist (nv non-vars) | |
| 237 | (setq all-vars (union all-vars (term-variables nv) :test #'eq))) | |
| 238 | (if (null all-vars) | |
| 239 | (setq indep non-vars | |
| 240 | dep nil) | |
| 241 | (let (cur) | |
| 242 | (while-not (subsetp all-vars accum-vars :test #'eq) | |
| 243 | (setf cur (pop non-vars)) | |
| 244 | (push cur indep) | |
| 245 | (setf accum-vars (union accum-vars (term-variables cur) | |
| 246 | :test #'eq))) | |
| 247 | (setf dep non-vars)))) | |
| 248 | ||
| 249 | ;; split variables appearing at top level into indep and dep parts. | |
| 250 | (dolist (v top-vars) | |
| 251 | (if (member v accum-vars :test #'eq) | |
| 252 | (push v dep-vars) | |
| 253 | (if (member v indep-vars :test #'eq) | |
| 254 | ;; we require linerality of independent variables. | |
| 255 | (return-from exit nil) | |
| 256 | (push v indep-vars)))) | |
| 257 | (setq indep-vars (topo-sort indep-vars | |
| 258 | #'(lambda (x y) | |
| 259 | (sort< (variable-sort x) | |
| 260 | (variable-sort y) | |
| 261 | so)))) | |
| 262 | (setq dep-vars (nreverse dep-vars)) | |
| 263 | (if (and indep | |
| 264 | (or dep ; there are dependent or there are a few | |
| 265 | dep-vars ; easy matching cases. | |
| 266 | (< 1 (length indep-vars))) | |
| 267 | (or (null (cdr indep-vars)) | |
| 268 | ; indep-vars must be linearly | |
| 269 | ; ordered by sort. | |
| 270 | (do ((cur (car indep-vars) nxt) | |
| 271 | (nxt (cadr indep-vars) (car lst)) | |
| 272 | (lst (cddr indep-vars) (cdr lst))) | |
| 273 | ((null nxt) t) | |
| 274 | (unless (sort<= (variable-sort cur) | |
| 275 | (variable-sort nxt) | |
| 276 | so) | |
| 277 | (return nil))))) | |
| 278 | ;; restructure the pattern. | |
| 279 | (progn | |
| 280 | (when *match-debug* | |
| 281 | (format t "~&is-simple-ac-match-ok?, before") | |
| 282 | (print-term-tree pattern) | |
| 283 | (format t "~%-- indep = ") | |
| 284 | (print-chaos-object indep) | |
| 285 | (format t "~%-- dep(lst) = ") | |
| 286 | (print-chaos-object dep) | |
| 287 | (format t "~%-- dep-vars = ") | |
| 288 | (print-chaos-object dep-vars) | |
| 289 | (format t "~%-- idep-vars = ") | |
| 290 | (print-chaos-object indep-vars) | |
| 291 | (force-output)) | |
| 292 | (term-replace pattern | |
| 293 | (make-right-assoc-normal-form-with-sort-check | |
| 294 | meth | |
| 295 | (append | |
| 296 | (list (make-right-assoc-normal-form-with-sort-check | |
| 297 | meth | |
| 298 | indep)) | |
| 299 | dep | |
| 300 | dep-vars | |
| 301 | indep-vars))) | |
| 302 | (when *match-debug* | |
| 303 | (format t "~&is-simple-ac-match-ok?, after") | |
| 304 | (print-chaos-object pattern) | |
| 305 | (force-output) | |
| 306 | (print-term-tree pattern) | |
| 307 | (force-output)) | |
| 308 | t) | |
| 309 | ;; else | |
| 310 | nil ))))) | |
| 218 | (non-vars nil) | |
| 219 | (indep nil) | |
| 220 | (dep nil) | |
| 221 | (accum-vars nil) | |
| 222 | (top-vars nil) | |
| 223 | (indep-vars nil) | |
| 224 | (dep-vars nil) | |
| 225 | ) | |
| 226 | ||
| 227 | ;; first separate out the variables. | |
| 228 | (dolist (tm subs) | |
| 229 | (if (term-is-variable? tm) | |
| 230 | (push tm top-vars) | |
| 231 | (push tm non-vars))) | |
| 232 | (setq non-vars (nreverse non-vars)) | |
| 233 | ||
| 234 | ;; split non-vars into indep and dep parts. | |
| 235 | (let ((all-vars nil)) ;all variables contained in non-vars. | |
| 236 | (dolist (nv non-vars) | |
| 237 | (setq all-vars (union all-vars (term-variables nv) :test #'eq))) | |
| 238 | (if (null all-vars) | |
| 239 | (setq indep non-vars | |
| 240 | dep nil) | |
| 241 | (let (cur) | |
| 242 | (while-not (subsetp all-vars accum-vars :test #'eq) | |
| 243 | (setf cur (pop non-vars)) | |
| 244 | (push cur indep) | |
| 245 | (setf accum-vars (union accum-vars (term-variables cur) | |
| 246 | :test #'eq))) | |
| 247 | (setf dep non-vars)))) | |
| 248 | ||
| 249 | ;; split variables appearing at top level into indep and dep parts. | |
| 250 | (dolist (v top-vars) | |
| 251 | (if (member v accum-vars :test #'eq) | |
| 252 | (push v dep-vars) | |
| 253 | (if (member v indep-vars :test #'eq) | |
| 254 | ;; we require linerality of independent variables. | |
| 255 | (return-from exit nil) | |
| 256 | (push v indep-vars)))) | |
| 257 | (setq indep-vars (topo-sort indep-vars | |
| 258 | #'(lambda (x y) | |
| 259 | (sort< (variable-sort x) | |
| 260 | (variable-sort y) | |
| 261 | so)))) | |
| 262 | (setq dep-vars (nreverse dep-vars)) | |
| 263 | (if (and indep | |
| 264 | (or dep ; there are dependent or there are a few | |
| 265 | dep-vars ; easy matching cases. | |
| 266 | (< 1 (length indep-vars))) | |
| 267 | (or (null (cdr indep-vars)) | |
| 268 | ; indep-vars must be linearly | |
| 269 | ; ordered by sort. | |
| 270 | (do ((cur (car indep-vars) nxt) | |
| 271 | (nxt (cadr indep-vars) (car lst)) | |
| 272 | (lst (cddr indep-vars) (cdr lst))) | |
| 273 | ((null nxt) t) | |
| 274 | (unless (sort<= (variable-sort cur) | |
| 275 | (variable-sort nxt) | |
| 276 | so) | |
| 277 | (return nil))))) | |
| 278 | ;; restructure the pattern. | |
| 279 | (progn | |
| 280 | (when *match-debug* | |
| 281 | (format t "~%is-simple-ac-match-ok?, before") | |
| 282 | (print-term-tree pattern) | |
| 283 | (format t "~%-- indep = ") | |
| 284 | (print-chaos-object indep) | |
| 285 | (format t "~%-- dep(lst) = ") | |
| 286 | (print-chaos-object dep) | |
| 287 | (format t "~%-- dep-vars = ") | |
| 288 | (print-chaos-object dep-vars) | |
| 289 | (format t "~%-- idep-vars = ") | |
| 290 | (print-chaos-object indep-vars) | |
| 291 | (force-output)) | |
| 292 | (term-replace pattern | |
| 293 | (make-right-assoc-normal-form-with-sort-check | |
| 294 | meth | |
| 295 | (append | |
| 296 | (list (make-right-assoc-normal-form-with-sort-check | |
| 297 | meth | |
| 298 | indep)) | |
| 299 | dep | |
| 300 | dep-vars | |
| 301 | indep-vars))) | |
| 302 | (when *match-debug* | |
| 303 | (format t "~%is-simple-ac-match-ok?, after") | |
| 304 | (print-chaos-object pattern) | |
| 305 | (force-output) | |
| 306 | (print-term-tree pattern) | |
| 307 | (force-output)) | |
| 308 | t) | |
| 309 | ;; else | |
| 310 | nil ))))) | |
| 311 | 311 | |
| 312 | 312 | |
| 313 | 313 | ;;; DEP-MATCH : PATTERN TARGET -> GLOBALSTATE SUBSTITUTION NO-MATCH-FLAG E-EQUAL |
| 318 | 318 | |
| 319 | 319 | (defun dep-match (pattern t2) |
| 320 | 320 | (declare (type term pattern t2) |
| 321 | (values list list (or null t) (or null t))) | |
| 321 | (values list list (or null t) (or null t))) | |
| 322 | 322 | (let* ((subs (term-subterms pattern)) |
| 323 | (indep (car subs)) | |
| 324 | (method (term-method pattern)) | |
| 325 | (coarity (method-coarity method)) | |
| 326 | (new-pat (make-applform coarity method (list indep *match-dep-var*))) | |
| 327 | (so *current-sort-order*)) | |
| 323 | (indep (car subs)) | |
| 324 | (method (term-method pattern)) | |
| 325 | (coarity (method-coarity method)) | |
| 326 | (new-pat (make-applform coarity method (list indep *match-dep-var*))) | |
| 327 | (so *current-sort-order*)) | |
| 328 | 328 | ;; |
| 329 | 329 | (multiple-value-bind (global-state subst no-match E-equal) |
| 330 | (first-match new-pat t2) | |
| 330 | (first-match new-pat t2) | |
| 331 | 331 | (when (or no-match E-equal) |
| 332 | (return-from dep-match (values nil nil no-match E-equal))) | |
| 332 | (return-from dep-match (values nil nil no-match E-equal))) | |
| 333 | 333 | (let* ((dep (list-AC-subterms (cadr subs) method)) |
| 334 | (dep-len (length dep))) | |
| 335 | (declare (type fixnum dep-len) | |
| 336 | (type list dep) | |
| 337 | (ignore dep-len)) | |
| 338 | (loop | |
| 339 | ;; try to finish if succeed return subst. | |
| 340 | (let ((ok t) | |
| 341 | (rest (list-AC-subterms (variable-image | |
| 342 | subst | |
| 343 | *match-dep-var*) | |
| 344 | method)) | |
| 345 | (lst dep) | |
| 346 | x) | |
| 347 | (declare (type list rest lst)) | |
| 348 | (when (< (the fixnum (length rest)) | |
| 349 | (the fixnum (length dep))) | |
| 350 | (return (values nil nil t nil))) ;quit whole matching process | |
| 351 | (block finish-match | |
| 352 | (while lst | |
| 353 | (when (null rest) (setq ok nil) (return)) | |
| 354 | (setq x (car lst) lst (cdr lst)) | |
| 355 | (if (term-is-variable? x) | |
| 356 | (let ((val (variable-image subst x))) | |
| 357 | (if val | |
| 358 | ;;remove value if find or fail; rest is not nil | |
| 359 | ;;tricky point: if bound value of term has op at top | |
| 360 | ;;need to treat its list-ac-subterms individually. | |
| 361 | (dolist (tm (if (and (not (term-is-variable? val)) | |
| 362 | (method-is-AC-restriction-of | |
| 363 | (term-head val) | |
| 364 | method)) | |
| 365 | (list-AC-subterms val method) | |
| 366 | (list val))) | |
| 367 | (let ((prev nil) (cur rest)) | |
| 368 | (loop | |
| 369 | (when (null cur) (setq ok nil) (return-from finish-match)) | |
| 370 | (when (term-equational-equal tm (car cur)) | |
| 371 | (if (null prev) | |
| 372 | (setq rest (cdr rest)) | |
| 373 | (rplacd prev (cdr cur))) | |
| 374 | (return)) | |
| 375 | (setq prev cur cur (cdr cur))))) | |
| 376 | ;;else, find term for var and bind, if last done | |
| 377 | (if (null lst) | |
| 378 | (if (null (cdr rest)) | |
| 379 | (if (sort<= (term-sort (car rest)) | |
| 380 | (variable-sort x) | |
| 381 | so) | |
| 382 | (progn | |
| 383 | (push (cons x (car rest)) subst) | |
| 384 | (setq rest nil)) | |
| 385 | (progn (setq ok nil) (return))) | |
| 386 | (if (sort<= coarity (variable-sort x) so) | |
| 387 | (progn | |
| 388 | (push (cons x | |
| 389 | (make-right-assoc-normal-form-with-sort-check | |
| 390 | method rest)) | |
| 391 | subst) | |
| 392 | (setq rest nil)) | |
| 393 | (progn (setq ok nil) (return)))) | |
| 394 | (let ((varsort (variable-sort x)) | |
| 395 | (prev nil) (cur rest)) | |
| 396 | (loop | |
| 397 | (when (null cur) (setq ok nil) (return-from finish-match)) | |
| 398 | (when (sort<= (term-sort (car cur)) varsort so) | |
| 399 | (if (null prev) | |
| 400 | (setq rest (cdr rest)) | |
| 401 | (rplacd prev (cdr cur))) | |
| 402 | (push (cons x (car cur)) subst) | |
| 403 | (return)) | |
| 404 | (setq prev cur cur (cdr cur)))) | |
| 405 | ))) | |
| 406 | ;; instantiate and find or fail; rest is not nil | |
| 407 | (let ((instx (substitution-image subst x)) | |
| 408 | (prev nil) (cur rest)) | |
| 409 | (loop | |
| 410 | (when (null cur) (setq ok nil) (return-from finish-match)) | |
| 411 | (when (term-equational-equal instx (car cur)) | |
| 412 | (if (null prev) | |
| 413 | (setq rest (cdr rest)) | |
| 414 | (rplacd prev (cdr cur))) | |
| 415 | (return)) | |
| 416 | (setq prev cur cur (cdr cur))))) | |
| 417 | )) ; finish-match ---------- | |
| 418 | (when (and ok (null rest)) (return (values nil subst nil nil)))) | |
| 419 | ;; | |
| 420 | (multiple-value-setq (global-state subst no-match) | |
| 421 | (next-match global-state)) | |
| 422 | (when no-match | |
| 423 | (return (values nil nil t nil)))) ; loop -------------------------- | |
| 424 | ;; | |
| 425 | )))) | |
| 334 | (dep-len (length dep))) | |
| 335 | (declare (type fixnum dep-len) | |
| 336 | (type list dep) | |
| 337 | (ignore dep-len)) | |
| 338 | (loop | |
| 339 | ;; try to finish if succeed return subst. | |
| 340 | (let ((ok t) | |
| 341 | (rest (list-AC-subterms (variable-image | |
| 342 | subst | |
| 343 | *match-dep-var*) | |
| 344 | method)) | |
| 345 | (lst dep) | |
| 346 | x) | |
| 347 | (declare (type list rest lst)) | |
| 348 | (when (< (the fixnum (length rest)) | |
| 349 | (the fixnum (length dep))) | |
| 350 | (return (values nil nil t nil))) ;quit whole matching process | |
| 351 | (block finish-match | |
| 352 | (while lst | |
| 353 | (when (null rest) (setq ok nil) (return)) | |
| 354 | (setq x (car lst) lst (cdr lst)) | |
| 355 | (if (term-is-variable? x) | |
| 356 | (let ((val (variable-image subst x))) | |
| 357 | (if val | |
| 358 | ;;remove value if find or fail; rest is not nil | |
| 359 | ;;tricky point: if bound value of term has op at top | |
| 360 | ;;need to treat its list-ac-subterms individually. | |
| 361 | (dolist (tm (if (and (not (term-is-variable? val)) | |
| 362 | (method-is-AC-restriction-of | |
| 363 | (term-head val) | |
| 364 | method)) | |
| 365 | (list-AC-subterms val method) | |
| 366 | (list val))) | |
| 367 | (let ((prev nil) (cur rest)) | |
| 368 | (loop | |
| 369 | (when (null cur) (setq ok nil) (return-from finish-match)) | |
| 370 | (when (term-equational-equal tm (car cur)) | |
| 371 | (if (null prev) | |
| 372 | (setq rest (cdr rest)) | |
| 373 | (rplacd prev (cdr cur))) | |
| 374 | (return)) | |
| 375 | (setq prev cur cur (cdr cur))))) | |
| 376 | ;;else, find term for var and bind, if last done | |
| 377 | (if (null lst) | |
| 378 | (if (null (cdr rest)) | |
| 379 | (if (sort<= (term-sort (car rest)) | |
| 380 | (variable-sort x) | |
| 381 | so) | |
| 382 | (progn | |
| 383 | (push (cons x (car rest)) subst) | |
| 384 | (setq rest nil)) | |
| 385 | (progn (setq ok nil) (return))) | |
| 386 | (if (sort<= coarity (variable-sort x) so) | |
| 387 | (progn | |
| 388 | (push (cons x | |
| 389 | (make-right-assoc-normal-form-with-sort-check | |
| 390 | method rest)) | |
| 391 | subst) | |
| 392 | (setq rest nil)) | |
| 393 | (progn (setq ok nil) (return)))) | |
| 394 | (let ((varsort (variable-sort x)) | |
| 395 | (prev nil) (cur rest)) | |
| 396 | (loop | |
| 397 | (when (null cur) (setq ok nil) (return-from finish-match)) | |
| 398 | (when (sort<= (term-sort (car cur)) varsort so) | |
| 399 | (if (null prev) | |
| 400 | (setq rest (cdr rest)) | |
| 401 | (rplacd prev (cdr cur))) | |
| 402 | (push (cons x (car cur)) subst) | |
| 403 | (return)) | |
| 404 | (setq prev cur cur (cdr cur)))) | |
| 405 | ))) | |
| 406 | ;; instantiate and find or fail; rest is not nil | |
| 407 | (let ((instx (substitution-image subst x)) | |
| 408 | (prev nil) (cur rest)) | |
| 409 | (loop | |
| 410 | (when (null cur) (setq ok nil) (return-from finish-match)) | |
| 411 | (when (term-equational-equal instx (car cur)) | |
| 412 | (if (null prev) | |
| 413 | (setq rest (cdr rest)) | |
| 414 | (rplacd prev (cdr cur))) | |
| 415 | (return)) | |
| 416 | (setq prev cur cur (cdr cur))))) | |
| 417 | )) ; finish-match ---------- | |
| 418 | (when (and ok (null rest)) (return (values nil subst nil nil)))) | |
| 419 | ;; | |
| 420 | (multiple-value-setq (global-state subst no-match) | |
| 421 | (next-match global-state)) | |
| 422 | (when no-match | |
| 423 | (return (values nil nil t nil)))) ; loop -------------------------- | |
| 424 | ;; | |
| 425 | )))) | |
| 426 | 426 | |
| 427 | 427 | ;;; MATCH-DEP-WITH-THEORY : theory pattern target |
| 428 | 428 | ;;; -> global-state substitution no-match-flag e-equal |
| 434 | 434 | |
| 435 | 435 | (defun match-dep-with-theory (theory t1 t2) |
| 436 | 436 | (declare (type theory-info theory) |
| 437 | (type term t1 t2)) | |
| 437 | (type term t1 t2)) | |
| 438 | 438 | (let* ((subs (term-subterms t1)) |
| 439 | (indep (car subs)) | |
| 440 | (meth (term-head t1)) | |
| 441 | (coar (method-coarity meth)) | |
| 442 | (newpat (make-applform coar meth (list indep *match-dep-var*)))) | |
| 439 | (indep (car subs)) | |
| 440 | (meth (term-head t1)) | |
| 441 | (coar (method-coarity meth)) | |
| 442 | (newpat (make-applform coar meth (list indep *match-dep-var*)))) | |
| 443 | 443 | (declare (type list subs)) |
| 444 | 444 | (multiple-value-bind |
| 445 | (global-state subst no-match E-equal) | |
| 446 | (first-match-with-theory theory newpat t2) | |
| 445 | (global-state subst no-match E-equal) | |
| 446 | (first-match-with-theory theory newpat t2) | |
| 447 | 447 | (if (or no-match E-equal) |
| 448 | (values nil nil no-match E-equal) | |
| 449 | (let ((dep (list-AC-subterms (cadr subs) meth)) | |
| 450 | (so *current-sort-order*)) | |
| 451 | (declare (type list dep) | |
| 452 | (type sort-order so)) | |
| 453 | (loop | |
| 454 | ;; try to finish if succeed return subst. | |
| 455 | (let ((ok t) | |
| 456 | (rest (list-AC-subterms (variable-image | |
| 457 | subst | |
| 458 | *match-dep-var*) | |
| 459 | meth)) | |
| 460 | (lst dep) | |
| 461 | x) | |
| 462 | (declare (type list rest)) | |
| 463 | (when (< (length rest) (length dep)) | |
| 464 | (return (values nil nil t nil))) ; quit whole matching process | |
| 465 | (block finish-match | |
| 466 | (loop | |
| 467 | (when (null lst) (return)) | |
| 468 | (when (null rest) (setq ok nil) (return)) | |
| 469 | (setq x (car lst) | |
| 470 | lst (cdr lst)) | |
| 471 | (if (term-is-variable? x) | |
| 472 | (let ((val (variable-image subst x))) | |
| 473 | (if val | |
| 474 | ;; remove value if find or fail; rest is not nil | |
| 475 | ;; tricky point: if bound value of term has op at top | |
| 476 | ;; need to treat its term-list-ac-subterms individually | |
| 477 | (dolist (tm (if (and (not (term-is-applform? val)) | |
| 478 | (method-is-AC-restriction-of | |
| 479 | (term-head val) | |
| 480 | meth)) | |
| 481 | (list-AC-subterms val meth) | |
| 482 | (list val))) | |
| 483 | (let ((prev nil) | |
| 484 | (cur rest)) | |
| 485 | (loop | |
| 486 | (when (null cur) | |
| 487 | (setq ok nil) | |
| 488 | (return-from finish-match)) | |
| 489 | (when (term-equational-equal tm (car cur)) | |
| 490 | (if (null prev) | |
| 491 | (setq rest (cdr rest)) | |
| 492 | (rplacd prev (cdr cur))) | |
| 493 | (return)) | |
| 494 | (setq prev cur cur (cdr cur))))) | |
| 495 | ;; find term for var and bind; if last done | |
| 496 | (if (null lst) | |
| 497 | (if (null (cdr rest)) | |
| 498 | (if (sort<= (term-sort (car rest)) | |
| 499 | (variable-sort x) | |
| 500 | so) | |
| 501 | (progn (push (cons x (car rest)) subst) | |
| 502 | (setq rest nil)) | |
| 503 | (progn (setq ok nil) | |
| 504 | (return))) | |
| 505 | (if (sort<= coar (variable-sort x) so) | |
| 506 | (progn | |
| 507 | (push | |
| 508 | (cons x | |
| 509 | (make-right-assoc-normal-form-with-sort-check | |
| 510 | meth rest)) | |
| 511 | subst) | |
| 512 | (setq rest nil)) | |
| 513 | (progn (setq ok nil) | |
| 514 | (return)))) | |
| 515 | (let ((varsort (variable-sort x)) | |
| 516 | (prev nil) | |
| 517 | (cur rest)) | |
| 518 | (loop | |
| 519 | (when (null cur) | |
| 520 | (setq ok nil) | |
| 521 | (return-from finish-match)) | |
| 522 | (when (sort<= (term-sort (car cur)) | |
| 523 | varsort | |
| 524 | so) | |
| 525 | (if (null prev) | |
| 526 | (setq rest (cdr rest)) | |
| 527 | (rplacd prev (cdr cur))) | |
| 528 | (push (cons x (car cur)) subst) | |
| 529 | (return)) | |
| 530 | (setq prev cur | |
| 531 | cur (cdr cur)) | |
| 532 | ))))) | |
| 533 | ;; instantiate and find or fail; rest is not nil | |
| 534 | (let ((instx (substitution-image subst x)) | |
| 535 | (prev nil) | |
| 536 | (cur rest)) | |
| 537 | (loop (when (null cur) | |
| 538 | (setq ok nil) | |
| 539 | (return-from finish-match)) | |
| 540 | (when (term-equational-equal instx (car cur)) | |
| 541 | (if (null prev) | |
| 542 | (setq rest (cdr rest)) | |
| 543 | (rplacd prev (cdr cur))) | |
| 544 | (return)) | |
| 545 | (setq prev cur | |
| 546 | cur (cdr cur))))) | |
| 547 | )) ; -- block finish-match | |
| 548 | (when (and ok (null rest)) | |
| 549 | (return (values nil subst nil nil)))) | |
| 550 | ;; | |
| 551 | (multiple-value-setq (global-state subst no-match) | |
| 552 | (next-match global-state)) | |
| 553 | (when no-match | |
| 554 | (return (values nil nil t nil))) | |
| 555 | )))))) | |
| 448 | (values nil nil no-match E-equal) | |
| 449 | (let ((dep (list-AC-subterms (cadr subs) meth)) | |
| 450 | (so *current-sort-order*)) | |
| 451 | (declare (type list dep) | |
| 452 | (type sort-order so)) | |
| 453 | (loop | |
| 454 | ;; try to finish if succeed return subst. | |
| 455 | (let ((ok t) | |
| 456 | (rest (list-AC-subterms (variable-image | |
| 457 | subst | |
| 458 | *match-dep-var*) | |
| 459 | meth)) | |
| 460 | (lst dep) | |
| 461 | x) | |
| 462 | (declare (type list rest)) | |
| 463 | (when (< (length rest) (length dep)) | |
| 464 | (return (values nil nil t nil))) ; quit whole matching process | |
| 465 | (block finish-match | |
| 466 | (loop | |
| 467 | (when (null lst) (return)) | |
| 468 | (when (null rest) (setq ok nil) (return)) | |
| 469 | (setq x (car lst) | |
| 470 | lst (cdr lst)) | |
| 471 | (if (term-is-variable? x) | |
| 472 | (let ((val (variable-image subst x))) | |
| 473 | (if val | |
| 474 | ;; remove value if find or fail; rest is not nil | |
| 475 | ;; tricky point: if bound value of term has op at top | |
| 476 | ;; need to treat its term-list-ac-subterms individually | |
| 477 | (dolist (tm (if (and (not (term-is-applform? val)) | |
| 478 | (method-is-AC-restriction-of | |
| 479 | (term-head val) | |
| 480 | meth)) | |
| 481 | (list-AC-subterms val meth) | |
| 482 | (list val))) | |
| 483 | (let ((prev nil) | |
| 484 | (cur rest)) | |
| 485 | (loop | |
| 486 | (when (null cur) | |
| 487 | (setq ok nil) | |
| 488 | (return-from finish-match)) | |
| 489 | (when (term-equational-equal tm (car cur)) | |
| 490 | (if (null prev) | |
| 491 | (setq rest (cdr rest)) | |
| 492 | (rplacd prev (cdr cur))) | |
| 493 | (return)) | |
| 494 | (setq prev cur cur (cdr cur))))) | |
| 495 | ;; find term for var and bind; if last done | |
| 496 | (if (null lst) | |
| 497 | (if (null (cdr rest)) | |
| 498 | (if (sort<= (term-sort (car rest)) | |
| 499 | (variable-sort x) | |
| 500 | so) | |
| 501 | (progn (push (cons x (car rest)) subst) | |
| 502 | (setq rest nil)) | |
| 503 | (progn (setq ok nil) | |
| 504 | (return))) | |
| 505 | (if (sort<= coar (variable-sort x) so) | |
| 506 | (progn | |
| 507 | (push | |
| 508 | (cons x | |
| 509 | (make-right-assoc-normal-form-with-sort-check | |
| 510 | meth rest)) | |
| 511 | subst) | |
| 512 | (setq rest nil)) | |
| 513 | (progn (setq ok nil) | |
| 514 | (return)))) | |
| 515 | (let ((varsort (variable-sort x)) | |
| 516 | (prev nil) | |
| 517 | (cur rest)) | |
| 518 | (loop | |
| 519 | (when (null cur) | |
| 520 | (setq ok nil) | |
| 521 | (return-from finish-match)) | |
| 522 | (when (sort<= (term-sort (car cur)) | |
| 523 | varsort | |
| 524 | so) | |
| 525 | (if (null prev) | |
| 526 | (setq rest (cdr rest)) | |
| 527 | (rplacd prev (cdr cur))) | |
| 528 | (push (cons x (car cur)) subst) | |
| 529 | (return)) | |
| 530 | (setq prev cur | |
| 531 | cur (cdr cur)) | |
| 532 | ))))) | |
| 533 | ;; instantiate and find or fail; rest is not nil | |
| 534 | (let ((instx (substitution-image subst x)) | |
| 535 | (prev nil) | |
| 536 | (cur rest)) | |
| 537 | (loop (when (null cur) | |
| 538 | (setq ok nil) | |
| 539 | (return-from finish-match)) | |
| 540 | (when (term-equational-equal instx (car cur)) | |
| 541 | (if (null prev) | |
| 542 | (setq rest (cdr rest)) | |
| 543 | (rplacd prev (cdr cur))) | |
| 544 | (return)) | |
| 545 | (setq prev cur | |
| 546 | cur (cdr cur))))) | |
| 547 | )) ; -- block finish-match | |
| 548 | (when (and ok (null rest)) | |
| 549 | (return (values nil subst nil nil)))) | |
| 550 | ;; | |
| 551 | (multiple-value-setq (global-state subst no-match) | |
| 552 | (next-match global-state)) | |
| 553 | (when no-match | |
| 554 | (return (values nil nil t nil))) | |
| 555 | )))))) | |
| 556 | 556 | |
| 557 | 557 | |
| 558 | 558 | ;;; IDEMPOTENT --------------------------------------------------------------- |
| 568 | 568 | (not (term-is-variable? lhs)) |
| 569 | 569 | (not (term-is-builtin-constant? lhs)) |
| 570 | 570 | (let ((method (term-head lhs))) |
| 571 | (and (method-is-associative method) | |
| 572 | (method-is-commutative method) | |
| 573 | (method-is-idempotent method) | |
| 574 | (let* ((arity (method-arity method)) | |
| 575 | (subs (term-subterms lhs)) | |
| 576 | (sub-1 (car subs)) | |
| 577 | (sub-2 (cadr subs))) | |
| 578 | (and (term-is-variable? sub-1) | |
| 579 | ;; (term-is-variable? sub-2) ; this is redundant. | |
| 580 | (eq sub-1 sub-2) | |
| 581 | (sort= (variable-sort sub-1) (car arity)) | |
| 582 | (sort= (variable-sort sub-2) (cadr arity)))))))) | |
| 571 | (and (method-is-associative method) | |
| 572 | (method-is-commutative method) | |
| 573 | (method-is-idempotent method) | |
| 574 | (let* ((arity (method-arity method)) | |
| 575 | (subs (term-subterms lhs)) | |
| 576 | (sub-1 (car subs)) | |
| 577 | (sub-2 (cadr subs))) | |
| 578 | (and (term-is-variable? sub-1) | |
| 579 | ;; (term-is-variable? sub-2) ; this is redundant. | |
| 580 | (eq sub-1 sub-2) | |
| 581 | (sort= (variable-sort sub-1) (car arity)) | |
| 582 | (sort= (variable-sort sub-2) (cadr arity)))))))) | |
| 583 | 583 | |
| 584 | 584 | ;;; NOTE: assume that the rules is actually created in the form e + (x + x). |
| 585 | 585 | ;;; |
| 586 | 586 | (defun match-is-idem-ext-ok? (lhs cond kind) |
| 587 | 587 | (declare (type term lhs cond) |
| 588 | (values (or null t))) | |
| 588 | (values (or null t))) | |
| 589 | 589 | (and (is-true? cond) |
| 590 | 590 | (not (term-is-variable? lhs)) |
| 591 | 591 | (let ((method (term-head lhs))) |
| 592 | (and (method-is-associative method) | |
| 593 | (method-is-commutative method) | |
| 594 | (method-is-idempotent method) | |
| 595 | (let* ((arity (method-arity method)) | |
| 596 | (subs (term-subterms lhs)) | |
| 597 | (sub-1 (car subs)) | |
| 598 | (sub-2 (cadr subs))) | |
| 599 | (and (term-is-variable? sub-1) | |
| 600 | (let ((vs (variable-sort sub-1))) | |
| 601 | (or (or (sort= vs *universal-sort*) | |
| 602 | (sort= vs *huniversal-sort*) | |
| 603 | (sort= vs *cosmos*)) | |
| 604 | (and (sort= vs (car arity)) | |
| 605 | (sort= vs (cadr arity))))) | |
| 606 | (match-is-idem-ok2? sub-2 cond kind) | |
| 607 | (not (eq sub-1 (car (term-subterms sub-2)))) | |
| 608 | )))))) | |
| 592 | (and (method-is-associative method) | |
| 593 | (method-is-commutative method) | |
| 594 | (method-is-idempotent method) | |
| 595 | (let* ((arity (method-arity method)) | |
| 596 | (subs (term-subterms lhs)) | |
| 597 | (sub-1 (car subs)) | |
| 598 | (sub-2 (cadr subs))) | |
| 599 | (and (term-is-variable? sub-1) | |
| 600 | (let ((vs (variable-sort sub-1))) | |
| 601 | (or (or (sort= vs *universal-sort*) | |
| 602 | (sort= vs *huniversal-sort*) | |
| 603 | (sort= vs *cosmos*)) | |
| 604 | (and (sort= vs (car arity)) | |
| 605 | (sort= vs (cadr arity))))) | |
| 606 | (match-is-idem-ok2? sub-2 cond kind) | |
| 607 | (not (eq sub-1 (car (term-subterms sub-2)))) | |
| 608 | )))))) | |
| 609 | 609 | |
| 610 | 610 | ;;; EOF |
| 0 | 0 | ;;;-*- Mode:LISP; Package:CHAOS; Base:10; Syntax:Common-lisp -*- |
| 1 | 1 | ;;; |
| 2 | ;;; Copyright (c) 2000-2014, Toshimi Sawada. All rights reserved. | |
| 2 | ;;; Copyright (c) 2000-2015, Toshimi Sawada. All rights reserved. | |
| 3 | 3 | ;;; |
| 4 | 4 | ;;; Redistribution and use in source and binary forms, with or without |
| 5 | 5 | ;;; modification, are permitted provided that the following conditions |
| 27 | 27 | ;;; |
| 28 | 28 | (in-package :chaos) |
| 29 | 29 | #|============================================================================== |
| 30 | System: CHAOS | |
| 31 | Module: eval | |
| 32 | File: chaos-top.lisp | |
| 30 | System: CHAOS | |
| 31 | Module: eval | |
| 32 | File: chaos-top.lisp | |
| 33 | 33 | ==============================================================================|# |
| 34 | 34 | |
| 35 | 35 | ;;; == DESCRIPTION ============================================================= |
| 78 | 78 | (ext:gc) |
| 79 | 79 | (if top |
| 80 | 80 | (ext:save-lisp path |
| 81 | :purify nil | |
| 82 | :init-function top | |
| 83 | :print-herald nil | |
| 84 | ) | |
| 81 | :purify nil | |
| 82 | :init-function top | |
| 83 | :print-herald nil | |
| 84 | ) | |
| 85 | 85 | (ext:save-lisp path |
| 86 | :purify nil | |
| 87 | :print-herald nil))) | |
| 86 | :purify nil | |
| 87 | :print-herald nil))) | |
| 88 | 88 | |
| 89 | 89 | #+LUCID |
| 90 | 90 | (defun save-chaos (top &optional (path "bin/chaos.exe")) |
| 91 | 91 | (setq *chaos-new* t) |
| 92 | 92 | (if top |
| 93 | 93 | (disksave path |
| 94 | :full-gc t | |
| 95 | :restart-function top) | |
| 94 | :full-gc t | |
| 95 | :restart-function top) | |
| 96 | 96 | (disksave path |
| 97 | :full-gc t))) | |
| 97 | :full-gc t))) | |
| 98 | 98 | |
| 99 | 99 | #+:ccl |
| 100 | 100 | (defun save-chaos (top &optional (path "chaos")) |
| 101 | 101 | (setq *chaos-new* t) |
| 102 | 102 | (if top |
| 103 | 103 | (save-application path :toplevel-function top |
| 104 | :size '(6144000 4196000)) | |
| 104 | :size '(6144000 4196000)) | |
| 105 | 105 | (save-application path |
| 106 | :size '(6144000 4196000)))) | |
| 106 | :size '(6144000 4196000)))) | |
| 107 | 107 | #+:ALLEGRO |
| 108 | 108 | (defun save-chaos (top &optional (path "aobj")) |
| 109 | 109 | (setq *chaos-new* t) |
| 125 | 125 | (declare (ignore top)) |
| 126 | 126 | (setq *chaos-new* t) |
| 127 | 127 | (sb-ext:save-lisp-and-die path |
| 128 | :toplevel 'chaos::cafeobj-top-level | |
| 129 | :purify t | |
| 130 | :executable t | |
| 131 | :save-runtime-options t)) | |
| 128 | :toplevel 'chaos::cafeobj-top-level | |
| 129 | :purify t | |
| 130 | :executable t | |
| 131 | :save-runtime-options t)) | |
| 132 | 132 | |
| 133 | 133 | ;;; PROCESS-CHAOS-INPUT |
| 134 | 134 | ;;; |
| 136 | 136 | (let ((*standard-output* stream)) |
| 137 | 137 | (fresh-all) |
| 138 | 138 | (flush-all) |
| 139 | (format t "~&[") | |
| 140 | (if *last-module* | |
| 141 | (print-simple-mod-name *last-module*) | |
| 139 | (format t "~%[") | |
| 140 | (if (get-context-module t) | |
| 141 | (print-simple-mod-name (get-context-module)) | |
| 142 | 142 | (princ "*")) |
| 143 | (princ "]> ") | |
| 144 | )) | |
| 143 | (princ "]> "))) | |
| 145 | 144 | |
| 146 | 145 | (defun handle-chaos-error (val) |
| 147 | 146 | (if *chaos-input-source* |
| 163 | 162 | (declare (ignore char)) |
| 164 | 163 | (let ((obj (read stream nil :eof t))) |
| 165 | 164 | (if (eq obj :eof) |
| 166 | (values) | |
| 165 | (values) | |
| 167 | 166 | (eval-ast obj)))) |
| 168 | 167 | |
| 169 | 168 | (defun process-chaos-input () |
| 170 | 169 | (let ((*print-array* nil) |
| 171 | (*print-circle* nil) | |
| 172 | (*old-context* nil) | |
| 173 | (*show-mode* :chaos) | |
| 174 | (top-level (at-top-level))) | |
| 170 | (*print-circle* nil) | |
| 171 | (*old-context* nil) | |
| 172 | (*show-mode* :chaos) | |
| 173 | (top-level (at-top-level))) | |
| 175 | 174 | (unless (or top-level *chaos-quiet*) |
| 176 | 175 | (if *chaos-input-source* |
| 177 | (with-output-simple-msg () | |
| 178 | (format t "~&processing input : ~a~%" (namestring *chaos-input-source*))) | |
| 179 | (with-output-simple-msg () | |
| 180 | (format t "~&processing input .......................~%"))) | |
| 176 | (with-output-simple-msg () | |
| 177 | (format t "rocessing input : ~a~%" (namestring *chaos-input-source*))) | |
| 178 | (with-output-simple-msg () | |
| 179 | (format t "processing input .......................~%"))) | |
| 181 | 180 | ) |
| 182 | 181 | (let ((ast nil) |
| 183 | (*readtable* (copy-readtable))) | |
| 182 | (*readtable* (copy-readtable))) | |
| 184 | 183 | ;; (declare (special *readtable*)) |
| 185 | 184 | (set-macro-character #\! #'chaos-eval-reader) |
| 186 | 185 | (block top-loop |
| 187 | (loop | |
| 188 | (with-chaos-top-error ('handle-chaos-top-error) | |
| 189 | (with-chaos-error ('handle-chaos-error) | |
| 190 | (when top-level | |
| 191 | (chaos-prompt)) | |
| 192 | (setq ast (chaos-read)) | |
| 193 | ||
| 194 | ;; QUIT ----------------------------------------------------------- | |
| 195 | (when (eq ast :quit) | |
| 196 | (return-from top-loop nil)) | |
| 197 | ;; PROCESS INPUT COMMANDS ========================================= | |
| 198 | (block process-input | |
| 199 | #|| | |
| 200 | (when (eq ast '!) | |
| 201 | (setq ast (eval (chaos-read))) | |
| 202 | (when (eq ast :quit) (return-from top-loop nil))) | |
| 203 | ||# | |
| 204 | (eval-ast ast :print-generic-result) | |
| 205 | ) | |
| 206 | (setq *chaos-print-errors* t))) | |
| 207 | ))))) | |
| 186 | (loop | |
| 187 | (with-chaos-top-error ('handle-chaos-top-error) | |
| 188 | (with-chaos-error ('handle-chaos-error) | |
| 189 | (when top-level | |
| 190 | (chaos-prompt)) | |
| 191 | (setq ast (chaos-read)) | |
| 192 | ||
| 193 | ;; QUIT ----------------------------------------------------------- | |
| 194 | (when (eq ast :quit) | |
| 195 | (return-from top-loop nil)) | |
| 196 | ;; PROCESS INPUT COMMANDS ========================================= | |
| 197 | (block process-input | |
| 198 | #|| | |
| 199 | (when (eq ast '!) | |
| 200 | (setq ast (eval (chaos-read))) | |
| 201 | (when (eq ast :quit) (return-from top-loop nil))) | |
| 202 | ||# | |
| 203 | (eval-ast ast :print-generic-result) | |
| 204 | ) | |
| 205 | (setq *chaos-print-errors* t))) | |
| 206 | ))))) | |
| 208 | 207 | |
| 209 | 208 | ;;; CHAOS TOP LEVEL LOOP |
| 210 | 209 | ;;; [ast/script/lisp-form] ---> (read) ---> (eval) ---> (print) |
| 0 | 0 | ;;;-*- Mode:LISP; Package: Chaos; Base:10; Syntax:Common-lisp -*- |
| 1 | 1 | ;;; |
| 2 | ;;; Copyright (c) 2000-2014, Toshimi Sawada. All rights reserved. | |
| 2 | ;;; Copyright (c) 2000-2015, Toshimi Sawada. All rights reserved. | |
| 3 | 3 | ;;; |
| 4 | 4 | ;;; Redistribution and use in source and binary forms, with or without |
| 5 | 5 | ;;; modification, are permitted provided that the following conditions |
| 32 | 32 | (declaim (optimize (speed 1) (safety 3) #-GCL (debug 3))) |
| 33 | 33 | |
| 34 | 34 | #|============================================================================== |
| 35 | System: Chaos | |
| 36 | Module: eval | |
| 37 | File: debug.lisp | |
| 35 | System: Chaos | |
| 36 | Module: eval | |
| 37 | File: debug.lisp | |
| 38 | 38 | ==============================================================================|# |
| 39 | 39 | |
| 40 | 40 | (defun print-opinfos (module) |
| 49 | 49 | (dolist (opinfo (module-all-operators module)) |
| 50 | 50 | (let ((methods (opinfo-methods opinfo))) |
| 51 | 51 | (dolist (m methods) |
| 52 | (format t "~&method : ") | |
| 52 | (format t "~%method : ") | |
| 53 | 53 | (print-chaos-object m) |
| 54 | 54 | (let ((info (get-method-info m))) |
| 55 | 55 | (if (not info) |
| 56 | (format t "~&could not get method info ! ") | |
| 56 | (format t "~%could not get method info ! ") | |
| 57 | 57 | (print-method-info info)))))))) |
| 58 | 58 | |
| 59 | 59 | (defun print-method-info (info) |
| 0 | 0 | ;;;-*- Mode:LISP; Package:CHAOS; Base:10; Syntax:Common-lisp -*- |
| 1 | 1 | ;;; |
| 2 | ;;; Copyright (c) 2000-2014, Toshimi Sawada. All rights reserved. | |
| 2 | ;;; Copyright (c) 2000-2015, Toshimi Sawada. All rights reserved. | |
| 3 | 3 | ;;; |
| 4 | 4 | ;;; Redistribution and use in source and binary forms, with or without |
| 5 | 5 | ;;; modification, are permitted provided that the following conditions |
| 27 | 27 | ;;; |
| 28 | 28 | (in-package :chaos) |
| 29 | 29 | #|============================================================================== |
| 30 | System: CHAOS | |
| 31 | Module: eval | |
| 32 | File: eval-ast1.lisp | |
| 30 | System: CHAOS | |
| 31 | Module: eval | |
| 32 | File: eval-ast1.lisp | |
| 33 | 33 | ==============================================================================|# |
| 34 | 34 | #-:chaos-debug |
| 35 | 35 | (declaim (optimize (speed 3) (safety 0) #-GCL (debug 0))) |
| 47 | 47 | ;;; **************************************************************************** |
| 48 | 48 | |
| 49 | 49 | ;;;============================================================================= |
| 50 | ;;; SORT, SUBSORT, RECORD/CLASS SORTS | |
| 50 | ;;; SORT, SUBSORT, RECORD/CLASS SORTS | |
| 51 | 51 | ;;;============================================================================= |
| 52 | 52 | |
| 53 | 53 | ;;;----------------------------------------------------------------------------- |
| 61 | 61 | ;;; in the above case. |
| 62 | 62 | (defun resolve-sort-ref (module sort-name) |
| 63 | 63 | (cond ((%is-sort-ref sort-name) |
| 64 | (find-sort-in module sort-name)) | |
| 65 | ((or (symbolp sort-name) | |
| 66 | (stringp sort-name)) | |
| 67 | (find-sort-in module sort-name)) | |
| 68 | (t (with-output-chaos-error ('strange-sort-name) | |
| 69 | (format t "internal error, strange sort name ~a" sort-name) | |
| 70 | )))) | |
| 64 | (find-sort-in module sort-name)) | |
| 65 | ((or (symbolp sort-name) | |
| 66 | (stringp sort-name)) | |
| 67 | (find-sort-in module sort-name)) | |
| 68 | (t (with-output-chaos-error ('strange-sort-name) | |
| 69 | (format t "internal error, strange sort name ~a" sort-name) | |
| 70 | )))) | |
| 71 | 71 | |
| 72 | 72 | ;;; RESOLVE-OR-DEFINE-SORT : sort-name -> sort |
| 73 | 73 | ;;; uses `resove-sort-ref' for referring existing sort, |
| 76 | 76 | (defun resolve-or-define-sort (module sort-name &optional hidden) |
| 77 | 77 | (let ((sort (resolve-sort-ref module sort-name))) |
| 78 | 78 | (if sort |
| 79 | (cond ((or (eq sort *universal-sort*) | |
| 80 | (eq sort *huniversal-sort*) | |
| 81 | ;;(eq sort *cosmos*) | |
| 82 | ) | |
| 83 | (let ((*chaos-quiet* t)) | |
| 84 | (declare (special *chaos-quiet*)) | |
| 85 | (with-output-chaos-error ('invalid-sort-decl) | |
| 86 | (format t "You can not declare built in sort ~A" | |
| 87 | (string (sort-name sort)))))) | |
| 88 | (t (if (or (and hidden (sort-is-hidden sort)) | |
| 89 | (and (not hidden) (not (sort-is-hidden sort)))) | |
| 90 | sort | |
| 91 | (let ((*chaos-quiet* t)) | |
| 92 | (declare (special *chaos-quiet*)) | |
| 93 | (with-output-chaos-warning () | |
| 94 | (princ "declaring ") | |
| 95 | (format t "a ~a sort ~s, there already be a sort" | |
| 96 | (if hidden | |
| 97 | "hidden" | |
| 98 | "visible") | |
| 99 | (if (%is-sort-ref sort-name) | |
| 100 | (%sort-ref-name sort-name) | |
| 101 | sort-name)) | |
| 102 | (print-next) | |
| 103 | (princ "with the same name but of different type (visible/hidden).") | |
| 104 | (print-next) | |
| 105 | (princ "...ignored.") | |
| 106 | (return-from resolve-or-define-sort nil)) | |
| 107 | )))) | |
| 79 | (cond ((or (eq sort *universal-sort*) | |
| 80 | (eq sort *huniversal-sort*) | |
| 81 | ;;(eq sort *cosmos*) | |
| 82 | ) | |
| 83 | (let ((*chaos-quiet* t)) | |
| 84 | (declare (special *chaos-quiet*)) | |
| 85 | (with-output-chaos-error ('invalid-sort-decl) | |
| 86 | (format t "You can not declare built in sort ~A" | |
| 87 | (string (sort-name sort)))))) | |
| 88 | (t (if (or (and hidden (sort-is-hidden sort)) | |
| 89 | (and (not hidden) (not (sort-is-hidden sort)))) | |
| 90 | sort | |
| 91 | (let ((*chaos-quiet* t)) | |
| 92 | (declare (special *chaos-quiet*)) | |
| 93 | (with-output-chaos-warning () | |
| 94 | (princ "declaring ") | |
| 95 | (format t "a ~a sort ~s, there already be a sort" | |
| 96 | (if hidden | |
| 97 | "hidden" | |
| 98 | "visible") | |
| 99 | (if (%is-sort-ref sort-name) | |
| 100 | (%sort-ref-name sort-name) | |
| 101 | sort-name)) | |
| 102 | (print-next) | |
| 103 | (princ "with the same name but of different type (visible/hidden).") | |
| 104 | (print-next) | |
| 105 | (princ "...ignored.") | |
| 106 | (return-from resolve-or-define-sort nil)) | |
| 107 | )))) | |
| 108 | 108 | (cond ((%is-sort-ref sort-name) |
| 109 | (if (%sort-ref-qualifier sort-name) | |
| 110 | ;; should not happen this case. | |
| 111 | (with-output-chaos-error ('invalid-sort-decl) | |
| 112 | (princ "declare-sort accepted a qualified sort-name:") | |
| 113 | (print-next) | |
| 114 | (format t "sort name = ~s, qulifier = " | |
| 115 | (%sort-ref-name sort-name)) | |
| 116 | (print-modexp (%sort-ref-qualifier sort-name)) | |
| 117 | (print-next) | |
| 118 | (princ "ignoring the declaration.") | |
| 119 | ) | |
| 120 | ;; | |
| 121 | (let ((true-name (%sort-ref-name sort-name))) | |
| 122 | (declare-sort-in-module (if (stringp true-name) | |
| 123 | (intern true-name) | |
| 124 | true-name) | |
| 125 | *current-module* | |
| 126 | 'sort | |
| 127 | hidden)))) | |
| 128 | ((stringp sort-name) | |
| 129 | (declare-sort-in-module (intern sort-name) | |
| 130 | *current-module* | |
| 131 | 'sort | |
| 132 | hidden)) | |
| 133 | ((symbolp sort-name) | |
| 134 | (declare-sort-in-module sort-name | |
| 135 | *current-module* | |
| 136 | 'sort | |
| 137 | hidden)) | |
| 138 | (t (with-output-panic-message () | |
| 139 | (format t "declaring sort : accepted invalid name ~s" sort-name) | |
| 140 | (break | |
| 141 | "Please send bug report to \"sawada@sra.co.jp\", thanks~"))))) | |
| 109 | (if (%sort-ref-qualifier sort-name) | |
| 110 | ;; should not happen this case. | |
| 111 | (with-output-chaos-error ('invalid-sort-decl) | |
| 112 | (princ "declare-sort accepted a qualified sort-name:") | |
| 113 | (print-next) | |
| 114 | (format t "sort name = ~s, qulifier = " | |
| 115 | (%sort-ref-name sort-name)) | |
| 116 | (print-modexp (%sort-ref-qualifier sort-name)) | |
| 117 | (print-next) | |
| 118 | (princ "ignoring the declaration.") | |
| 119 | ) | |
| 120 | ;; | |
| 121 | (let ((true-name (%sort-ref-name sort-name))) | |
| 122 | (declare-sort-in-module (if (stringp true-name) | |
| 123 | (intern true-name) | |
| 124 | true-name) | |
| 125 | *current-module* | |
| 126 | 'sort | |
| 127 | hidden)))) | |
| 128 | ((stringp sort-name) | |
| 129 | (declare-sort-in-module (intern sort-name) | |
| 130 | *current-module* | |
| 131 | 'sort | |
| 132 | hidden)) | |
| 133 | ((symbolp sort-name) | |
| 134 | (declare-sort-in-module sort-name | |
| 135 | *current-module* | |
| 136 | 'sort | |
| 137 | hidden)) | |
| 138 | (t (with-output-panic-message () | |
| 139 | (format t "declaring sort : accepted invalid name ~s" sort-name) | |
| 140 | (break | |
| 141 | "Please send bug report to \"sawada@sra.co.jp\", thanks~"))))) | |
| 142 | 142 | )) |
| 143 | 143 | |
| 144 | 144 | ;;; DECLARE-SORT : sort-decl |
| 148 | 148 | (include-chaos-module) |
| 149 | 149 | (set-needs-parse) |
| 150 | 150 | (resolve-or-define-sort *current-module* |
| 151 | (%sort-decl-name sort-decl) | |
| 152 | (%sort-decl-hidden sort-decl))) | |
| 151 | (%sort-decl-name sort-decl) | |
| 152 | (%sort-decl-hidden sort-decl))) | |
| 153 | 153 | |
| 154 | 154 | ;;; DECLARE-PSORT (psort-decl) |
| 155 | 155 | ;;; real evaluation is postponed untill all sorts are visible in the module, |
| 163 | 163 | |
| 164 | 164 | (defun eval-psort-declaration (decl module) |
| 165 | 165 | (let ((sort-ref (%psort-decl-sort decl)) |
| 166 | (sort nil)) | |
| 166 | (sort nil)) | |
| 167 | 167 | ;; we have a case the reference is just a sort-object, |
| 168 | 168 | ;; occuring only when we inherit p-sort in instantiation/renaming. |
| 169 | 169 | ;; |
| 170 | 170 | (if (sort-p sort-ref) |
| 171 | (setq sort sort-ref) | |
| 172 | (setq sort (resolve-sort-ref module (%psort-decl-sort decl)))) | |
| 171 | (setq sort sort-ref) | |
| 172 | (setq sort (resolve-sort-ref module (%psort-decl-sort decl)))) | |
| 173 | 173 | (unless sort |
| 174 | 174 | (with-output-chaos-error ('no-such-sort) |
| 175 | (princ "declaring principal sort, no such sort ") | |
| 176 | (print-sort-ref (%psort-decl-sort decl)) | |
| 177 | )) | |
| 175 | (princ "declaring principal sort, no such sort ") | |
| 176 | (print-sort-ref (%psort-decl-sort decl)) | |
| 177 | )) | |
| 178 | 178 | (setf (module-principal-sort module) sort))) |
| 179 | 179 | |
| 180 | 180 | ;;;----------------------------------------------------------------------------- |
| 188 | 188 | (define-builtin-sort (%bsort-decl-name decl) |
| 189 | 189 | *current-module* |
| 190 | 190 | (list (%bsort-decl-token-predicate decl) |
| 191 | (%bsort-decl-term-creator decl) | |
| 192 | (%bsort-decl-term-printer decl) | |
| 193 | (%bsort-decl-term-predicate decl)) | |
| 191 | (%bsort-decl-term-creator decl) | |
| 192 | (%bsort-decl-term-printer decl) | |
| 193 | (%bsort-decl-term-predicate decl)) | |
| 194 | 194 | (%bsort-decl-hidden decl))) |
| 195 | 195 | |
| 196 | 196 | ;;;----------------------------------------------------------------------------- |
| 208 | 208 | ;; (push subsort-decl (module-sort-relations *current-module*)) |
| 209 | 209 | ;; call declare-subsort-in-module after resolving sort references. |
| 210 | 210 | (let ((hidden (car (%subsort-decl-sort-relation subsort-decl))) |
| 211 | (body (cdr (%subsort-decl-sort-relation subsort-decl)))) | |
| 211 | (body (cdr (%subsort-decl-sort-relation subsort-decl)))) | |
| 212 | 212 | (declare-subsort-in-module |
| 213 | 213 | (list (mapcar #'(lambda (x) |
| 214 | (if (eq x ':<) | |
| 215 | ':< | |
| 216 | (resolve-or-define-sort *current-module* x hidden))) | |
| 217 | body)) | |
| 214 | (if (eq x ':<) | |
| 215 | ':< | |
| 216 | (resolve-or-define-sort *current-module* x hidden))) | |
| 217 | body)) | |
| 218 | 218 | *current-module* |
| 219 | 219 | hidden ))) |
| 220 | 220 | |
| 221 | ;;;----------------------------------------------------------------------------- | |
| 222 | ;;; DECLARE-RECORD | |
| 223 | ;;; | |
| 224 | (defun declare-record (record-decl) | |
| 225 | (I-miss-current-module declare-record) | |
| 226 | (include-BOOL) | |
| 227 | (include-RECORD) | |
| 228 | (let ((rsort (declare-record-in-module *current-module* | |
| 229 | (%record-decl-name record-decl) | |
| 230 | (%record-decl-supers record-decl) | |
| 231 | (%record-decl-attributes | |
| 232 | record-decl) | |
| 233 | (%record-decl-hidden record-decl)))) | |
| 234 | (set-needs-parse) | |
| 235 | (set-needs-rule) | |
| 236 | rsort)) | |
| 237 | ||
| 238 | ;;;----------------------------------------------------------------------------- | |
| 239 | ;;; DECLARE-CLASS | |
| 240 | ;;; | |
| 241 | (defun declare-class (class-decl) | |
| 242 | (I-miss-current-module declare-class) | |
| 243 | (include-BOOL) | |
| 244 | (include-OBJECT) | |
| 245 | (let ((csort (declare-class-in-module *current-module* | |
| 246 | (%class-decl-name class-decl) | |
| 247 | (%class-decl-supers class-decl) | |
| 248 | (%class-decl-attributes class-decl) | |
| 249 | (%class-decl-hidden class-decl)))) | |
| 250 | (set-needs-parse) | |
| 251 | (set-needs-rule) | |
| 252 | csort)) | |
| 253 | ||
| 254 | ;;;============================================================================= | |
| 255 | ;;; OPERATOR, OPERATOR ATTRIBUTES | |
| 221 | ;;;============================================================================= | |
| 222 | ;;; OPERATOR, OPERATOR ATTRIBUTES | |
| 256 | 223 | ;;;============================================================================= |
| 257 | 224 | |
| 258 | 225 | ;;; FIND-QUAL-OPERATORs : OpRef -> List[OpInfo] |
| 259 | 226 | ;;; |
| 260 | 227 | (defun find-qual-operators (opref &optional mod (type nil)) |
| 261 | 228 | (let ((name (%opref-name opref)) |
| 262 | (num-args (%opref-num-args opref)) | |
| 263 | (module (%opref-module opref))) | |
| 229 | (num-args (%opref-num-args opref)) | |
| 230 | (module (%opref-module opref))) | |
| 264 | 231 | (if module |
| 265 | (let ((modval (eval-modexp module))) | |
| 266 | (if (module-p modval) | |
| 267 | (find-all-qual-operators-in modval name num-args type) | |
| 268 | (with-output-chaos-error ('no-such-module) | |
| 269 | (princ "resolving operator reference ") | |
| 270 | (print-ast opref) | |
| 271 | (print-next) | |
| 272 | (princ "no such module ") | |
| 273 | (print-modexp module) | |
| 274 | ))) | |
| 232 | (let ((modval (eval-modexp module))) | |
| 233 | (if (module-p modval) | |
| 234 | (find-all-qual-operators-in modval name num-args type) | |
| 235 | (with-output-chaos-error ('no-such-module) | |
| 236 | (princ "resolving operator reference ") | |
| 237 | (print-ast opref) | |
| 238 | (print-next) | |
| 239 | (princ "no such module ") | |
| 240 | (print-modexp module) | |
| 241 | ))) | |
| 275 | 242 | (if mod |
| 276 | (find-all-qual-operators-in mod name num-args type) | |
| 277 | (progn | |
| 278 | (I-miss-current-module find-qual-operators) | |
| 279 | (find-all-qual-operators-in *current-module* name num-args type)))))) | |
| 243 | (find-all-qual-operators-in mod name num-args type) | |
| 244 | (progn | |
| 245 | (I-miss-current-module find-qual-operators) | |
| 246 | (find-all-qual-operators-in *current-module* name num-args type)))))) | |
| 280 | 247 | |
| 281 | 248 | ;;; DECLARE-OPERATOR opdecl -> method |
| 282 | 249 | ;;; returns method if success, otherwise nil. |
| 285 | 252 | (I-miss-current-module declare-operator) |
| 286 | 253 | (include-BOOL) |
| 287 | 254 | (let* ((attr (%op-decl-attribute op-decl)) |
| 288 | (memo (%opattrs-memo attr) ;(if (and *memo-rewrite* *always-memo*) | |
| 289 | ; t | |
| 290 | ; (%opattrs-memo attr)) | |
| 291 | ) | |
| 292 | (theory (%opattrs-theory attr)) | |
| 293 | (assoc (%opattrs-assoc attr)) | |
| 294 | (prec (%opattrs-prec attr)) | |
| 295 | (strat (%opattrs-strat attr)) | |
| 296 | (constr (%opattrs-constr attr)) | |
| 297 | (coherent (%opattrs-coherent attr)) | |
| 298 | (meta-demod (%opattrs-meta-demod attr))) | |
| 255 | (memo (%opattrs-memo attr) ;(if (and *memo-rewrite* *always-memo*) | |
| 256 | ; t | |
| 257 | ; (%opattrs-memo attr)) | |
| 258 | ) | |
| 259 | (theory (%opattrs-theory attr)) | |
| 260 | (assoc (%opattrs-assoc attr)) | |
| 261 | (prec (%opattrs-prec attr)) | |
| 262 | (strat (%opattrs-strat attr)) | |
| 263 | (constr (%opattrs-constr attr)) | |
| 264 | (coherent (%opattrs-coherent attr)) | |
| 265 | (meta-demod (%opattrs-meta-demod attr))) | |
| 299 | 266 | (multiple-value-bind (op meth delayed) |
| 300 | (declare-operator-in-module (%op-decl-name op-decl) | |
| 301 | (%op-decl-arity op-decl) | |
| 302 | (%op-decl-coarity op-decl) | |
| 303 | *current-module* | |
| 304 | constr | |
| 305 | (%op-decl-hidden op-decl) | |
| 306 | coherent | |
| 307 | error-operator | |
| 308 | ) | |
| 267 | (declare-operator-in-module (%op-decl-name op-decl) | |
| 268 | (%op-decl-arity op-decl) | |
| 269 | (%op-decl-coarity op-decl) | |
| 270 | *current-module* | |
| 271 | constr | |
| 272 | (%op-decl-hidden op-decl) | |
| 273 | coherent | |
| 274 | error-operator | |
| 275 | ) | |
| 309 | 276 | (when delayed |
| 310 | (push op-decl (module-error-op-decl *current-module*)) | |
| 311 | (mark-need-parsing-preparation *current-module*) | |
| 312 | (return-from declare-operator t)) | |
| 277 | (push op-decl (module-error-op-decl *current-module*)) | |
| 278 | (mark-need-parsing-preparation *current-module*) | |
| 279 | (return-from declare-operator t)) | |
| 313 | 280 | ;; |
| 314 | 281 | (if (and op meth) |
| 315 | (progn | |
| 316 | ;; memo attribute | |
| 317 | (when memo | |
| 318 | (declare-method-memo-attr meth memo) | |
| 319 | ) | |
| 320 | ;; meta-demod predicate | |
| 321 | (when meta-demod | |
| 322 | (declare-method-meta-demod-attr meth meta-demod)) | |
| 323 | ;; | |
| 324 | (if theory | |
| 325 | (declare-method-theory meth theory) | |
| 326 | (progn | |
| 327 | (setf (method-theory meth *current-opinfo-table*) | |
| 328 | *the-empty-theory*) | |
| 329 | (compute-method-theory-info-for-matching meth | |
| 330 | *current-opinfo-table*) | |
| 331 | )) | |
| 332 | (when assoc | |
| 333 | (if (eq (method-module meth) | |
| 334 | *current-module*) | |
| 335 | (declare-method-associativity meth assoc) | |
| 336 | (with-output-chaos-warning () | |
| 337 | (princ "you cannot alter associativity of") | |
| 338 | (print-next) | |
| 339 | (princ "operator ") | |
| 340 | (print-chaos-object meth) | |
| 341 | (print-next) | |
| 342 | (princ "of module ") | |
| 343 | (print-simple-mod-name (method-module meth)) | |
| 344 | (print-next) | |
| 345 | (princ "ignoring..")))) | |
| 346 | (when prec | |
| 347 | (if (eq (method-module meth) *current-module*) | |
| 348 | (declare-method-precedence meth prec) | |
| 349 | (with-output-chaos-warning () | |
| 350 | (princ "you cannot alter precedence of") | |
| 351 | (print-next) | |
| 352 | (princ "operator ") | |
| 353 | (print-chaos-object meth) | |
| 354 | (print-next) | |
| 355 | (princ "of module ") | |
| 356 | (print-simple-mod-name (method-module meth)) | |
| 357 | (print-next) | |
| 358 | (princ "ignoring..")))) | |
| 359 | (when strat | |
| 360 | (if (eq (method-module meth) *current-module*) | |
| 361 | (declare-method-strategy meth strat) | |
| 362 | (with-output-chaos-warning () | |
| 363 | (princ "you cannot alter strategy of") | |
| 364 | (print-next) | |
| 365 | (princ "operator ") | |
| 366 | (print-chaos-object meth) | |
| 367 | (print-next) | |
| 368 | (princ "of module ") | |
| 369 | (print-simple-mod-name (method-module meth)) | |
| 370 | (print-next) | |
| 371 | (princ "ignoring..")))) | |
| 372 | ;; (when constr (declare-method-constr meth constr)) | |
| 373 | ;; (when coherent (declare-method-coherent meth coherent)) | |
| 374 | (set-needs-parse) | |
| 375 | (set-needs-rule) | |
| 376 | meth) | |
| 377 | nil)))) | |
| 378 | ||
| 379 | ;;; DECLARE-OPERATOR-ATTRIBUTES : decl -> operator | |
| 380 | ;;; returns operator if success, otherwise nil. | |
| 381 | ;;; | |
| 382 | #|| | |
| 383 | (defun declare-operator-attributes (decl) | |
| 384 | (I-miss-current-module declare-operator-attributes) | |
| 385 | ;; *NOTE* qualifier in opref is ignored, is it OK? | |
| 386 | (let ((name (%opref-name (%opattr-decl-opref decl))) | |
| 387 | (num-args (%opref-num-args (%opattr-decl-opref decl))) | |
| 388 | (attr (%opattr-decl-attribute decl))) | |
| 389 | (let ((opinfo (find-qual-operator-in *current-module* name num-args))) | |
| 390 | (unless opinfo | |
| 391 | (with-output-chaos-error ('operator-not-found) | |
| 392 | (format t "declaring attributes, could not found unique operator ~a." | |
| 393 | name) | |
| 394 | )) | |
| 395 | (let ((op (opinfo-operator opinfo)) | |
| 396 | (memo (%opattrs-memo attr)) | |
| 397 | (theory (%opattrs-theory attr)) | |
| 398 | (assoc (%opattrs-assoc attr)) | |
| 399 | (prec (%opattrs-prec attr)) | |
| 400 | (strat (%opattrs-strat attr))) | |
| 401 | ;; (when memo (declare-operator-memo-attr op memo)) | |
| 402 | (when memo | |
| 403 | (with-output-chaos-warning () | |
| 404 | (format t "memo attribute is now obsolate."))) | |
| 405 | (when theory (declare-operator-theory op theory)) | |
| 406 | (when assoc (declare-operator-associativity op assoc)) | |
| 407 | (when prec (declare-operator-precedence op prec)) | |
| 408 | (when strat (declare-operator-strategy op strat)) | |
| 409 | (set-needs-parse) | |
| 410 | (set-needs-rule) | |
| 411 | ;; save the declaration form. | |
| 412 | (push decl (module-opattrs *current-module*)) | |
| 413 | op)))) | |
| 414 | ||# | |
| 415 | ||
| 416 | ;;;============================================================================= | |
| 417 | ;;; AXIOMS, VARIABLES | |
| 282 | (progn | |
| 283 | ;; memo attribute | |
| 284 | (when memo | |
| 285 | (declare-method-memo-attr meth memo) | |
| 286 | ) | |
| 287 | ;; meta-demod predicate | |
| 288 | (when meta-demod | |
| 289 | (declare-method-meta-demod-attr meth meta-demod)) | |
| 290 | ;; | |
| 291 | (if theory | |
| 292 | (declare-method-theory meth theory) | |
| 293 | (progn | |
| 294 | (setf (method-theory meth *current-opinfo-table*) | |
| 295 | *the-empty-theory*) | |
| 296 | (compute-method-theory-info-for-matching meth | |
| 297 | *current-opinfo-table*) | |
| 298 | )) | |
| 299 | (when assoc | |
| 300 | (if (eq (method-module meth) | |
| 301 | *current-module*) | |
| 302 | (declare-method-associativity meth assoc) | |
| 303 | (with-output-chaos-warning () | |
| 304 | (princ "you cannot alter associativity of") | |
| 305 | (print-next) | |
| 306 | (princ "operator ") | |
| 307 | (print-chaos-object meth) | |
| 308 | (print-next) | |
| 309 | (princ "of module ") | |
| 310 | (print-simple-mod-name (method-module meth)) | |
| 311 | (print-next) | |
| 312 | (princ "ignoring..")))) | |
| 313 | (when prec | |
| 314 | (if (eq (method-module meth) *current-module*) | |
| 315 | (declare-method-precedence meth prec) | |
| 316 | (with-output-chaos-warning () | |
| 317 | (princ "you cannot alter precedence of") | |
| 318 | (print-next) | |
| 319 | (princ "operator ") | |
| 320 | (print-chaos-object meth) | |
| 321 | (print-next) | |
| 322 | (princ "of module ") | |
| 323 | (print-simple-mod-name (method-module meth)) | |
| 324 | (print-next) | |
| 325 | (princ "ignoring..")))) | |
| 326 | (when strat | |
| 327 | (if (eq (method-module meth) *current-module*) | |
| 328 | (declare-method-strategy meth strat) | |
| 329 | (with-output-chaos-warning () | |
| 330 | (princ "you cannot alter strategy of") | |
| 331 | (print-next) | |
| 332 | (princ "operator ") | |
| 333 | (print-chaos-object meth) | |
| 334 | (print-next) | |
| 335 | (princ "of module ") | |
| 336 | (print-simple-mod-name (method-module meth)) | |
| 337 | (print-next) | |
| 338 | (princ "ignoring..")))) | |
| 339 | ;; (when constr (declare-method-constr meth constr)) | |
| 340 | ;; (when coherent (declare-method-coherent meth coherent)) | |
| 341 | (set-needs-parse) | |
| 342 | (set-needs-rule) | |
| 343 | meth) | |
| 344 | nil)))) | |
| 345 | ||
| 346 | ;;;============================================================================= | |
| 347 | ;;; AXIOMS, VARIABLES | |
| 418 | 348 | ;;;============================================================================= |
| 419 | 349 | |
| 420 | 350 | ;;;----------------------------------------------------------------------------- |
| 426 | 356 | ;; (set-needs-parse) ; too early to set the flag. |
| 427 | 357 | (include-BOOL) |
| 428 | 358 | (let ((sort (find-sort-in *current-module* (%var-decl-sort ast))) |
| 429 | (res nil)) | |
| 359 | (res nil)) | |
| 430 | 360 | (unless sort |
| 431 | 361 | (if (may-be-error-sort-ref? (%var-decl-sort ast)) |
| 432 | (progn | |
| 433 | ;; may be declaration of variable of error sorts. | |
| 434 | (push ast (module-error-var-decl *current-module*)) | |
| 435 | (return-from declare-variable t)) | |
| 436 | ;; | |
| 437 | (with-output-chaos-error ('no-such-sort) | |
| 438 | (format t "declaring variable(s)~{~^ ~a~^,~}," | |
| 439 | (%var-decl-names ast)) | |
| 440 | ;; (print-ast (%var-decl-sort ast)) | |
| 441 | (print-next) | |
| 442 | (format t "no such sort: ~a" (%sort-ref-name (%var-decl-sort ast))) | |
| 443 | ))) | |
| 362 | (progn | |
| 363 | ;; may be declaration of variable of error sorts. | |
| 364 | (push ast (module-error-var-decl *current-module*)) | |
| 365 | (return-from declare-variable t)) | |
| 366 | ;; | |
| 367 | (with-output-chaos-error ('no-such-sort) | |
| 368 | (format t "declaring variable(s)~{~^ ~a~^,~}," | |
| 369 | (%var-decl-names ast)) | |
| 370 | ;; (print-ast (%var-decl-sort ast)) | |
| 371 | (print-next) | |
| 372 | (format t "no such sort: ~a" (%sort-ref-name (%var-decl-sort ast))) | |
| 373 | ))) | |
| 444 | 374 | (dolist (name (%var-decl-names ast)) |
| 445 | 375 | (push (declare-variable-in-module name sort *current-module*) res)) |
| 446 | 376 | ;; - patch, now we are safe to set the flag. |
| 453 | 383 | ;; (set-needs-parse) ; too early to set the flag. |
| 454 | 384 | (include-BOOL) |
| 455 | 385 | (let ((sort (find-sort-in *current-module* (%pvar-decl-sort ast))) |
| 456 | (res nil)) | |
| 386 | (res nil)) | |
| 457 | 387 | (unless sort |
| 458 | 388 | (if (may-be-error-sort-ref? (%pvar-decl-sort ast)) |
| 459 | (progn | |
| 460 | ;; may be declaration of variable of error sorts. | |
| 461 | (push ast (module-error-var-decl *current-module*)) | |
| 462 | (return-from declare-pvariable t)) | |
| 463 | ;; | |
| 464 | (with-output-chaos-error ('no-such-sort) | |
| 465 | (format t "declaring pseud variable(s)~{~^ ~a~^,~}, no such sort." | |
| 466 | (%pvar-decl-names ast)) | |
| 467 | (print-ast (%pvar-decl-sort ast)) | |
| 468 | ))) | |
| 389 | (progn | |
| 390 | ;; may be declaration of variable of error sorts. | |
| 391 | (push ast (module-error-var-decl *current-module*)) | |
| 392 | (return-from declare-pvariable t)) | |
| 393 | ;; | |
| 394 | (with-output-chaos-error ('no-such-sort) | |
| 395 | (format t "declaring pseud variable(s)~{~^ ~a~^,~}, no such sort." | |
| 396 | (%pvar-decl-names ast)) | |
| 397 | (print-ast (%pvar-decl-sort ast)) | |
| 398 | ))) | |
| 469 | 399 | (dolist (name (%pvar-decl-names ast)) |
| 470 | 400 | (push (declare-pvariable-in-module name sort *current-module*) res)) |
| 471 | 401 | ;; - patch, now we are safe to set the flag. |
| 492 | 422 | (I-miss-current-module parse-axiom-declaration) |
| 493 | 423 | ;; |
| 494 | 424 | (let* ((sort *cosmos*) |
| 495 | (*fill-rc-attribute* t) | |
| 496 | (*parse-variables* nil) | |
| 497 | (*parse-lhs-attr-vars* nil) | |
| 498 | (*lhs-attrid-vars* nil) | |
| 499 | (lhs (%axiom-decl-lhs ast)) | |
| 500 | (rhs (%axiom-decl-rhs ast)) | |
| 501 | (cond-part (%axiom-decl-cond ast)) | |
| 502 | (labels (%axiom-decl-labels ast)) | |
| 503 | (type (%axiom-decl-type ast)) | |
| 504 | (behavioural (%axiom-decl-behavioural ast)) | |
| 505 | (the-axiom nil) | |
| 506 | (meta-rule nil)) | |
| 425 | (*fill-rc-attribute* t) | |
| 426 | (*parse-variables* nil) | |
| 427 | (*parse-lhs-attr-vars* nil) | |
| 428 | (*lhs-attrid-vars* nil) | |
| 429 | (lhs (%axiom-decl-lhs ast)) | |
| 430 | (rhs (%axiom-decl-rhs ast)) | |
| 431 | (cond-part (%axiom-decl-cond ast)) | |
| 432 | (labels (%axiom-decl-labels ast)) | |
| 433 | (type (%axiom-decl-type ast)) | |
| 434 | (behavioural (%axiom-decl-behavioural ast)) | |
| 435 | (the-axiom nil) | |
| 436 | (meta-rule nil)) | |
| 507 | 437 | ;; |
| 508 | 438 | (dolist (ml .special-meta-rule-labels.) |
| 509 | 439 | (when (member ml labels) |
| 510 | (when meta-rule | |
| 511 | (with-output-chaos-error ('invalid-meta-rule) | |
| 512 | (format t "You cannot specify multiple :m-and, :m-or, .e.t.c at once!"))) | |
| 513 | (setq meta-rule ml))) | |
| 440 | (when meta-rule | |
| 441 | (with-output-chaos-error ('invalid-meta-rule) | |
| 442 | (format t "You cannot specify multiple :m-and, :m-or, .e.t.c at once!"))) | |
| 443 | (setq meta-rule ml))) | |
| 514 | 444 | ;; |
| 515 | 445 | (when (eq type :rule) |
| 516 | 446 | (include-rwl *current-module*)) |
| 517 | 447 | (prepare-for-parsing *current-module*) |
| 518 | 448 | ;; |
| 519 | 449 | (cond ((or (is-lisp-form-token-sequence rhs) |
| 520 | (is-chaos-value-token-sequence rhs)) | |
| 521 | ;; | |
| 522 | (when meta-rule | |
| 523 | (with-output-chaos-error ('invalid-special-rule) | |
| 524 | (format t "Invalid special rule ~s for built-in axiom." meta-rule))) | |
| 525 | ;; aka builtin rule. | |
| 526 | (let* ((parsed-lhs (simple-parse *current-module* lhs sort)) | |
| 527 | (parsed-rhs (simple-parse *current-module* rhs sort)) | |
| 528 | (parsed-cnd (if cond-part | |
| 529 | (simple-parse *current-module* cond-part sort) | |
| 530 | *bool-true*)) | |
| 531 | (error-p nil)) | |
| 532 | (setf sort (term-sort parsed-lhs)) | |
| 533 | (when (and parsed-cnd (term-ill-defined parsed-cnd)) | |
| 534 | (with-output-simple-msg () | |
| 535 | (princ "[Error] no parse for condition part of the axiom.")) | |
| 536 | (setf error-p t)) | |
| 537 | ;; | |
| 538 | (when (term-is-builtin-constant? parsed-lhs) | |
| 539 | (with-output-chaos-error ('invlaid-lhs) | |
| 540 | (format t "sole built-in constant on LHS is not allowed, sorry!"))) | |
| 541 | ;; | |
| 542 | (if (or (term-ill-defined parsed-lhs) | |
| 543 | (null sort)) | |
| 544 | (with-output-simple-msg () | |
| 545 | (princ "[Error] no parse for LHS of the axiom (ignored): ") | |
| 546 | nil) | |
| 547 | (if (not error-p) | |
| 548 | (let ((canon (canonicalize-variables (list parsed-lhs parsed-rhs parsed-cnd) *current-module*))) | |
| 549 | (unless (sort<= (term-sort (third canon)) *condition-sort* *current-sort-order*) | |
| 550 | (with-output-chaos-error ('invalid-condition) | |
| 551 | (format t "Illegal condition part of conditional axiom:") | |
| 552 | (print-next) | |
| 553 | (term-print-with-sort (third canon)))) | |
| 554 | (setq the-axiom | |
| 555 | (make-rule :lhs (first canon) | |
| 556 | :rhs (second canon) | |
| 557 | :condition (third canon) | |
| 558 | :labels labels | |
| 559 | :behavioural behavioural | |
| 560 | :type type))) | |
| 561 | (chaos-error 'invalid-axiom-decl) )))) | |
| 562 | ||
| 563 | ;; normal rule | |
| 564 | (t (let* ((parses-lhs (let ((*parsing-axiom-lhs* t)) | |
| 565 | (parser-parses *current-module* lhs sort))) | |
| 566 | (parses-rhs (parser-parses *current-module* rhs sort)) | |
| 567 | (parsed-cnd (if cond-part | |
| 568 | (simple-parse *current-module* | |
| 569 | cond-part | |
| 570 | sort) | |
| 571 | *bool-true*)) | |
| 572 | (error-p nil)) | |
| 573 | ;; | |
| 574 | ;; check condition part. | |
| 575 | ;; | |
| 576 | (when (and cond-part (term-ill-defined parsed-cnd)) | |
| 577 | (with-output-simple-msg () | |
| 578 | (princ "[Error] no parse for axiom condition")) | |
| 579 | (setf error-p t)) | |
| 580 | ||
| 581 | ;; find apropreate pair of LHS & RHS. | |
| 582 | (let ((res (parser-find-rule-pair | |
| 583 | *current-module* parses-lhs parses-rhs))) | |
| 584 | (if (null res) | |
| 585 | ;; completely no found. | |
| 586 | (with-output-simple-msg () | |
| 587 | (princ "[Error] bad axiom (ignored): ") | |
| 588 | ;; show LHS | |
| 589 | (if (null parses-lhs) | |
| 590 | (format t "~& No possible parse for LHS") | |
| 591 | (progn | |
| 592 | (format t "~&- LHS") | |
| 593 | (dolist (f parses-lhs) | |
| 594 | (print-next) | |
| 595 | (print-term-tree f t)))) | |
| 596 | ;; show RHS | |
| 597 | (if (null parses-rhs) | |
| 598 | (format t "~& No possible parse for RHS") | |
| 599 | (progn | |
| 600 | (format t "~&- RHS") | |
| 601 | (dolist (f parses-rhs) | |
| 602 | (print-next) | |
| 603 | (print-term-tree f t) | |
| 604 | ))) | |
| 605 | (chaos-error 'invalid-axiom-decl)) | |
| 606 | ;; | |
| 607 | (progn | |
| 608 | (unless (null (cdr res)) | |
| 609 | (with-output-chaos-warning () | |
| 610 | (princ "axiom is ambiguous: ") (print-next) | |
| 611 | (unless (null (cdr parses-lhs)) | |
| 612 | (princ "-- More than one parse for the LHS") | |
| 613 | (print-next) | |
| 614 | (format t "form : ~a" lhs) | |
| 615 | (print-next) | |
| 616 | (format t "trees:") | |
| 617 | (parse-show-diff parses-lhs) | |
| 618 | (format t "~&...adopting [1]...")) | |
| 619 | (unless (null (cdr parses-rhs)) | |
| 620 | (princ "-- More than one parse for the RHS") | |
| 621 | (print-next) | |
| 622 | (format t "form : ~a" rhs) | |
| 623 | (print-next) | |
| 624 | (format t "trees:") | |
| 625 | (parse-show-diff parses-rhs) | |
| 626 | (format t "~&...adopting [1]...")))) | |
| 627 | (if (not error-p) | |
| 628 | (let ((lhs-result (car (car res))) | |
| 629 | (rhs-result (parse-convert (cadr (car res))))) | |
| 630 | ||
| 631 | (when (term-is-builtin-constant? lhs-result) | |
| 632 | (with-output-chaos-error ('invlaid-lhs) | |
| 633 | (format t "sole built-in constant on LHS is not allowed, sorry!") | |
| 634 | (format t "~& - LHS :") | |
| 635 | (term-print-with-sort lhs-result) | |
| 636 | (print-ast ast) | |
| 637 | )) | |
| 638 | ;; | |
| 639 | (when meta-rule | |
| 640 | ;; lhs must be associative | |
| 641 | (unless (eq *bool-true* parsed-cnd) | |
| 642 | (with-output-chaos-error ('invalid-cond) | |
| 643 | (format t "Sorry, but now ~s can only be specified for non-conditional axioms." meta-rule))) | |
| 644 | (unless (is-in-same-connected-component *bool-sort* | |
| 645 | (term-sort rhs-result) | |
| 646 | *current-sort-order*) | |
| 647 | (with-output-chaos-error ('invalid-rhs) | |
| 648 | (format t "RHS must be a term of sort Bool for ~s axiom." meta-rule)))) | |
| 649 | ;; | |
| 650 | (let ((canon (canonicalize-variables (list lhs-result rhs-result parsed-cnd) *current-module*))) | |
| 651 | (unless (sort<= (term-sort (third canon)) *condition-sort* *current-sort-order*) | |
| 652 | (with-output-chaos-error ('invalid-condition) | |
| 653 | (format t "Illegal condition part of conditional axiom:") | |
| 654 | (print-next) | |
| 655 | (term-print-with-sort (third canon)))) | |
| 656 | ;; | |
| 657 | (setq the-axiom | |
| 658 | (make-rule :lhs (first canon) | |
| 659 | :rhs (second canon) | |
| 660 | :condition (third canon) | |
| 661 | :behavioural behavioural | |
| 662 | :labels labels | |
| 663 | :type type | |
| 664 | :meta-and-or meta-rule))) | |
| 665 | ;; | |
| 666 | (when *chaos-verbose* | |
| 667 | (when behavioural | |
| 668 | (unless (and (term-can-be-in-beh-axiom? | |
| 669 | lhs-result) | |
| 670 | (term-can-be-in-beh-axiom? | |
| 671 | rhs-result)) | |
| 672 | (with-output-chaos-warning () | |
| 673 | (format t "non-behavioural operation on hidden sorts appearing in the behavioural axiom:") | |
| 674 | (with-in-module (*current-module*) | |
| 675 | (print-next) | |
| 676 | (print-chaos-object the-axiom))))))) | |
| 677 | (chaos-error 'invalid-axiom-decl)))))))) | |
| 450 | (is-chaos-value-token-sequence rhs)) | |
| 451 | ;; | |
| 452 | (when meta-rule | |
| 453 | (with-output-chaos-error ('invalid-special-rule) | |
| 454 | (format t "Invalid special rule ~s for built-in axiom." meta-rule))) | |
| 455 | ;; aka builtin rule. | |
| 456 | (let* ((parsed-lhs (simple-parse *current-module* lhs sort)) | |
| 457 | (parsed-rhs (simple-parse *current-module* rhs sort)) | |
| 458 | (parsed-cnd (if cond-part | |
| 459 | (simple-parse *current-module* cond-part sort) | |
| 460 | *bool-true*)) | |
| 461 | (error-p nil)) | |
| 462 | (setf sort (term-sort parsed-lhs)) | |
| 463 | (when (and parsed-cnd (term-ill-defined parsed-cnd)) | |
| 464 | (with-output-simple-msg () | |
| 465 | (princ "[Error] no parse for condition part of the axiom.")) | |
| 466 | (setf error-p t)) | |
| 467 | ;; | |
| 468 | ;; | |
| 469 | (if (or (term-ill-defined parsed-lhs) | |
| 470 | (null sort)) | |
| 471 | (with-output-chaos-error ('invalid-lhs) | |
| 472 | (princ "no parse for LHS of the axiom (ignored): ")) | |
| 473 | (if (not error-p) | |
| 474 | (let ((canon (canonicalize-variables (list parsed-lhs parsed-rhs parsed-cnd) *current-module*))) | |
| 475 | (when (term-is-builtin-constant? parsed-lhs) | |
| 476 | (with-output-chaos-error ('bad-axiom) | |
| 477 | (format t "System does not support sole built-in constant on LHS, sorry.") | |
| 478 | (format t "~&-- LHS : ") | |
| 479 | (term-print-with-sort parsed-lhs))) | |
| 480 | (unless (sort<= (term-sort (third canon)) *condition-sort* *current-sort-order*) | |
| 481 | (with-output-chaos-error ('invalid-condition) | |
| 482 | (format t "Illegal condition part of conditional axiom:") | |
| 483 | (print-next) | |
| 484 | (term-print-with-sort (third canon)))) | |
| 485 | (setq the-axiom | |
| 486 | (make-rule :lhs (first canon) | |
| 487 | :rhs (second canon) | |
| 488 | :condition (third canon) | |
| 489 | :labels labels | |
| 490 | :behavioural behavioural | |
| 491 | :type type))) | |
| 492 | (chaos-error 'invalid-axiom-decl) )))) | |
| 493 | ||
| 494 | ;; normal rule | |
| 495 | (t (let* ((parses-lhs (let ((*parsing-axiom-lhs* t)) | |
| 496 | (parser-parses *current-module* lhs sort))) | |
| 497 | (parses-rhs (parser-parses *current-module* rhs sort)) | |
| 498 | (parsed-cnd (if cond-part | |
| 499 | (simple-parse *current-module* | |
| 500 | cond-part | |
| 501 | sort) | |
| 502 | *bool-true*)) | |
| 503 | (error-p nil)) | |
| 504 | ;; | |
| 505 | ;; check condition part. | |
| 506 | ;; | |
| 507 | (when (and cond-part (term-ill-defined parsed-cnd)) | |
| 508 | (with-output-simple-msg () | |
| 509 | (princ "[Error] no parse for axiom condition")) | |
| 510 | (setf error-p t)) | |
| 511 | ||
| 512 | ;; find apropreate pair of LHS & RHS. | |
| 513 | (let ((res (parser-find-rule-pair | |
| 514 | *current-module* parses-lhs parses-rhs))) | |
| 515 | (if (null res) | |
| 516 | ;; completely no found. | |
| 517 | (with-output-simple-msg () | |
| 518 | (princ "[Error] bad axiom (ignored): ") | |
| 519 | ;; show LHS | |
| 520 | (if (null parses-lhs) | |
| 521 | (format t "~& No possible parse for LHS") | |
| 522 | (progn | |
| 523 | (format t "~&- LHS") | |
| 524 | (dolist (f parses-lhs) | |
| 525 | (print-next) | |
| 526 | (print-term-tree f t)))) | |
| 527 | ;; show RHS | |
| 528 | (if (null parses-rhs) | |
| 529 | (format t "~& No possible parse for RHS") | |
| 530 | (progn | |
| 531 | (format t "~&- RHS") | |
| 532 | (dolist (f parses-rhs) | |
| 533 | (print-next) | |
| 534 | (print-term-tree f t)))) | |
| 535 | (chaos-error 'invalid-axiom-decl)) | |
| 536 | ;; | |
| 537 | (progn | |
| 538 | (unless (null (cdr res)) | |
| 539 | (with-output-chaos-warning () | |
| 540 | (princ "axiom is ambiguous: ") (print-next) | |
| 541 | (unless (null (cdr parses-lhs)) | |
| 542 | (princ "-- More than one parse for the LHS") | |
| 543 | (print-next) | |
| 544 | (format t "form : ~a" lhs) | |
| 545 | (print-next) | |
| 546 | (format t "trees:") | |
| 547 | (parse-show-diff parses-lhs) | |
| 548 | (format t "~&...adopting [1]...")) | |
| 549 | (unless (null (cdr parses-rhs)) | |
| 550 | (princ "-- More than one parse for the RHS") | |
| 551 | (print-next) | |
| 552 | (format t "form : ~a" rhs) | |
| 553 | (print-next) | |
| 554 | (format t "trees:") | |
| 555 | (parse-show-diff parses-rhs) | |
| 556 | (format t "~&...adopting [1]...")))) | |
| 557 | (if (not error-p) | |
| 558 | (let ((lhs-result (car (car res))) | |
| 559 | (rhs-result (parse-convert (cadr (car res))))) | |
| 560 | (when (term-is-builtin-constant? lhs-result) | |
| 561 | (with-output-chaos-error ('bad-axiom) | |
| 562 | (format t "System does not support sole built-in constant on LHS, sorry.") | |
| 563 | (format t "~&-- LHS : ") | |
| 564 | (term-print-with-sort lhs-result))) | |
| 565 | (when meta-rule | |
| 566 | ;; lhs must be associative | |
| 567 | (unless (eq *bool-true* parsed-cnd) | |
| 568 | (with-output-chaos-error ('invalid-cond) | |
| 569 | (format t "Sorry, but now ~s can only be specified for non-conditional axioms." meta-rule))) | |
| 570 | (unless (is-in-same-connected-component *bool-sort* | |
| 571 | (term-sort rhs-result) | |
| 572 | *current-sort-order*) | |
| 573 | (with-output-chaos-error ('invalid-rhs) | |
| 574 | (format t "RHS must be a term of sort Bool for ~s axiom." meta-rule)))) | |
| 575 | ;; | |
| 576 | (let ((canon (canonicalize-variables (list lhs-result rhs-result parsed-cnd) *current-module*))) | |
| 577 | (unless (sort<= (term-sort (third canon)) *condition-sort* *current-sort-order*) | |
| 578 | (with-output-chaos-error ('invalid-condition) | |
| 579 | (format t "Illegal condition part of conditional axiom:") | |
| 580 | (print-next) | |
| 581 | (term-print-with-sort (third canon)))) | |
| 582 | ;; | |
| 583 | (setq the-axiom | |
| 584 | (make-rule :lhs (first canon) | |
| 585 | :rhs (second canon) | |
| 586 | :condition (third canon) | |
| 587 | :behavioural behavioural | |
| 588 | :labels labels | |
| 589 | :type type | |
| 590 | :meta-and-or meta-rule))) | |
| 591 | ;; | |
| 592 | (when *chaos-verbose* | |
| 593 | (when behavioural | |
| 594 | (unless (and (term-can-be-in-beh-axiom? | |
| 595 | lhs-result) | |
| 596 | (term-can-be-in-beh-axiom? | |
| 597 | rhs-result)) | |
| 598 | (with-output-chaos-warning () | |
| 599 | (format t "non-behavioural operation on hidden sorts appearing in the behavioural axiom:") | |
| 600 | (with-in-module (*current-module*) | |
| 601 | (print-next) | |
| 602 | (print-chaos-object the-axiom))))))) | |
| 603 | (chaos-error 'invalid-axiom-decl)))))))) | |
| 678 | 604 | ;; check the axiom |
| 679 | 605 | (check-axiom-error-method *current-module* the-axiom t) |
| 680 | 606 | ;; additionaly if condition part contains match-op... |
| 696 | 622 | |
| 697 | 623 | (defun eval-let (ast) |
| 698 | 624 | (let ((sym (%let-sym ast)) |
| 699 | (value (%let-value ast))) | |
| 625 | (value (%let-value ast))) | |
| 700 | 626 | ;; (I-miss-current-module eval-let) |
| 701 | 627 | (unless *current-module* |
| 702 | 628 | (with-output-chaos-error ('no-context) |
| 703 | (princ "no context (current) module is set!"))) | |
| 629 | (princ "no context (current) module is set!"))) | |
| 704 | 630 | ;; |
| 705 | 631 | (with-in-module (*current-module*) |
| 706 | 632 | (prepare-for-parsing *current-module*) |
| 707 | 633 | (let ((*parse-variables* nil)) |
| 708 | (let ((res (simple-parse *current-module* value *cosmos*))) | |
| 709 | (setq res (car (canonicalize-variables (list res) *current-module*))) | |
| 710 | ;; we treate $$term & $$subterm, we must copy for | |
| 711 | ;; avoiding side effect. | |
| 712 | (when (or (equal "$$term" sym) (equal "$$subtem" sym)) | |
| 713 | (setq res (simple-copy-term res))) | |
| 714 | (when (set-bound-value sym res) | |
| 715 | (when (and (at-top-level) (not *chaos-quiet*)) | |
| 716 | (format t "~&-- setting let variable \"~a\" to :" sym) | |
| 717 | (let ((*fancy-print* nil) | |
| 718 | (*print-indent* (+ *print-indent* 4))) | |
| 719 | (print-next) | |
| 720 | (term-print res) | |
| 721 | (print-check 0 3) | |
| 722 | (princ " : ") | |
| 723 | (print-sort-name (term-sort res))))) | |
| 724 | t))))) | |
| 634 | (let ((res (simple-parse *current-module* value *cosmos*))) | |
| 635 | (setq res (car (canonicalize-variables (list res) *current-module*))) | |
| 636 | ;; we treate $$term & $$subterm, we must copy for | |
| 637 | ;; avoiding side effect. | |
| 638 | (when (or (equal "$$term" sym) (equal "$$subtem" sym)) | |
| 639 | (setq res (simple-copy-term res))) | |
| 640 | (when (set-bound-value sym res) | |
| 641 | (when (and (at-top-level) (not *chaos-quiet*)) | |
| 642 | (format t "~%-- setting let variable \"~a\" to :" sym) | |
| 643 | (let ((*fancy-print* nil) | |
| 644 | (*print-indent* (+ *print-indent* 4))) | |
| 645 | (print-next) | |
| 646 | (term-print res) | |
| 647 | (print-check 0 3) | |
| 648 | (princ " : ") | |
| 649 | (print-sort-name (term-sort res))))) | |
| 650 | t))))) | |
| 725 | 651 | |
| 726 | 652 | ;;;============================================================================= |
| 727 | 653 | ;;; MACRO |
| 729 | 655 | |
| 730 | 656 | (defun eval-macro (ast) |
| 731 | 657 | (let ((pre-lhs (%macro-lhs ast)) |
| 732 | (pre-rhs (%macro-rhs ast)) | |
| 733 | lhs | |
| 734 | rhs | |
| 735 | macro) | |
| 658 | (pre-rhs (%macro-rhs ast)) | |
| 659 | lhs | |
| 660 | rhs | |
| 661 | macro) | |
| 736 | 662 | (I-miss-current-module eval-macro) |
| 737 | 663 | (prepare-for-parsing *current-module*) |
| 738 | 664 | (let ((*parse-variables* nil) |
| 739 | (*macroexpand* nil)) | |
| 665 | (*macroexpand* nil)) | |
| 740 | 666 | (setq lhs (simple-parse *current-module* pre-lhs *cosmos*)) |
| 741 | 667 | (when (term-ill-defined lhs) |
| 742 | (with-output-chaos-error ('invalid-macro-lhs) | |
| 743 | (format t "no parse for LHS of the macro declaration: ") | |
| 744 | (print-chaos-object ast))) | |
| 668 | (with-output-chaos-error ('invalid-macro-lhs) | |
| 669 | (format t "no parse for LHS of the macro declaration: ") | |
| 670 | (print-chaos-object ast))) | |
| 745 | 671 | (setq rhs (simple-parse *current-module* pre-rhs *cosmos*)) |
| 746 | 672 | (when (term-ill-defined rhs) |
| 747 | (with-output-chaos-error ('invalid-macro-rhs) | |
| 748 | (format t "no parse for RHS of the macro declaration: ") | |
| 749 | (print-chaos-object ast))) | |
| 673 | (with-output-chaos-error ('invalid-macro-rhs) | |
| 674 | (format t "no parse for RHS of the macro declaration: ") | |
| 675 | (print-chaos-object ast))) | |
| 750 | 676 | (unless (term-is-application-form? lhs) |
| 751 | (with-output-chaos-error ('invalid-macro) | |
| 752 | (format t "macro can only be defined for normal application form.~%") | |
| 753 | (print-chaos-object ast))) | |
| 677 | (with-output-chaos-error ('invalid-macro) | |
| 678 | (format t "macro can only be defined for normal application form.~%") | |
| 679 | (print-chaos-object ast))) | |
| 754 | 680 | (unless (theory-info-empty-for-matching |
| 755 | (method-theory-info-for-matching | |
| 756 | (term-head lhs))) | |
| 757 | (with-output-chaos-error ('invalid-macro) | |
| 758 | (format t "macro can only be defined for operators with no equational theory.~%") | |
| 759 | (print-chaos-object ast))) | |
| 681 | (method-theory-info-for-matching | |
| 682 | (term-head lhs))) | |
| 683 | (with-output-chaos-error ('invalid-macro) | |
| 684 | (format t "macro can only be defined for operators with no equational theory.~%") | |
| 685 | (print-chaos-object ast))) | |
| 760 | 686 | ;; LHS & RHS must be of the same sort -- too rigid? |
| 761 | 687 | (unless (is-in-same-connected-component (term-sort lhs) |
| 762 | (term-sort rhs) | |
| 763 | *current-sort-order*) | |
| 764 | (with-output-chaos-error ('invalid-macro) | |
| 765 | (format t "sort of LHS & RHS of the maro declaration must be the same.") | |
| 766 | (terpri) | |
| 767 | (print-chaos-object ast))) | |
| 688 | (term-sort rhs) | |
| 689 | *current-sort-order*) | |
| 690 | (with-output-chaos-error ('invalid-macro) | |
| 691 | (format t "sort of LHS & RHS of the maro declaration must be the same.") | |
| 692 | (terpri) | |
| 693 | (print-chaos-object ast))) | |
| 768 | 694 | ;; |
| 769 | 695 | ;; check in |
| 770 | 696 | (let ((canon (canonicalize-variables (list lhs rhs) *current-module*))) |
| 771 | (setq macro (make-macro :lhs (first canon) :rhs (second canon))) | |
| 772 | (add-macro-to-module *current-module* macro)) | |
| 697 | (setq macro (make-macro :lhs (first canon) :rhs (second canon))) | |
| 698 | (add-macro-to-module *current-module* macro)) | |
| 773 | 699 | ;; set module status |
| 774 | 700 | (set-needs-parse) |
| 775 | 701 | macro))) |
| 776 | 702 | |
| 777 | 703 | ;;;============================================================================= |
| 778 | ;;; MODULE | |
| 704 | ;;; MODULE | |
| 779 | 705 | ;;;============================================================================= |
| 780 | 706 | |
| 781 | 707 | ;;; DECLARE-MODULE : module-declaration-form -> module |
| 782 | 708 | ;;; |
| 783 | 709 | (defun declare-module (decl) |
| 784 | ;; need not *current-module* | |
| 785 | (let ((mod nil) ; will bound created module. | |
| 786 | (name (%module-decl-name decl)) | |
| 787 | (kind (%module-decl-kind decl)) | |
| 788 | (type (%module-decl-type decl)) | |
| 789 | (body (%module-decl-elements decl)) | |
| 790 | (*allow-$$term* nil) | |
| 791 | (*modexp-eval-table* nil) | |
| 792 | (auto-context? *auto-context-change*) | |
| 793 | (*auto-context-change* nil)) | |
| 710 | (let ((mod nil) ; will bound created module. | |
| 711 | (name (%module-decl-name decl)) | |
| 712 | (kind (%module-decl-kind decl)) | |
| 713 | (type (%module-decl-type decl)) | |
| 714 | (body (%module-decl-elements decl)) | |
| 715 | (*allow-$$term* nil) | |
| 716 | (*modexp-eval-table* nil) | |
| 717 | (auto-context? *auto-context-change*) | |
| 718 | (*auto-context-change* nil)) | |
| 794 | 719 | (declare (special *modexp-eval-table* |
| 795 | *auto-context-change*)) | |
| 720 | *auto-context-change*)) | |
| 796 | 721 | (unless *chaos-quiet* |
| 797 | 722 | (if (equal name "%") |
| 798 | (with-output-msg () | |
| 799 | (princ "opening module ") | |
| 800 | (print-mod-name *open-module*) | |
| 801 | (force-output)) | |
| 802 | (unless (modexp-is-parameter-theory name) | |
| 803 | (format t "~&-- defining ~(~a~) ~a" (case kind | |
| 804 | (:object "module!") | |
| 805 | (:theory "module*") | |
| 806 | (otherwise "module")) | |
| 807 | name) | |
| 808 | (force-output)))) | |
| 723 | (with-output-msg () | |
| 724 | (princ "opening module ") | |
| 725 | (print-mod-name *open-module*) | |
| 726 | (force-output)) | |
| 727 | (unless (modexp-is-parameter-theory name) | |
| 728 | (format t "~%-- defining ~(~a~) ~a" (case kind | |
| 729 | (:object "module!") | |
| 730 | (:theory "module*") | |
| 731 | (otherwise "module")) | |
| 732 | name) | |
| 733 | (force-output)))) | |
| 809 | 734 | ;; |
| 810 | 735 | (let ((modval (eval-modexp name nil nil)) |
| 811 | (recover-same-context nil)) | |
| 736 | (recover-same-context nil)) | |
| 812 | 737 | (unless (or (modexp-is-error modval) |
| 813 | (and (module-p modval) | |
| 814 | (modexp-is-parameter-theory (module-name modval))) | |
| 815 | (equal "%" name) | |
| 816 | (eq '% name) | |
| 817 | (equal " % % " name)) | |
| 818 | ||
| 819 | (unless (modexp-is-parameter-theory name) | |
| 820 | (when (module-is-hard-wired modval) | |
| 821 | (with-output-chaos-error ('invalid-module-decl) | |
| 822 | (format t "You can not redefine system module ~a ." name))) | |
| 823 | (when (module-is-write-protected modval) | |
| 824 | (with-output-chaos-error ('invalid-module-decl) | |
| 825 | (format t "Module ~a is protected!" name))) | |
| 826 | (with-output-chaos-warning () | |
| 827 | (format t "Redefining module ~a " name))) | |
| 828 | ;; | |
| 829 | (propagate-module-change modval) | |
| 830 | ;; | |
| 831 | (when (eq modval *last-module*) | |
| 832 | (setq *last-module* nil) | |
| 833 | (setq recover-same-context t)) | |
| 834 | ||
| 835 | (when (eq modval *memoized-module*) | |
| 836 | (clear-term-memo-table *term-memo-table*)) | |
| 837 | (when (eq modval .memb-last-module.) | |
| 838 | (clear-memb-hash)) | |
| 839 | ;; | |
| 840 | (setq name (module-name modval)) | |
| 841 | (clear-module-instance-db modval) | |
| 842 | (when (eq $$term-context modval) | |
| 843 | (setq $$term nil | |
| 844 | $$term-context nil | |
| 845 | $$subterm nil | |
| 846 | $$action-stack nil | |
| 847 | $$selection-stack nil)) | |
| 848 | ) | |
| 738 | (and (module-p modval) | |
| 739 | (modexp-is-parameter-theory (module-name modval))) | |
| 740 | (equal "%" name) | |
| 741 | (eq '% name) | |
| 742 | (equal " % % " name)) | |
| 743 | ||
| 744 | (unless (modexp-is-parameter-theory name) | |
| 745 | (when (module-is-hard-wired modval) | |
| 746 | (with-output-chaos-error ('invalid-module-decl) | |
| 747 | (format t "You can not redefine system module ~a ." name))) | |
| 748 | (when (module-is-write-protected modval) | |
| 749 | (with-output-chaos-error ('invalid-module-decl) | |
| 750 | (format t "Module ~a is protected!" name))) | |
| 751 | (with-output-chaos-warning () | |
| 752 | (format t "Redefining module ~a " name))) | |
| 753 | ;; | |
| 754 | (propagate-module-change modval) | |
| 755 | ;; | |
| 756 | (when (eq modval (get-context-module t)) | |
| 757 | (reset-context-module) | |
| 758 | (setq recover-same-context t)) | |
| 759 | ||
| 760 | (when (eq modval *memoized-module*) | |
| 761 | (clear-term-memo-table *term-memo-table*)) | |
| 762 | (when (eq modval .memb-last-module.) | |
| 763 | (clear-memb-hash)) | |
| 764 | ;; | |
| 765 | (setq name (module-name modval)) | |
| 766 | (clear-module-instance-db modval) | |
| 767 | (when (eq $$term-context modval) | |
| 768 | (setq $$term nil | |
| 769 | $$term-context nil | |
| 770 | $$subterm nil | |
| 771 | $$action-stack nil | |
| 772 | $$selection-stack nil))) | |
| 849 | 773 | |
| 850 | 774 | ;; process declaration forms. |
| 851 | 775 | (setf mod (create-module name)) |
| 853 | 777 | (setf (module-type mod) type) |
| 854 | 778 | (when *save-definition* (setf (module-decl-form mod) decl)) |
| 855 | 779 | (let ((*top-level-definition-in-progress* |
| 856 | (or *top-level-definition-in-progress* | |
| 857 | mod))) | |
| 858 | ;; construction process is done in the context of `mod'. | |
| 859 | (with-in-module (mod) | |
| 860 | (add-modexp-defn name mod) | |
| 861 | ;; operate on mod by side-effect ---------------- | |
| 862 | ;; EVAL EACH MODULE CONSTRUCTS. | |
| 863 | (dolist (e body) | |
| 864 | (flet ((report-decl-error (&rest ignore) | |
| 865 | (declare (ignore ignore)) | |
| 866 | (unless *chaos-quiet* | |
| 867 | (with-output-msg () | |
| 868 | (format t "failed to evaluate the form:~%") | |
| 869 | (print-ast e) | |
| 870 | (force-output))) | |
| 871 | (chaos-error 'declaration-failed))) | |
| 872 | ;; | |
| 873 | (with-chaos-error (#'report-decl-error) | |
| 874 | (eval-ast e)) | |
| 875 | (print-in-progress ".")))) | |
| 876 | ;; FINAL SET UP. | |
| 877 | (let ((real-mod (find-module-in-env name nil))) | |
| 878 | (final-setup real-mod) | |
| 879 | (if recover-same-context | |
| 880 | (setq *last-module* real-mod) | |
| 881 | (if auto-context? | |
| 882 | (change-context *last-module* real-mod))) | |
| 883 | ;; | |
| 884 | (unless (module-is-parameter-theory real-mod) | |
| 885 | (print-in-progress " done.")) | |
| 886 | ;; | |
| 887 | real-mod))))) | |
| 888 | ||
| 889 | ;;;============================================================================= | |
| 890 | ;;; VIEW | |
| 780 | (or *top-level-definition-in-progress* | |
| 781 | mod))) | |
| 782 | ;; construction process is done in the context of `mod'. | |
| 783 | (with-in-module (mod) | |
| 784 | (add-modexp-defn name mod) | |
| 785 | ;; operate on mod by side-effect ---------------- | |
| 786 | ;; EVAL EACH MODULE CONSTRUCTS. | |
| 787 | (dolist (e body) | |
| 788 | (flet ((report-decl-error (&rest ignore) | |
| 789 | (declare (ignore ignore)) | |
| 790 | (unless *chaos-quiet* | |
| 791 | (with-output-msg () | |
| 792 | (format t "failed to evaluate the form:~%") | |
| 793 | (print-ast e) | |
| 794 | (force-output))) | |
| 795 | (chaos-error 'declaration-failed))) | |
| 796 | ;; | |
| 797 | (with-chaos-error (#'report-decl-error) | |
| 798 | (eval-ast e)) | |
| 799 | (print-in-progress ".")))) | |
| 800 | ;; FINAL SET UP. | |
| 801 | (let ((real-mod (find-module-in-env name nil))) | |
| 802 | (final-setup real-mod) | |
| 803 | (if recover-same-context | |
| 804 | (reset-context-module real-mod) | |
| 805 | (if auto-context? | |
| 806 | (change-context (get-context-module t) real-mod))) | |
| 807 | ;; | |
| 808 | (unless (module-is-parameter-theory real-mod) | |
| 809 | (print-in-progress " done.")) | |
| 810 | ;; | |
| 811 | real-mod))))) | |
| 812 | ||
| 813 | ;;;============================================================================= | |
| 814 | ;;; VIEW | |
| 891 | 815 | ;;;============================================================================= |
| 892 | 816 | |
| 893 | 817 | ;;; DECLARE-VIEW : definition -> View |
| 894 | 818 | ;;; |
| 895 | 819 | (defun declare-view (decl) |
| 896 | 820 | (let ((name (%view-decl-name decl)) |
| 897 | (view (%view-decl-view decl)) | |
| 898 | (*auto-context-change* nil) | |
| 899 | (*current-module* nil)) | |
| 821 | (view (%view-decl-view decl)) | |
| 822 | (*auto-context-change* nil) | |
| 823 | (*current-module* nil)) | |
| 900 | 824 | (declare (special *auto-context-change*)) |
| 901 | 825 | (let ((real-name (normalize-modexp name)) |
| 902 | new-view) | |
| 826 | new-view) | |
| 903 | 827 | (let ((vw (find-view-in-env real-name))) |
| 904 | (unless *chaos-quiet* | |
| 905 | (format *error-output* "~&-- defining view ~a " name)) | |
| 906 | (when vw | |
| 907 | (with-output-chaos-warning () | |
| 908 | (format t "redefining view ~a " real-name)) | |
| 909 | (propagate-view-change vw) | |
| 910 | ) | |
| 911 | ;; | |
| 912 | (setq new-view (complete-view view)) | |
| 913 | (setf (view-name new-view) real-name) | |
| 914 | (setf (view-decl-form new-view) view) | |
| 915 | (if vw | |
| 916 | (copy-view new-view vw) | |
| 917 | (setq vw new-view)) | |
| 918 | ;; | |
| 919 | (add-depend-relation vw :view (view-src vw)) | |
| 920 | (add-depend-relation vw :view (view-target vw)) | |
| 921 | (add-view-defn real-name vw) | |
| 922 | (print-in-progress " done.") | |
| 923 | ;; | |
| 924 | (mark-view-as-consistent vw) | |
| 925 | vw)))) | |
| 926 | ||
| 927 | ;;;============================================================================= | |
| 928 | ;;; IMPORTATION | |
| 828 | (unless *chaos-quiet* | |
| 829 | (format *error-output* "~%-- defining view ~a " name)) | |
| 830 | (when vw | |
| 831 | (with-output-chaos-warning () | |
| 832 | (format t "redefining view ~a " real-name)) | |
| 833 | (propagate-view-change vw) | |
| 834 | ) | |
| 835 | ;; | |
| 836 | (setq new-view (complete-view view)) | |
| 837 | (setf (view-name new-view) real-name) | |
| 838 | (setf (view-decl-form new-view) view) | |
| 839 | (if vw | |
| 840 | (copy-view new-view vw) | |
| 841 | (setq vw new-view)) | |
| 842 | ;; | |
| 843 | (add-depend-relation vw :view (view-src vw)) | |
| 844 | (add-depend-relation vw :view (view-target vw)) | |
| 845 | (add-view-defn real-name vw) | |
| 846 | (print-in-progress " done.") | |
| 847 | ;; | |
| 848 | (mark-view-as-consistent vw) | |
| 849 | vw)))) | |
| 850 | ||
| 851 | ;;;============================================================================= | |
| 852 | ;;; IMPORTATION | |
| 929 | 853 | ;;;============================================================================= |
| 930 | 854 | |
| 931 | 855 | ;;; EVAL-IMPORT-MODEXP : import-decl -> {cur_mod} |
| 934 | 858 | (defun eval-import-modexp (decl) |
| 935 | 859 | (I-miss-current-module eval-import-modexp) |
| 936 | 860 | (let ((mode (%import-mode decl)) |
| 937 | (modexp (%import-module decl)) | |
| 938 | (parameter (%import-parameter decl)) | |
| 939 | (alias (%import-alias decl)) | |
| 940 | (new-mod nil)) | |
| 941 | (when (and (%is-modexp modexp) | |
| 942 | (equal (%modexp-value modexp) "THE-LAST-MODULE")) | |
| 943 | (setf (%modexp-value modexp) *last-module*)) | |
| 944 | (setf new-mod (import-module *current-module* mode modexp parameter alias)) | |
| 861 | (modexp (%import-module decl)) | |
| 862 | (parameter (%import-parameter decl)) | |
| 863 | (alias (%import-alias decl)) | |
| 864 | (new-mod nil)) | |
| 865 | (setf new-mod (import-module (get-context-module) mode modexp parameter alias)) | |
| 945 | 866 | new-mod)) |
| 946 | 867 | |
| 947 | 868 | ;;; !ADD-US |
| 948 | 869 | ;;;----------------------------------------------------------------------------- |
| 949 | 870 | ;;; NOT YET |
| 950 | ||
| 951 | #|| | |
| 952 | (defun !add-us (e) | |
| 953 | ;; expansion top-level-eval | |
| 954 | (let ((mepars (parse-modexp (third e)))) | |
| 955 | (if (and (consp mepars) (eq 'with (car mepars))) | |
| 956 | (!add-using-with *current-module* mepars) | |
| 957 | (let ((val (eval-modexp mepars nil nil))) | |
| 958 | (if (eq *TRUTH-module* val) | |
| 959 | (with-output-chaos-warning () | |
| 960 | (princ "using TRUTH not allowed, replaced by extending") | |
| 961 | (print-next) | |
| 962 | (princ "in module ") (print-mod-name *current-module*) | |
| 963 | (import-module *current-module* :extending val)) | |
| 964 | (if (eq *current-module* val) | |
| 965 | (with-output-chaos-warning () | |
| 966 | (princ "module cannot use itself (ignored).")) | |
| 967 | (import-module *current-module* :using val)))) | |
| 968 | ))) | |
| 969 | ||# | |
| 970 | ||
| 971 | #|| | |
| 972 | ;;; handle using X with A and B | |
| 973 | (defun !add-using-with (module mepars) | |
| 974 | (let ((mod (eval-modexp (cadr mepars)))) | |
| 975 | (when (modexp-is-error mod) | |
| 976 | (with-output-chaos-error () | |
| 977 | (princ "cannot evaluate module: ") | |
| 978 | (print-modexp (cadr mepars)) | |
| 979 | (chaos-to-top))) | |
| 980 | (let ((submods (let ((*current-module* mod)) | |
| 981 | (mapcar #'(lambda (me) | |
| 982 | (let ((val (eval-modexp me))) | |
| 983 | (when (modexp-is-error val) | |
| 984 | (with-output-chaos-error () | |
| 985 | (princ "cannot evaluate module: ") | |
| 986 | (print-modexp me) | |
| 987 | (terpri) | |
| 988 | (chaos-to-top))) | |
| 989 | val)) | |
| 990 | (if (equal '(nil) (caddr mepars)) | |
| 991 | nil | |
| 992 | (caddr mepars)))))) | |
| 993 | (incorporate-using-with module mod submods)))) | |
| 994 | 871 | |
| 995 | 872 | ;;; Labels in Axioms env. |
| 996 | 873 | ;;;----------------------------------------------------------------------------- |
| 1001 | 878 | (let ((val (delete "," x :test #'equal)) (res nil)) |
| 1002 | 879 | (dolist (l val) |
| 1003 | 880 | (if (find #\. l) |
| 1004 | (with-output-chaos-warning () | |
| 1005 | (princ "label ") | |
| 1006 | (princ l) | |
| 1007 | (princ " contains a '.' (ignored)") (terpri)) | |
| 1008 | (if (digit-char-p (char l 0)) | |
| 1009 | (with-output-chaos-warning () | |
| 1010 | (princ "label ") | |
| 1011 | (princ l) | |
| 1012 | (princ " contains an initial digit (ignored)") (terpri)) | |
| 1013 | (push l res))) | |
| 1014 | ) | |
| 1015 | (nreverse res) | |
| 1016 | )) | |
| 1017 | ||
| 1018 | ||
| 1019 | ;;;============================================================================= | |
| 1020 | ;;; MISC. | |
| 1021 | ||
| 1022 | ;;; AS | |
| 1023 | ;;;----------------------------------------------------------------------------- | |
| 1024 | ;;; !ADD-AS | |
| 1025 | ;;; | |
| 1026 | (defun !add-as (e) | |
| 1027 | (unless (module-is-prepare-for-parsing *current-module*) | |
| 1028 | (prepare-for-parsing *current-module*)) | |
| 1029 | (with-in-module (*current-module*) | |
| 1030 | (let* ((so (module-sort-order *current-module*)) | |
| 1031 | (sort (find-sort-in *current-module* (nth 1 e))) | |
| 1032 | (tm (parser$parses *current-module* (nth 3 e) | |
| 1033 | (if sort sort *cosmos*))) | |
| 1034 | (cnd (parser$parses *current-module* (nth 5 e)))) | |
| 1035 | (when (null sort) | |
| 1036 | (princ "Unknown sort in sort constraint")) | |
| 1037 | (when (null tm) | |
| 1038 | (princ "No parse for term in sort constraint") (terpri)) | |
| 1039 | (when (or (null cnd) (not (null (cdr cnd)))) | |
| 1040 | (princ "No single parse for condition in sort constraint") (terpri)) | |
| 1041 | (if (and tm (not (null (cdr tm)))) | |
| 1042 | (when tm (princ "Term in sort constraint is ambiguous") (terpri)) | |
| 1043 | (when (and tm (null (cdr tm))) | |
| 1044 | (when (and sort tm) | |
| 1045 | (unless (sort-order$is-included-in so sort (term$sort (car tm))) | |
| 1046 | (princ "Specified sort and sort of term incompatible"))) | |
| 1047 | (when (and tm cnd (null (cdr tm)) (null (cdr cnd))) | |
| 1048 | (unless (subsetp (term$vars (car cnd)) (term$vars (car tm))) | |
| 1049 | (princ "Condition variables not subset of those in term") (terpri))) | |
| 1050 | ))) | |
| 1051 | (error "** Error: general sort constraint not currently handled (ignored)") | |
| 1052 | (terpri) | |
| 1053 | (princ " ") | |
| 1054 | (princ "as ") | |
| 1055 | (simple-princ-open (nth 1 e)) | |
| 1056 | (princ " : ") | |
| 1057 | (simple-princ-open (nth 3 e)) | |
| 1058 | (princ " if ") | |
| 1059 | (simple-princ-open (nth 5 e)) | |
| 1060 | (princ " .") | |
| 1061 | (terpri) | |
| 1062 | )) | |
| 1063 | ||
| 1064 | ;;; OP-AS | |
| 1065 | (defun !add-op-as (e) | |
| 1066 | ;(!add-sort-constraint | |
| 1067 | ; (nth 7 e) (nth 5 e) (nth 9 e)) | |
| 1068 | (with-output-chaos-warning () | |
| 1069 | (princ "operator assertion being treated simply as a") | |
| 1070 | (princ " declaration") (print-next) | |
| 1071 | (princ "for operator: ") (print-simple-princ-open (nth 1 e)) (terpri)) | |
| 1072 | (!add-op | |
| 1073 | `("op" ,(nth 1 e) ":" ,(nth 3 e) "->" ,(nth 5 e) | |
| 1074 | ,@(if (equal "." (nth 10 e)) nil (list (nth 10 e))) | |
| 1075 | ".")) | |
| 1076 | ) | |
| 1077 | ||
| 1078 | ||# | |
| 881 | (with-output-chaos-warning () | |
| 882 | (princ "label ") | |
| 883 | (princ l) | |
| 884 | (princ " contains a '.' (ignored)") (terpri)) | |
| 885 | (if (digit-char-p (char l 0)) | |
| 886 | (with-output-chaos-warning () | |
| 887 | (princ "label ") | |
| 888 | (princ l) | |
| 889 | (princ " contains an initial digit (ignored)") (terpri)) | |
| 890 | (push l res)))) | |
| 891 | (nreverse res))) | |
| 1079 | 892 | |
| 1080 | 893 | ;;; EOF |
| 0 | 0 | ;;;-*- Mode:LISP; Package:CHAOS; Base:10; Syntax:Common-lisp -*- |
| 1 | 1 | ;;; |
| 2 | ;;; Copyright (c) 2000-2014, Toshimi Sawada. All rights reserved. | |
| 2 | ;;; Copyright (c) 2000-2015, Toshimi Sawada. All rights reserved. | |
| 3 | 3 | ;;; |
| 4 | 4 | ;;; Redistribution and use in source and binary forms, with or without |
| 5 | 5 | ;;; modification, are permitted provided that the following conditions |
| 27 | 27 | ;;; |
| 28 | 28 | (in-package :chaos) |
| 29 | 29 | #|============================================================================== |
| 30 | System: CHAOS | |
| 31 | Module: eval | |
| 32 | File: eval-ast2.lisp | |
| 30 | System: CHAOS | |
| 31 | Module: eval | |
| 32 | File: eval-ast2.lisp | |
| 33 | 33 | ==============================================================================|# |
| 34 | 34 | #-:chaos-debug |
| 35 | 35 | (declaim (optimize (speed 3) (safety 0) #-GCL (debug 0))) |
| 82 | 82 | (defun eval-lisp-form (ast) |
| 83 | 83 | (let ((form (%lisp-eval-form ast))) |
| 84 | 84 | (setq form |
| 85 | (cond ((consp form) | |
| 85 | (cond ((consp form) | |
| 86 | 86 | (if (symbolp (car form)) |
| 87 | 87 | (if (fboundp (car form)) |
| 88 | 88 | form |
| 94 | 94 | (if (boundp form) |
| 95 | 95 | form |
| 96 | 96 | (with-output-chaos-error ('invalid-lisp-form) |
| 97 | (format t "unbound Lisp symbol \"~a\"." form) | |
| 98 | )) | |
| 97 | (format t "unbound Lisp symbol \"~a\"." form))) | |
| 99 | 98 | form)))) |
| 100 | 99 | (eval form))) |
| 101 | 100 | |
| 128 | 127 | (perform-reduction* preterm modexp mode result-as-text))) |
| 129 | 128 | |
| 130 | 129 | (defun perform-reduction* (preterm &optional modexp mode (result-as-text nil)) |
| 131 | ;; (setq $$trials 1) | |
| 132 | (setq *m-pattern-subst* nil) | |
| 133 | ;; | |
| 134 | (setq .rwl-context-stack. nil) | |
| 135 | (setq .rwl-sch-context. nil) | |
| 136 | (setq .rwl-states-so-far. 0) | |
| 137 | ;; | |
| 138 | (let ((*consider-object* t) | |
| 139 | (*rewrite-exec-mode* (or (eq mode :exec) | |
| 140 | (eq mode :exec+))) | |
| 141 | (*rewrite-semantic-reduce* nil) | |
| 142 | sort | |
| 143 | time1 | |
| 144 | time2 | |
| 145 | (time-for-parse nil) | |
| 146 | (time-for-reduction nil) | |
| 147 | (number-matches nil)) | |
| 148 | (let ((mod (if modexp | |
| 149 | (eval-modexp modexp) | |
| 150 | *last-module*))) | |
| 151 | (unless (eq mod *last-module*) | |
| 152 | (clear-term-memo-table *term-memo-table*)) | |
| 153 | (if (or (null mod) (modexp-is-error mod)) | |
| 154 | (if (null mod) | |
| 155 | (with-output-chaos-error ('no-context) | |
| 156 | (princ "no module expression provided and no selected(current) module.") | |
| 157 | ) | |
| 158 | (with-output-chaos-error ('no-such-module) | |
| 159 | (princ "incorrect module expression, no such module ") | |
| 160 | (print-chaos-object modexp) | |
| 161 | )) | |
| 130 | (let ((result nil) ; normalized term | |
| 131 | (mod (if modexp ; context of rewriting | |
| 132 | (eval-modexp modexp) | |
| 133 | (get-context-module))) | |
| 134 | term ; target term | |
| 135 | stat-form ; statistics in string | |
| 136 | term-form) ; normalized term in string form | |
| 137 | ;; prepare rewriting context | |
| 138 | (when (modexp-is-error mod) | |
| 139 | (with-output-chaos-error ('no-such-module) | |
| 140 | (princ "Incorrect module expression, no such module ") | |
| 141 | (print-chaos-object modexp))) | |
| 142 | ;; set rewrting context | |
| 143 | (context-push-and-move (get-context-module t) mod) | |
| 144 | (when *auto-context-change* | |
| 145 | (change-context (get-context-module t) mod)) | |
| 146 | ;; parse target term | |
| 147 | (setq term (prepare-term preterm mod)) | |
| 148 | ;; print out prelude message | |
| 149 | (unless *chaos-quiet* | |
| 150 | (with-in-module (mod) | |
| 151 | (format t "~&-- ~a in " (if (eq mode :exec) | |
| 152 | "execute" | |
| 153 | (if (eq mode :exec+) | |
| 154 | "execute!" | |
| 155 | (if (eq mode :red) | |
| 156 | "reduce" | |
| 157 | "bhavioral reduce")))) | |
| 158 | (print-simple-mod-name mod) | |
| 159 | (princ " : ") | |
| 160 | (let ((*print-indent* (+ 4 *print-indent*))) | |
| 161 | (print-check 0 20) | |
| 162 | (term-print-with-sort term)) | |
| 163 | (flush-all))) | |
| 164 | ;; do the rewriting | |
| 165 | (let ((*chaos-quiet* t)) | |
| 166 | (compile-module mod)) | |
| 167 | (setq result (reducer term mod mode)) | |
| 168 | ;; print out the resultant term | |
| 169 | (with-in-module (mod) | |
| 170 | (if result-as-text | |
| 171 | (setq term-form (term-print-with-sort-string result)) | |
| 162 | 172 | (progn |
| 163 | (context-push-and-move *last-module* mod) | |
| 164 | (with-in-module (mod) | |
| 165 | (when *auto-context-change* | |
| 166 | (change-context *last-module* mod)) | |
| 167 | (!setup-reduction mod) | |
| 168 | (setq $$mod *current-module*) | |
| 169 | (setq sort *cosmos*) | |
| 170 | (when *show-stats* (setq time1 (get-internal-run-time))) | |
| 171 | (setq *rewrite-semantic-reduce* | |
| 172 | (and (eq mode :red) | |
| 173 | (module-has-behavioural-axioms mod))) | |
| 174 | ;; | |
| 175 | (let* ((*parse-variables* nil) | |
| 176 | (term (simple-parse *current-module* preterm sort))) | |
| 177 | (when (or (null (term-sort term)) | |
| 178 | (sort<= (term-sort term) *syntax-err-sort* *chaos-sort-order*)) | |
| 179 | (return-from perform-reduction* nil)) | |
| 180 | #|| | |
| 181 | (setq term (car (canonicalize-variables (list term) mod))) | |
| 182 | ||# | |
| 183 | (when *rewrite-stepping* (setq *steps-to-be-done* 1)) | |
| 184 | (when *show-stats* | |
| 185 | (setq time2 (get-internal-run-time)) | |
| 186 | (setf time-for-parse | |
| 187 | (format nil "~,3f sec" | |
| 188 | ;; (/ (float (- time2 time1)) internal-time-units-per-second) | |
| 189 | (elapsed-time-in-seconds time1 time2) | |
| 190 | ))) | |
| 191 | (unless *chaos-quiet* | |
| 192 | ;; (fresh-all) | |
| 193 | (flush-all) | |
| 194 | (if (eq mode :exec) ; *rewrite-exec-mode* | |
| 195 | (format t "~%-- execute in ") | |
| 196 | (if (eq mode :exec+) | |
| 197 | (format t "~%-- execute! in ") | |
| 198 | (if (eq mode :red) | |
| 199 | (format t "~%-- reduce in ") | |
| 200 | (format t"~%-- behavioural reduce in ")) | |
| 201 | )) | |
| 202 | (print-simple-mod-name *current-module*) | |
| 203 | (princ " : ") | |
| 204 | (let ((*print-indent* (+ 4 *print-indent*))) | |
| 205 | (print-check 0 20) | |
| 206 | (term-print-with-sort term)) | |
| 207 | (flush-all)) | |
| 208 | ;; ******** | |
| 209 | (reset-target-term term *last-module* mod) | |
| 210 | ;; ******** | |
| 211 | (setq $$matches 0) | |
| 212 | (setq time1 (get-internal-run-time)) | |
| 213 | (let ((*perform-on-demand-reduction* t) | |
| 214 | (*rule-count* 0)) | |
| 215 | (let ((res nil)) | |
| 216 | (catch 'rewrite-abort | |
| 217 | (let ((*do-empty-match* nil)) ; t | |
| 218 | (if (and *rewrite-exec-mode* | |
| 219 | *cexec-normalize*) | |
| 220 | (rewrite-exec term *current-module* mode) | |
| 221 | (rewrite term *current-module* mode)))) | |
| 222 | ;; | |
| 223 | #|| ============= TODO | |
| 224 | (when (term-op-contains-theory $$term) | |
| 225 | (reset-reduced-flag $$term) | |
| 226 | (setq term $$term) | |
| 227 | (catch 'rewrite-abort | |
| 228 | (let ((*do-empty-match* nil)) | |
| 229 | (if (and *rewrite-exec-mode* | |
| 230 | *cexec-normalize*) | |
| 231 | (rewrite-exec term *current-module* mode) | |
| 232 | (rewrite term *current-module* mode))))) | |
| 233 | ||# | |
| 234 | ;; | |
| 235 | (setq res $$term) | |
| 236 | (when *mel-sort* | |
| 237 | (setq res (setq $$term (apply-sort-memb res mod))) | |
| 238 | ) | |
| 239 | ;; | |
| 240 | (setq time2 (get-internal-run-time)) | |
| 241 | (setf time-for-reduction | |
| 242 | (format nil "~,3f sec" | |
| 243 | (elapsed-time-in-seconds time1 time2))) | |
| 244 | (setf number-matches $$matches) | |
| 245 | (setq $$matches 0) | |
| 246 | (setq $$norm res) | |
| 247 | ;; print out the result. | |
| 248 | (if result-as-text | |
| 249 | (let ((red-term (term-print-with-sort-string res)) | |
| 250 | (stat | |
| 251 | (if *show-stats* | |
| 252 | (concatenate | |
| 253 | 'string | |
| 254 | (format nil | |
| 255 | "~%(~a for parse, ~s rewrites(~a), ~d matches" | |
| 256 | time-for-parse | |
| 257 | *rule-count* | |
| 258 | time-for-reduction | |
| 259 | number-matches) | |
| 260 | (if (zerop *term-memo-hash-hit*) | |
| 261 | (format nil ")~%") | |
| 262 | (format nil ", ~d memo hits)~%" | |
| 263 | *term-memo-hash-hit*))) | |
| 264 | ""))) | |
| 265 | (return-from perform-reduction* (values red-term stat))) | |
| 266 | (progn | |
| 267 | (terpri)(term-print-with-sort res) | |
| 268 | (when *show-stats* | |
| 269 | (format t "~%(~a for parse, ~s rewrites(~a), ~d matches" | |
| 270 | time-for-parse | |
| 271 | *rule-count* | |
| 272 | time-for-reduction | |
| 273 | number-matches) | |
| 274 | (if (zerop *term-memo-hash-hit*) | |
| 275 | (format t ")~%") | |
| 276 | (format t ", ~d memo hits)~%" | |
| 277 | *term-memo-hash-hit*))) | |
| 278 | (flush-all) | |
| 279 | ;; (terpri) | |
| 280 | )) | |
| 281 | )) | |
| 282 | )) | |
| 283 | (context-pop-and-recover)))))) | |
| 173 | (format t "~%") | |
| 174 | (term-print-with-sort result)))) | |
| 175 | (when *show-stats* | |
| 176 | (setf stat-form (generate-statistics-form)) | |
| 177 | (format t "~%~a" stat-form) | |
| 178 | (flush-all)) | |
| 179 | ;; reset the context | |
| 180 | (context-pop-and-recover) | |
| 181 | ;; done all | |
| 182 | (if result-as-text | |
| 183 | (values term-form stat-form) | |
| 184 | nil))) | |
| 284 | 185 | |
| 285 | 186 | (defun perform-meta-reduction (pre-term &optional modexp mode) |
| 286 | 187 | (let ((*rewrite-exec-mode* (or (eq mode :exec) |
| 287 | 188 | (eq mode :exec+))) |
| 288 | 189 | (*rewrite-semantic-reduce* nil) |
| 289 | sort) | |
| 190 | sort) | |
| 290 | 191 | (let ((mod (if modexp |
| 291 | 192 | (eval-modexp modexp) |
| 292 | *last-module*))) | |
| 293 | (if (or (null mod) (modexp-is-error mod)) | |
| 294 | (if (null mod) | |
| 295 | (with-output-chaos-error ('no-context) | |
| 296 | (princ "no module expression provided and no selected(current) module.")) | |
| 297 | (with-output-chaos-error ('no-such-module) | |
| 298 | (princ "incorrect module expression, no such module ") | |
| 299 | (print-chaos-object modexp))) | |
| 193 | (get-context-module)))) | |
| 194 | (if (modexp-is-error mod) | |
| 195 | (with-output-chaos-error ('no-such-module) | |
| 196 | (princ "incorrect module expression, no such module ") | |
| 197 | (print-chaos-object modexp)) | |
| 300 | 198 | (progn |
| 301 | (context-push-and-move *last-module* mod) | |
| 302 | (setq sort *cosmos*) | |
| 199 | (context-push-and-move (get-context-module t) mod) | |
| 200 | (setq sort *cosmos*) | |
| 201 | (when *auto-context-change* | |
| 202 | (change-context (get-context-module t) mod)) ;;; what? | |
| 303 | 203 | (with-in-module (mod) |
| 304 | ;; | |
| 305 | (change-context *last-module* mod) | |
| 306 | ;; | |
| 307 | (!setup-reduction mod) | |
| 204 | (!setup-reduction *current-module*) | |
| 308 | 205 | (setq $$mod *current-module*) |
| 309 | 206 | (setq *rewrite-semantic-reduce* |
| 310 | 207 | (and (eq mode :red) |
| 311 | 208 | (module-has-behavioural-axioms mod))) |
| 312 | (let* ((*parse-variables* nil) | |
| 313 | (term (simple-parse *current-module* pre-term sort)) | |
| 314 | (res nil)) | |
| 209 | (let* ((*parse-variables* nil) | |
| 210 | (term (simple-parse *current-module* pre-term sort)) | |
| 211 | (res nil)) | |
| 315 | 212 | (when (or (null (term-sort term)) |
| 316 | 213 | (sort<= (term-sort term) *syntax-err-sort* *chaos-sort-order*)) |
| 317 | 214 | (return-from perform-meta-reduction nil)) |
| 318 | (setq res (car (canonicalize-variables (list term) mod))) | |
| 319 | (catch 'rewrite-abort | |
| 320 | (let ((*do-empty-match* nil)) ; t | |
| 321 | (if (and *rewrite-exec-mode* | |
| 322 | *cexec-normalize*) | |
| 323 | (rewrite-exec res *current-module* mode) | |
| 324 | (rewrite res *current-module* mode)))) | |
| 325 | (context-pop-and-recover) | |
| 326 | res))))))) | |
| 215 | (setq res (car (canonicalize-variables (list term) mod))) | |
| 216 | (catch 'rewrite-abort | |
| 217 | (let ((*do-empty-match* nil)) ; t | |
| 218 | (if (and *rewrite-exec-mode* | |
| 219 | *cexec-normalize*) | |
| 220 | (rewrite-exec res *current-module* mode) | |
| 221 | (rewrite res *current-module* mode)))) | |
| 222 | (context-pop-and-recover) | |
| 223 | res))))))) | |
| 327 | 224 | |
| 328 | 225 | ;;; ************** |
| 329 | 226 | ;;; TEST REDUCTION |
| 364 | 261 | (defun do-parse-term* (preterm &optional modexp) |
| 365 | 262 | (let ((mod (if modexp |
| 366 | 263 | (eval-modexp modexp) |
| 367 | *last-module*))) | |
| 368 | (unless mod | |
| 369 | (with-output-chaos-error ('no-context) | |
| 370 | (princ "no module expression provided and no selected(current) module."))) | |
| 264 | (get-context-module))) | |
| 265 | (target-term nil)) | |
| 371 | 266 | (when (modexp-is-error mod) |
| 372 | 267 | (with-output-chaos-error ('no-such-module) |
| 373 | (princ "incorrect module expression, not such module: ") | |
| 374 | (print-chaos-object modexp))) | |
| 268 | (princ "incorrect module expression, no such module: ") | |
| 269 | (print-chaos-object modexp))) | |
| 375 | 270 | ;; |
| 376 | (context-push-and-move *last-module* mod) | |
| 271 | (context-push-and-move (get-context-module t) mod) | |
| 377 | 272 | (with-in-module (mod) |
| 378 | 273 | (prepare-for-parsing *current-module*) |
| 379 | 274 | (let ((*parse-variables* nil)) |
| 380 | (let ((res (simple-parse *current-module* preterm *cosmos*))) | |
| 381 | (setq res (car (canonicalize-variables (list res) mod))) | |
| 382 | ;; ******** MEL | |
| 383 | (when *mel-sort* | |
| 384 | (!setup-reduction mod) | |
| 385 | (setq res (apply-sort-memb res | |
| 386 | mod))) | |
| 387 | (reset-target-term res *last-module* mod) | |
| 388 | ;; ******** | |
| 389 | (format t "~&") | |
| 390 | (term-print-with-sort res *standard-output*) | |
| 391 | (flush-all) | |
| 392 | ;; (break "...") | |
| 393 | #|| | |
| 394 | (when *chaos-verbose* | |
| 395 | (print-term-tree res t)) | |
| 396 | ||# | |
| 397 | ))) | |
| 398 | (context-pop-and-recover))) | |
| 275 | (setq target-term (car (canonicalize-variables (list (simple-parse *current-module* preterm *cosmos*)) mod))) | |
| 276 | ;; ******** MEL | |
| 277 | (when *mel-sort* | |
| 278 | (!setup-reduction mod) | |
| 279 | (setq target-term (apply-sort-memb target-term mod))) | |
| 280 | (reset-target-term target-term *current-module* mod) | |
| 281 | ;; ******** | |
| 282 | (format t "~%") | |
| 283 | (term-print-with-sort target-term *standard-output*) | |
| 284 | (flush-all))) | |
| 285 | (context-pop-and-recover) | |
| 286 | (values target-term mod))) | |
| 399 | 287 | |
| 400 | 288 | ;;; *TODO* |
| 401 | 289 | (defun red-loop (mod &optional prompt) |
| 402 | 290 | (declare (ignore mod prompt)) |
| 403 | 291 | (with-output-simple-msg () |
| 404 | 292 | (princ "sorry, red-loop is not implemented yet..")) |
| 405 | (return-from red-loop nil) | |
| 406 | #|| | |
| 407 | (setq $$trials 1) | |
| 408 | (setq mod (eval-modexp-top mod)) | |
| 409 | (if (modexp-is-error mod) | |
| 410 | (with-output-chaos-error ('no-such-module) | |
| 411 | (princ "undefined module") | |
| 412 | ) | |
| 413 | (let (in | |
| 414 | (flag nil) | |
| 415 | (top-level (at-top-level))) | |
| 416 | (!setup-reduction mod) | |
| 417 | (loop | |
| 418 | (chaos-init) | |
| 419 | (when (and prompt top-level) | |
| 420 | (terpri) | |
| 421 | (print-mod-name mod) (princ "> ")) | |
| 422 | (let ((cur (!set-single-reader '("[" "]" "_")))) | |
| 423 | (progn | |
| 424 | (setq in (read-seq-of-term '(|.|))) | |
| 425 | (!set-reader cur))) | |
| 426 | (when (null in) (return)) | |
| 427 | (unless top-level | |
| 428 | (if flag | |
| 429 | (progn (princ "---------------------------------------") | |
| 430 | (terpri)) | |
| 431 | (setq flag t))) | |
| 432 | (perform-reduction in) ; should ... | |
| 433 | ))) | |
| 434 | :done | |
| 435 | ||# | |
| 436 | ) | |
| 293 | (return-from red-loop nil)) | |
| 437 | 294 | |
| 438 | 295 | (defun check-bad-rules (mod) |
| 439 | 296 | (declare (ignore mod)) |
| 457 | 314 | (defun under-debug-rewrite () |
| 458 | 315 | (or $$trace-rewrite $$trace-rewrite-whole *rewrite-stepping* |
| 459 | 316 | *rewrite-count-limit* *rewrite-stop-pattern*)) |
| 460 | ||
| 461 | #|| | |
| 462 | (defun rewrite-debug-on () | |
| 463 | (setf (symbol-function 'apply-one-rule) | |
| 464 | (symbol-function 'apply-one-rule-dbg))) | |
| 465 | ||
| 466 | (defun rewrite-debug-off () | |
| 467 | (unless (under-debug-rewrite) | |
| 468 | (setf (symbol-function 'apply-one-rule) | |
| 469 | (symbol-function 'apply-one-rule-simple)))) | |
| 470 | ||# | |
| 471 | 317 | |
| 472 | 318 | (defun rewrite-debug-on () ()) |
| 473 | 319 | (defun rewrite-debug-off () ()) |
| 499 | 345 | (parse-integer count :junk-allowed t) |
| 500 | 346 | (if (= len (length count)) |
| 501 | 347 | (set-rewrite-count-limit num) |
| 502 | (with-output-chaos-error ('invalid-value) | |
| 503 | (format t "invalid rewrite count limit ~a" count) | |
| 504 | )))))) | |
| 348 | (with-output-chaos-error ('invalid-value) | |
| 349 | (format t "invalid rewrite count limit ~a" count))))))) | |
| 505 | 350 | |
| 506 | 351 | (defun set-rewrite-count-limit (num) |
| 507 | 352 | (if (integerp num) |
| 511 | 356 | (if (> num 0) |
| 512 | 357 | (progn (setq *rewrite-count-limit* num) |
| 513 | 358 | (rewrite-debug-on)) |
| 514 | (with-output-chaos-error ('invalid-value) | |
| 359 | (with-output-chaos-error ('invalid-value) | |
| 515 | 360 | (format t "invalid rewrite count limit value ~d" num) |
| 516 | 361 | (print-next) (princ "must be a positive integer.") |
| 517 | 362 | ))) |
| 526 | 371 | (parse-integer (car value) :junk-allowed t) |
| 527 | 372 | (if (= len (length (car value))) |
| 528 | 373 | (set-rewrite-count-limit num) |
| 529 | (with-output-chaos-error ('invalid-value) | |
| 530 | (format t "invalid rewrite count limit ~a" (car value)) | |
| 531 | (print-next) | |
| 532 | (princ "must be a positive integer.")))))) | |
| 374 | (with-output-chaos-error ('invalid-value) | |
| 375 | (format t "invalid rewrite count limit ~a" (car value)) | |
| 376 | (print-next) | |
| 377 | (princ "must be a positive integer.")))))) | |
| 533 | 378 | |
| 534 | 379 | (defun set-cond-trial-limit (value) |
| 535 | 380 | (if (or (null value) |
| 540 | 385 | (if (and (= len (length (car value))) |
| 541 | 386 | (> num 0)) |
| 542 | 387 | (setq *condition-trial-limit* num) |
| 543 | (with-output-chaos-error ('invalid-value) | |
| 544 | (format t "invalid condition trial limit ~a" (car value)) | |
| 545 | (print-next) | |
| 546 | (princ "must be a positive integer.") ))))) | |
| 388 | (with-output-chaos-error ('invalid-value) | |
| 389 | (format t "invalid condition trial limit ~a" (car value)) | |
| 390 | (print-next) | |
| 391 | (princ "must be a positive integer.") ))))) | |
| 547 | 392 | |
| 548 | 393 | ;;; ******************** |
| 549 | 394 | ;;; REWRITE STOP PATTERN |
| 563 | 408 | (if (or (null pat) |
| 564 | 409 | (member pat '(("none") ("off") ("nil") ("null")))) |
| 565 | 410 | (set-rewrite-stop-pattern 'none) |
| 566 | (let ((mod (or *current-module* | |
| 567 | *last-module* | |
| 568 | (with-output-chaos-error ('no-context) | |
| 569 | (princ "no context (current) module is specified."))) | |
| 570 | )) | |
| 411 | (let ((mod (get-context-module))) | |
| 571 | 412 | (let* ((*parse-variables* (module-variables mod)) |
| 572 | 413 | (term (simple-parse mod |
| 573 | 414 | pat *cosmos*))) |
| 575 | 416 | (sort<= (term-sort term) *syntax-err-sort* |
| 576 | 417 | *chaos-sort-order*)) |
| 577 | 418 | (return-from set-rewrite-stop-pattern2 nil)) |
| 578 | (setq term (car (canonicalize-variables (list term) mod))) | |
| 419 | (setq term (car (canonicalize-variables (list term) mod))) | |
| 579 | 420 | (set-rewrite-stop-pattern term))))) |
| 580 | 421 | |
| 581 | 422 | ;;; ******* |
| 616 | 457 | (setf mod (eval-modexp modexp)) |
| 617 | 458 | (when (modexp-is-error mod) |
| 618 | 459 | (with-output-chaos-error ('no-such-module) |
| 619 | (format t "incorrect module expression, unknown module?") | |
| 620 | (print-modexp modexp) | |
| 621 | )) | |
| 460 | (format t "incorrect module expression, or unknown module: ") | |
| 461 | (print-modexp modexp))) | |
| 622 | 462 | (describe-module mod))) |
| 623 | 463 | |
| 624 | 464 | |
| 630 | 470 | ;; (*current-module* nil) |
| 631 | 471 | mod) |
| 632 | 472 | (setf mod (if (null modexp) |
| 633 | *last-module* | |
| 473 | (get-context-module) | |
| 634 | 474 | (eval-modexp modexp))) |
| 635 | 475 | (when (modexp-is-error mod) |
| 636 | 476 | (with-output-chaos-error ('no-such-module) |
| 637 | (princ "incorrect module expression or uknown module") | |
| 638 | (print-modexp modexp) | |
| 639 | )) | |
| 477 | (princ "incorrect module expression or uknown module ") | |
| 478 | (print-modexp modexp))) | |
| 640 | 479 | ;; |
| 641 | 480 | (unless mod |
| 642 | 481 | (with-output-chaos-error ('no-context) |
| 643 | (princ "no module to be opened!") | |
| 644 | )) | |
| 482 | (princ "no module to be opened!"))) | |
| 645 | 483 | ;; |
| 646 | 484 | (unless *chaos-quiet* |
| 647 | 485 | (fresh-all) |
| 653 | 491 | (!open-module mod) |
| 654 | 492 | (unless *chaos-quiet* |
| 655 | 493 | (print-in-progress ". done.") |
| 656 | (terpri) | |
| 657 | ) | |
| 658 | )) | |
| 494 | (terpri)))) | |
| 659 | 495 | |
| 660 | 496 | (defparameter *module-open-form* |
| 661 | 497 | (%module-decl* "%" |
| 672 | 508 | (princ "closing this module...") (print-next) |
| 673 | 509 | (eval-close-module nil))) |
| 674 | 510 | (setq *open-module* mod) |
| 675 | (setq *last-before-open* *last-module*) | |
| 676 | (setq *last-module* mod) | |
| 511 | (setq *last-before-open* (get-context-module t)) | |
| 677 | 512 | (clear-term-memo-table *term-memo-table*) |
| 678 | 513 | (let ((*chaos-quiet* t) |
| 679 | (*copy-variables* t)) | |
| 514 | (*copy-variables* t) | |
| 515 | open-mod) | |
| 680 | 516 | (setf (%module-decl-kind *module-open-form*) (module-kind mod)) |
| 681 | (setq *last-module* (eval-ast *module-open-form*)) | |
| 682 | (import-module *last-module* :using mod) | |
| 683 | ;; (import-module *last-module* :including mod) | |
| 684 | ;; (import-variables mod *last-module*) | |
| 685 | (compile-module *last-module*)) | |
| 686 | (change-context *last-before-open* *last-module*) | |
| 687 | *last-module*)) | |
| 517 | (setq open-mod (eval-ast *module-open-form*)) | |
| 518 | (import-module open-mod :using (compile-module mod)) | |
| 519 | (compile-module open-mod) | |
| 520 | (change-context *last-before-open* open-mod) | |
| 521 | open-mod))) | |
| 688 | 522 | |
| 689 | 523 | ;;; ************ |
| 690 | 524 | ;;; CLOSE-MODULE |
| 692 | 526 | (defun eval-close-module (&rest ast) |
| 693 | 527 | (declare (ignore ast)) |
| 694 | 528 | (if *open-module* |
| 695 | (let ((saved-open *open-module*)) | |
| 696 | (when (and saved-open (equal "%" (module-name saved-open))) | |
| 697 | ;; (delete-module-all saved-open) | |
| 698 | ;; discard all resources | |
| 699 | (initialize-module *open-module*) | |
| 700 | (setq *open-module* nil)) | |
| 701 | (change-context *last-module* *last-before-open*) | |
| 529 | (let ((omod (eval-modexp "%"))) | |
| 530 | (initialize-module omod) | |
| 531 | (when (eq omod (get-context-module t)) | |
| 532 | (change-context (get-context-module t) *last-before-open*)) | |
| 702 | 533 | (setq *open-module* nil) |
| 703 | (when *current-module* | |
| 704 | (change-current-module *last-module*)) | |
| 705 | 534 | (setq *last-before-open* nil)) |
| 706 | 535 | (with-output-chaos-warning () |
| 707 | (princ "no module is open.") | |
| 708 | ))) | |
| 709 | ||
| 536 | (princ "no module is open.")))) | |
| 710 | 537 | |
| 711 | 538 | ;;; *********** |
| 712 | 539 | ;;; SAVE SYSTEM |
| 758 | 585 | (print-centering |
| 759 | 586 | "* NOTE : DO NOT MODIFY THIS FILE ULESS YOU REALLY KNOW WHAT YOU ARE DOING!." |
| 760 | 587 | .fill-space. |
| 761 | stream) | |
| 762 | ) | |
| 588 | stream)) | |
| 763 | 589 | (terpri stream) |
| 764 | 590 | (princ "|#" stream) |
| 765 | 591 | (format stream "~&(in-package \"CHAOS\")") |
| 781 | 607 | (%view-decl* (view-name v) |
| 782 | 608 | (view-decl-form v)))))) |
| 783 | 609 | ;; the end |
| 784 | (format stream "~&)") | |
| 610 | (format stream "~%)") | |
| 785 | 611 | (when compile |
| 786 | 612 | (compile-file file)))))) |
| 787 | 613 | |
| 862 | 688 | (when msg? |
| 863 | 689 | (with-output-simple-msg () |
| 864 | 690 | (format t "~&** done restting system.") |
| 865 | (force-output))) | |
| 866 | )) | |
| 691 | (force-output))))) | |
| 867 | 692 | |
| 868 | 693 | ;;; ********** |
| 869 | 694 | ;;; FULL-RESET |
| 882 | 707 | (when msg? |
| 883 | 708 | (print-in-progress "."))) |
| 884 | 709 | (when msg? |
| 885 | (format t "~& start clean up views .")) | |
| 710 | (format t "~% start clean up views .")) | |
| 886 | 711 | (dolist (v *modexp-view-table*) |
| 887 | 712 | (clean-up-view (cdr v)) |
| 888 | 713 | (when msg? |
| 894 | 719 | ;; |
| 895 | 720 | (when msg? |
| 896 | 721 | (print-in-progress " done") |
| 897 | (terpri) | |
| 898 | ) | |
| 722 | (terpri)) | |
| 899 | 723 | (setq *chaos-features* nil) |
| 900 | 724 | (setq *open-module* nil) |
| 901 | 725 | (setq *last-before-open* nil) |
| 981 | 805 | (chaos-to-top))) |
| 982 | 806 | (if file |
| 983 | 807 | (funcall proc file) |
| 984 | (funcall proc feature))))) | |
| 808 | (funcall proc (format nil "~{~A~^/~}" | |
| 809 | (cl-ppcre:split "::" feature))))))) | |
| 985 | 810 | |
| 986 | 811 | ;;; ******* |
| 987 | 812 | ;;; PROTECT |
| 1041 | 866 | (chaos-ls "../") |
| 1042 | 867 | (if dir |
| 1043 | 868 | (chaos-ls dir) |
| 1044 | (chaos-ls "."))) | |
| 869 | (chaos-ls "."))) | |
| 1045 | 870 | (force-output))) |
| 1046 | 871 | |
| 1047 | 872 | ;;; *** |
| 1063 | 888 | #+(OR GCL LUCID EXCL CLISP :SBCL) |
| 1064 | 889 | (when command |
| 1065 | 890 | (setq command (reduce #'(lambda (x y) (concatenate 'string x " " y)) |
| 1066 | command)) | |
| 891 | command)) | |
| 1067 | 892 | #+GCL (system command) |
| 1068 | 893 | #+EXCL (excl:shell command) |
| 1069 | 894 | #+CLISP (ext::shell command) |
| 1071 | 896 | #+CMU |
| 1072 | 897 | (when command |
| 1073 | 898 | (let ((com (car command)) |
| 1074 | (args (cdr command))) | |
| 899 | (args (cdr command))) | |
| 1075 | 900 | (ext:run-program com args :output t))) |
| 1076 | 901 | #+:openmcl |
| 1077 | 902 | (when command |
| 1078 | 903 | (let ((com (car command)) |
| 1079 | (args (cdr command))) | |
| 904 | (args (cdr command))) | |
| 1080 | 905 | (ccl:run-program com args :output t))) |
| 1081 | 906 | #+:SBCL |
| 1082 | 907 | (when command |
| 1109 | 934 | (defun eval-popd (ast) |
| 1110 | 935 | (if (%popd-num ast) |
| 1111 | 936 | (chaos-popd (%popd-num ast)) |
| 1112 | (chaos-popd)) | |
| 1113 | (format t "~&~a" (namestring (chaos-pwd)))) | |
| 937 | (chaos-popd))) | |
| 1114 | 938 | |
| 1115 | 939 | ;;; **** |
| 1116 | 940 | ;;; DIRS |
| 1153 | 977 | (princ "no current term to display.")))) |
| 1154 | 978 | ("term" |
| 1155 | 979 | (let* ((target (if (not (or (equal (second dat) "tree") |
| 1156 | (equal (second dat) "graph"))) | |
| 980 | (equal (second dat) "graph"))) | |
| 1157 | 981 | (second dat) |
| 1158 | 982 | nil)) |
| 1159 | 983 | (tree? (if target |
| 1219 | 1043 | ("option" (pignose-show-option (cadr dat))) |
| 1220 | 1044 | ;; =(*)=> support |
| 1221 | 1045 | (("exec" "search" "sch") |
| 1222 | (let ((option (cadr dat)) | |
| 1223 | (num (caddr dat))) | |
| 1224 | (case-equal option | |
| 1225 | ("graph" (show-rwl-sch-graph num)) | |
| 1226 | (otherwise | |
| 1227 | (with-output-chaos-error () | |
| 1228 | (format t "no such `show exec' option ~a" | |
| 1229 | (cadr dat))))))) | |
| 1046 | (let ((option (cadr dat)) | |
| 1047 | (num (caddr dat))) | |
| 1048 | (case-equal option | |
| 1049 | ("graph" (show-rwl-sch-graph num)) | |
| 1050 | (otherwise | |
| 1051 | (with-output-chaos-error () | |
| 1052 | (format t "no such `show exec' option ~a" | |
| 1053 | (cadr dat))))))) | |
| 1230 | 1054 | ("path" (let ((opt (cadr dat))) |
| 1231 | 1055 | (if (member opt '("labels" "label") :test #'equal) |
| 1232 | 1056 | (show-rwl-sch-path (caddr dat) :label) |
| 1233 | 1057 | (show-rwl-sch-path opt)))) |
| 1234 | ("state" (let ((opt (cadr dat))) | |
| 1235 | (show-rwl-sch-path opt nil .rwl-sch-context. t))) | |
| 1236 | ;; | |
| 1237 | (("undocumented" "undoc") | |
| 1238 | (show-undocumented)) | |
| 1058 | ("state" (let ((opt (cadr dat))) | |
| 1059 | (show-rwl-sch-path opt nil .rwl-sch-context. t))) | |
| 1060 | ;; | |
| 1061 | (("undocumented" "undoc") | |
| 1062 | (show-undocumented)) | |
| 1239 | 1063 | ;; CITP |
| 1240 | ("unproved" | |
| 1241 | (print-unproved-goals *proof-tree*)) | |
| 1242 | ("goal" (let ((name (cadr dat))) | |
| 1243 | (print-named-goal *proof-tree* name))) | |
| 1244 | ("proof" (let ((target (second dat))) | |
| 1245 | (when (or (null target) (equal target ".")) | |
| 1246 | (setq target "root")) | |
| 1247 | (print-proof-tree target describe))) | |
| 1248 | ||
| 1249 | ;; | |
| 1250 | ;; helpers | |
| 1251 | ;; | |
| 1064 | ("unproved" | |
| 1065 | (print-unproved-goals *proof-tree*)) | |
| 1066 | ("goal" (let ((name (cadr dat))) | |
| 1067 | (print-named-goal *proof-tree* name))) | |
| 1068 | ("proof" (let ((target (second dat))) | |
| 1069 | (when (or (null target) (equal target ".")) | |
| 1070 | (setq target "root")) | |
| 1071 | (print-proof-tree target describe))) | |
| 1072 | ||
| 1073 | ("autoload" | |
| 1074 | (format t "** Autoload settings:") | |
| 1075 | (format t "~%Module~14TPathname") | |
| 1076 | (format t "~%========================================") | |
| 1077 | (dolist (al *autoload-alist*) | |
| 1078 | (format t "~%~a~14T~a" (car al) (cdr al)))) | |
| 1079 | ("libpath" (pr-search-path)) | |
| 1080 | ;; | |
| 1081 | ;; helpers | |
| 1082 | ;; | |
| 1252 | 1083 | ("?" |
| 1253 | 1084 | (princ "** general module inspection commands.") |
| 1254 | 1085 | (terpri) |
| 1294 | 1125 | (princ " show stop") (terpri) |
| 1295 | 1126 | (princ " show features") (terpri) |
| 1296 | 1127 | (princ " show memo")(terpri) |
| 1297 | ;; | |
| 1128 | ;; | |
| 1298 | 1129 | ;; |
| 1299 | 1130 | (princ "** PigNose resolve base proof system commands.") |
| 1300 | 1131 | (terpri) |
| 1360 | 1191 | |
| 1361 | 1192 | ;; operator strictness |
| 1362 | 1193 | (:strictness |
| 1363 | (let ((mod (if *last-module* *last-module* | |
| 1364 | (if *current-module* | |
| 1365 | *current-module* | |
| 1366 | (with-output-chaos-error ('no-context) | |
| 1367 | (princ "no context (current) module.") | |
| 1368 | ))))) | |
| 1369 | ;; | |
| 1194 | (let ((mod (get-context-module))) | |
| 1370 | 1195 | (!setup-reduction mod) |
| 1371 | 1196 | (with-in-module (mod) |
| 1372 | 1197 | (if args |
| 1377 | 1202 | (check-operator-strictness op mod t)) |
| 1378 | 1203 | (with-output-chaos-error ('no-such-operator) |
| 1379 | 1204 | (princ "no such operator") |
| 1380 | (print-chaos-object parsedop) | |
| 1381 | )) | |
| 1382 | )) | |
| 1205 | (print-chaos-object parsedop))))) | |
| 1383 | 1206 | (check-operator-strictness-whole mod t))))) |
| 1384 | 1207 | |
| 1385 | 1208 | ;; TRS compatibility |
| 1397 | 1220 | (with-output-simple-msg () |
| 1398 | 1221 | (format t ">> module (corresponding TRS) is NOT compatible:") |
| 1399 | 1222 | (dolist (r-ms res) |
| 1400 | (format t "~&- rewrite rule") | |
| 1223 | (format t "~%- rewrite rule") | |
| 1401 | 1224 | (let ((*print-indent* (+ 2 *print-indent*))) |
| 1402 | 1225 | (print-next) |
| 1403 | (print-chaos-object (car r-ms)) | |
| 1404 | ) | |
| 1226 | (print-chaos-object (car r-ms))) | |
| 1405 | 1227 | (format t "~& violates the compatibility,") |
| 1406 | 1228 | (format t "~& and following operator(s) can possibly be affected:") |
| 1407 | 1229 | (let ((*print-indent* (+ 2 *print-indent*))) |
| 1411 | 1233 | (with-output-simple-msg () |
| 1412 | 1234 | (format t ">> module is compatible.")))))) |
| 1413 | 1235 | ;;; |
| 1414 | ;;; | |
| 1415 | ;;; | |
| 1416 | 1236 | (:coherency |
| 1417 | (let ((mod (if *last-module* *last-module* | |
| 1418 | (if *current-module* | |
| 1419 | *current-module* | |
| 1420 | (with-output-chaos-error ('no-context) | |
| 1421 | (princ "no context (current) module.") | |
| 1422 | ))))) | |
| 1423 | ;; | |
| 1237 | (let ((mod (get-context-module))) | |
| 1424 | 1238 | (!setup-reduction mod) |
| 1425 | 1239 | (with-in-module (mod) |
| 1426 | 1240 | (if args |
| 1431 | 1245 | (check-operator-coherency op mod t)) |
| 1432 | 1246 | (with-output-chaos-error ('no-such-operator) |
| 1433 | 1247 | (princ "no such operator") |
| 1434 | (print-chaos-object parsedop) | |
| 1435 | )) | |
| 1436 | )) | |
| 1248 | (print-chaos-object parsedop))))) | |
| 1437 | 1249 | (check-operator-coherency-whole mod))))) |
| 1438 | 1250 | ;; |
| 1439 | 1251 | ;; SENSIBILITY of the signature |
| 1440 | 1252 | ;; |
| 1441 | 1253 | (:sensible |
| 1442 | 1254 | (let ((module (eval-mod-ext args))) |
| 1443 | (unless *chaos-quiet* | |
| 1444 | (with-output-simple-msg () | |
| 1445 | (format t ">> Start sensible check ...") | |
| 1446 | (terpri) | |
| 1447 | (force-output))) | |
| 1448 | (check-sensible module t))) | |
| 1255 | (unless *chaos-quiet* | |
| 1256 | (with-output-simple-msg () | |
| 1257 | (format t ">> Start sensible check ...") | |
| 1258 | (terpri) | |
| 1259 | (force-output))) | |
| 1260 | (check-sensible module t))) | |
| 1449 | 1261 | (:rew-coherence |
| 1450 | 1262 | (let ((module (eval-mod-ext (cdr args)))) |
| 1451 | (let ((r-arg (car args))) | |
| 1452 | (unless (or (equal "coherency" r-arg) | |
| 1453 | (equal "coh" r-arg)) | |
| 1454 | (with-output-chaos-error ('invalid-arg) | |
| 1455 | (format t "check rewriting: Invalid argument ~s" r-arg))) | |
| 1456 | (check-rwl-coherency module)))) | |
| 1263 | (let ((r-arg (car args))) | |
| 1264 | (unless (or (equal "coherency" r-arg) | |
| 1265 | (equal "coh" r-arg)) | |
| 1266 | (with-output-chaos-error ('invalid-arg) | |
| 1267 | (format t "check rewriting: Invalid argument ~s" r-arg))) | |
| 1268 | (check-rwl-coherency module)))) | |
| 1457 | 1269 | |
| 1458 | 1270 | ;; PigNose extention |
| 1459 | 1271 | #+:BigPink |
| 1467 | 1279 | (pn-check-refinement args)) |
| 1468 | 1280 | ;; unknown |
| 1469 | 1281 | (t (with-output-chaos-error ('invalid-arg) |
| 1470 | (format t "unknown option to check: ~a" (%check-what ast)) | |
| 1471 | ))))) | |
| 1282 | (format t "unknown option to check: ~a" (%check-what ast))))))) | |
| 1472 | 1283 | |
| 1473 | 1284 | ;;; ************* |
| 1474 | 1285 | ;;; TRAM COMPILER |
| 1485 | 1296 | ;; first we check the context |
| 1486 | 1297 | (let ((mod (if modexp |
| 1487 | 1298 | (eval-modexp modexp) |
| 1488 | *last-module*))) | |
| 1489 | ;; | |
| 1490 | (when (or (null mod) (modexp-is-error mod)) | |
| 1491 | (if (null mod) | |
| 1492 | (with-output-chaos-error ('no-context) | |
| 1493 | (princ "no module expression provided and no selected(current) module.") | |
| 1494 | ) | |
| 1299 | (get-context-module)))) | |
| 1300 | (when (modexp-is-error mod) | |
| 1495 | 1301 | (with-output-chaos-error ('no-such-module) |
| 1496 | 1302 | (princ "incorrect module expression, no such module ") |
| 1497 | (print-chaos-object modexp) | |
| 1498 | ))) | |
| 1303 | (print-chaos-object modexp))) | |
| 1499 | 1304 | ;; process specified command |
| 1500 | 1305 | (case command |
| 1501 | 1306 | ((:compile :compile-all) |
| 1528 | 1333 | (princ (cadr result))) |
| 1529 | 1334 | (force-output)) |
| 1530 | 1335 | (progn |
| 1531 | (context-push-and-move *last-module* mod) | |
| 1336 | (context-push-and-move (get-context-module t) mod) | |
| 1532 | 1337 | (let ((*print-indent* (+ 4 *print-indent*))) |
| 1533 | 1338 | (with-in-module (mod) |
| 1534 | 1339 | (setq $$term (car result)) |
| 1545 | 1350 | (terpri) |
| 1546 | 1351 | (princ (cadr result))) |
| 1547 | 1352 | (force-output) |
| 1548 | (reset-target-term $$term *last-module* mod))) | |
| 1353 | (reset-target-term $$term (get-context-module t) mod))) | |
| 1549 | 1354 | (context-pop-and-recover))))) |
| 1550 | 1355 | ;; |
| 1551 | 1356 | (otherwise (with-output-panic-message () |
| 1552 | 1357 | (format t "internal error, unknown tram command ~a" |
| 1553 | 1358 | command) |
| 1554 | (chaos-error 'panic)))) | |
| 1555 | ))) | |
| 1359 | (chaos-error 'panic))))))) | |
| 1556 | 1360 | |
| 1557 | 1361 | ;;; ******** |
| 1558 | 1362 | ;;; AUTOLOAD |
| 1563 | 1367 | (let ((entry (assoc modname *autoload-alist* :test #'equal))) |
| 1564 | 1368 | (if entry |
| 1565 | 1369 | (setf (cdr entry) file) |
| 1566 | (push (cons modname file) *autoload-alist*))) | |
| 1567 | )) | |
| 1370 | (push (cons modname file) *autoload-alist*))))) | |
| 1371 | ||
| 1372 | ;;; ************ | |
| 1373 | ;;; NO AUTOLOAD | |
| 1374 | ;;; ************ | |
| 1375 | (defun eval-no-autoload (ast) | |
| 1376 | (let ((modname (%no-autoload-mod-name ast))) | |
| 1377 | (unless (assoc modname *autoload-alist* :test #'equal) | |
| 1378 | (with-output-chaos-warning () | |
| 1379 | (format t "Module ~s is not specified as 'autoload'." modname))) | |
| 1380 | (setq *autoload-alist* | |
| 1381 | (remove-if #'(lambda (x) (equal modname x)) *autoload-alist* | |
| 1382 | :key #'car)))) | |
| 1568 | 1383 | |
| 1569 | 1384 | ;;; ********************* |
| 1570 | 1385 | ;;; MISC SUPOORT ROUTINES |
| 1611 | 1426 | (number-matches 0)) |
| 1612 | 1427 | (let ((mod (if modexp |
| 1613 | 1428 | (eval-modexp modexp) |
| 1614 | *last-module*))) | |
| 1615 | (unless (eq mod *last-module*) | |
| 1429 | (get-context-module t)))) | |
| 1430 | (unless (eq mod (get-context-module t)) | |
| 1616 | 1431 | (clear-term-memo-table *term-memo-table*)) |
| 1617 | 1432 | (when (or (null mod) (modexp-is-error mod)) |
| 1618 | 1433 | (if (null mod) |
| 1621 | 1436 | (with-output-chaos-error ('no-such-module) |
| 1622 | 1437 | (princ "no such module: ") |
| 1623 | 1438 | (print-chaos-object modexp)))) |
| 1624 | ;; | |
| 1625 | (context-push-and-move *last-module* mod) | |
| 1439 | (context-push-and-move (get-context-module t) mod) | |
| 1440 | (when *auto-context-change* | |
| 1441 | (change-context (get-context-module t) mod)) | |
| 1626 | 1442 | (with-in-module (mod) |
| 1627 | (when *auto-context-change* | |
| 1628 | (change-context *last-module* mod)) | |
| 1629 | 1443 | (!setup-reduction mod) |
| 1630 | 1444 | (setq $$mod *current-module*) |
| 1631 | 1445 | (setq sort *cosmos*) |
| 1639 | 1453 | (sort<= (term-sort rhs) *syntax-err-sort* *chaos-sort-order*)) |
| 1640 | 1454 | (context-pop-and-recover) |
| 1641 | 1455 | (return-from eval-cbred nil)) |
| 1642 | (let ((canon (canonicalize-variables (list lhs rhs) mod))) | |
| 1643 | (setq lhs (first canon)) | |
| 1644 | (setq rhs (second canon))) | |
| 1456 | (let ((canon (canonicalize-variables (list lhs rhs) mod))) | |
| 1457 | (setq lhs (first canon)) | |
| 1458 | (setq rhs (second canon))) | |
| 1645 | 1459 | (when *show-stats* |
| 1646 | 1460 | (setq time2 (get-internal-run-time)) |
| 1647 | 1461 | (setq time-for-parse |
| 1655 | 1469 | (print-simple-mod-name *current-module*) |
| 1656 | 1470 | (print-check 0 3) |
| 1657 | 1471 | (princ " : ") |
| 1658 | ;; (print-check) | |
| 1659 | 1472 | (let ((*print-indent* (+ 4 *print-indent*))) |
| 1660 | 1473 | (term-print lhs) |
| 1661 | 1474 | (print-check 0 4) |
| 1662 | 1475 | (princ " == ") |
| 1663 | ;; (print-check) | |
| 1664 | 1476 | (term-print rhs)) |
| 1665 | 1477 | (flush-all)) |
| 1666 | ;; | |
| 1667 | 1478 | (setq $$matches 0) |
| 1668 | 1479 | (setq time1 (get-internal-run-time)) |
| 1669 | 1480 | |
| 1713 | 1524 | (let ((modexp (%inspect-modexp ast)) |
| 1714 | 1525 | mod) |
| 1715 | 1526 | (setf mod (if (null modexp) |
| 1716 | *last-module* | |
| 1527 | (get-context-module) | |
| 1717 | 1528 | (eval-modexp modexp))) |
| 1718 | 1529 | (when (modexp-is-error mod) |
| 1719 | 1530 | (with-output-chaos-error ('no-such-module) |
| 1732 | 1543 | (defun eval-what-is (ast) |
| 1733 | 1544 | (let ((name (%what-is-name ast)) |
| 1734 | 1545 | (modexp (%what-is-module ast)) |
| 1735 | (mod nil)) | |
| 1546 | (mod nil)) | |
| 1736 | 1547 | (setf mod (if (null modexp) |
| 1737 | *last-module* | |
| 1738 | (eval-modexp modexp))) | |
| 1548 | (get-context-module) | |
| 1549 | (eval-modexp modexp))) | |
| 1739 | 1550 | (when (modexp-is-error mod) |
| 1740 | 1551 | (with-output-chaos-error ('no-such-module)) |
| 1741 | 1552 | (princ "incorrect module expression or unknown module: ") |
| 1751 | 1562 | (defun eval-look-up (ast) |
| 1752 | 1563 | (let ((name (%look-up-name ast)) |
| 1753 | 1564 | (modexp (%look-up-module ast)) |
| 1754 | (mod nil)) | |
| 1565 | (mod nil)) | |
| 1755 | 1566 | (setf mod (if (null modexp) |
| 1756 | (or *last-module* | |
| 1757 | (with-output-chaos-error ('no-context) | |
| 1758 | (format t "~%No context module is set."))) | |
| 1759 | (eval-modexp modexp))) | |
| 1567 | (get-context-module) | |
| 1568 | (eval-modexp modexp))) | |
| 1760 | 1569 | (when (modexp-is-error mod) |
| 1761 | 1570 | (with-output-chaos-error ('no-such-module) |
| 1762 | (princ "incorrect module expression or unknown module: ") | |
| 1763 | (print-modexp modexp))) | |
| 1571 | (princ "incorrect module expression or unknown module: ") | |
| 1572 | (print-modexp modexp))) | |
| 1764 | 1573 | ;; |
| 1765 | 1574 | (!look-up name mod))) |
| 1766 | 1575 | |
| 1769 | 1578 | ;;; |
| 1770 | 1579 | (defun eval-delimiter (ast) |
| 1771 | 1580 | (let ((op (%delimiter-operation ast)) |
| 1772 | (chars (%delimiter-char-list ast))) | |
| 1581 | (chars (%delimiter-char-list ast))) | |
| 1773 | 1582 | (case op |
| 1774 | 1583 | ((:set :add) (!force-single-reader chars)) |
| 1775 | 1584 | ((:delete) (!unset-single-reader chars)) |
| 1776 | 1585 | (otherwise (with-output-chaos-error ('internal) |
| 1777 | (format t "Internal error, invalid delimiter operation ~s" op)))))) | |
| 1586 | (format t "Internal error, invalid delimiter operation ~s" op)))))) | |
| 1778 | 1587 | |
| 1779 | 1588 | ;;; ******************* |
| 1780 | 1589 | ;;; Chaos Top |
| 1845 | 1654 | ;; (cafeobj-input file) |
| 1846 | 1655 | (when *eval-ast* |
| 1847 | 1656 | (unless (or (at-top-level) *cafeobj-input-quiet*) |
| 1848 | (format t "~&-- done reading in file: ~a~%" (namestring file))))) | |
| 1657 | (format t "~%-- done reading in file: ~a~%" (namestring file))))) | |
| 1849 | 1658 | |
| 1850 | 1659 | ;;; *********** |
| 1851 | 1660 | ;;; SAVE-SYSTEM |
| 1914 | 1723 | ;;; DELIMITER |
| 1915 | 1724 | (defun eval-delimiter-proc (pre-args) |
| 1916 | 1725 | (declare (type list pre-args) |
| 1917 | (values t)) | |
| 1726 | (values t)) | |
| 1918 | 1727 | (let ((args nil) |
| 1919 | (op nil) | |
| 1920 | (ast nil)) | |
| 1728 | (op nil) | |
| 1729 | (ast nil)) | |
| 1921 | 1730 | (case-equal (the simple-string (second pre-args)) |
| 1922 | ("=" (setq op :set)) | |
| 1923 | ("+" (setq op :add)) | |
| 1924 | ("-" (setq op :delete)) | |
| 1925 | (t (with-output-chaos-error ('internal) | |
| 1926 | (format t "delimiter op given ivalid op ~a" (second pre-args))))) | |
| 1731 | ("=" (setq op :set)) | |
| 1732 | ("+" (setq op :add)) | |
| 1733 | ("-" (setq op :delete)) | |
| 1734 | (t (with-output-chaos-error ('internal) | |
| 1735 | (format t "delimiter op given ivalid op ~a" (second pre-args))))) | |
| 1927 | 1736 | (setq pre-args (fourth pre-args)) |
| 1928 | 1737 | (dolist (a pre-args) |
| 1929 | 1738 | (push a args)) |
| 0 | 0 | ;;;-*- Mode:LISP; Package:CHAOS; Base:10; Syntax:Common-lisp -*- |
| 1 | 1 | ;;; |
| 2 | ;;; Copyright (c) 2000-2014, Toshimi Sawada. All rights reserved. | |
| 2 | ;;; Copyright (c) 2000-2015, Toshimi Sawada. All rights reserved. | |
| 3 | 3 | ;;; |
| 4 | 4 | ;;; Redistribution and use in source and binary forms, with or without |
| 5 | 5 | ;;; modification, are permitted provided that the following conditions |
| 27 | 27 | ;;; |
| 28 | 28 | (in-package :chaos) |
| 29 | 29 | #|============================================================================== |
| 30 | System: CHAOS | |
| 31 | Module: eval | |
| 32 | File: eval-mod.lisp | |
| 30 | System: CHAOS | |
| 31 | Module: eval | |
| 32 | File: eval-mod.lisp | |
| 33 | 33 | ==============================================================================|# |
| 34 | 34 | #-:chaos-debug |
| 35 | 35 | (declaim (optimize (speed 3) (safety 0) #-GCL (debug 0))) |
| 46 | 46 | ;;; |
| 47 | 47 | (defun modexp-top-level-eval (modexp) |
| 48 | 48 | (let ((meparse (parse-modexp modexp))) |
| 49 | (if (equal "THE-LAST-MODULE" meparse) | |
| 50 | (if *last-module* | |
| 51 | *last-module* | |
| 52 | (with-output-chaos-error ('no-context) | |
| 53 | (princ "no context (current) module") | |
| 54 | )) | |
| 55 | (eval-modexp-top (normalize-modexp meparse))) | |
| 56 | )) | |
| 49 | (eval-modexp-top (normalize-modexp meparse)))) | |
| 57 | 50 | |
| 58 | 51 | ;;; EVAL-MOD |
| 59 | 52 | ;;; similar to MODEXP-TOP-LEVEL-EVAL. |
| 61 | 54 | ;;; |
| 62 | 55 | (defun eval-mod (toks &optional (change-context *auto-context-change*)) |
| 63 | 56 | (if (null toks) |
| 64 | (if *last-module* | |
| 65 | *last-module* | |
| 66 | (with-output-chaos-error ('no-context) | |
| 67 | (princ "no selected(current) module.") | |
| 68 | )) | |
| 69 | (if (equal '("%") toks) | |
| 70 | (if *open-module* | |
| 71 | (let ((mod (find-module-in-env (normalize-modexp "%")))) | |
| 72 | (unless mod | |
| 73 | (with-output-panic-message () | |
| 74 | (princ "could not find % module!!!!") | |
| 75 | (chaos-error 'panic))) | |
| 76 | (when change-context | |
| 77 | (change-context *last-module* mod)) | |
| 78 | mod) | |
| 79 | (with-output-chaos-warning () | |
| 80 | (princ "no module is opening.") | |
| 81 | (chaos-error 'no-open-module))) | |
| 82 | (let ((val (modexp-top-level-eval toks))) | |
| 83 | (if (modexp-is-error val) | |
| 84 | (if (and (null (cdr toks)) | |
| 85 | (<= 4 (length (car toks))) | |
| 86 | (equal "MOD" (subseq (car toks) 0 3))) | |
| 87 | (let ((val (read-from-string (subseq (car toks) 3)))) | |
| 88 | (if (integerp val) | |
| 89 | (let ((nmod (print-nth-mod val))) ;;; !!! | |
| 90 | (when change-context | |
| 91 | (change-context *last-module* nmod)) | |
| 92 | nmod) | |
| 93 | (with-output-chaos-error ('no-such-module) | |
| 94 | (format t "could not evaluate the modexp ~a" toks) | |
| 95 | ))) | |
| 96 | (with-output-chaos-error ('no-such-module) | |
| 97 | (format t "undefined module? ~a" toks) | |
| 98 | )) | |
| 99 | (progn | |
| 100 | (when change-context | |
| 101 | (change-context *last-module* val)) | |
| 102 | val)))))) | |
| 57 | (get-context-module) | |
| 58 | (if (equal '("%") toks) | |
| 59 | (if *open-module* | |
| 60 | (let ((mod (find-module-in-env (normalize-modexp "%")))) | |
| 61 | (unless mod | |
| 62 | (with-output-panic-message () | |
| 63 | (princ "could not find % module!!!!") | |
| 64 | (chaos-error 'panic))) | |
| 65 | (when change-context | |
| 66 | (change-context (get-context-module t) mod)) | |
| 67 | mod) | |
| 68 | (with-output-chaos-warning () | |
| 69 | (princ "no module is opening.") | |
| 70 | (chaos-error 'no-open-module))) | |
| 71 | (let ((val (modexp-top-level-eval toks))) | |
| 72 | (if (modexp-is-error val) | |
| 73 | (if (and (null (cdr toks)) | |
| 74 | (<= 4 (length (car toks))) | |
| 75 | (equal "MOD" (subseq (car toks) 0 3))) | |
| 76 | (let ((val (read-from-string (subseq (car toks) 3)))) | |
| 77 | (if (integerp val) | |
| 78 | (let ((nmod (print-nth-mod val))) ;;; !!! | |
| 79 | (when change-context | |
| 80 | (change-context (get-context-module t) nmod)) | |
| 81 | nmod) | |
| 82 | (with-output-chaos-error ('no-such-module) | |
| 83 | (format t "could not evaluate the modexp ~a" toks)))) | |
| 84 | (with-output-chaos-error ('no-such-module) | |
| 85 | (format t "undefined module? ~a" toks))) | |
| 86 | (progn | |
| 87 | (when change-context | |
| 88 | (change-context (get-context-module t) val)) | |
| 89 | val)))))) | |
| 103 | 90 | |
| 104 | 91 | ;;; what to do with this one? |
| 105 | 92 | |
| 113 | 100 | ;;; "param" --- parameter |
| 114 | 101 | ;;; |
| 115 | 102 | (defun eval-mod-ext (toks &optional |
| 116 | (change-context *auto-context-change* force?)) | |
| 103 | (change-context *auto-context-change* force?)) | |
| 117 | 104 | (when (equal toks ".") |
| 118 | 105 | (setq toks nil)) |
| 119 | 106 | (when (and (listp toks) |
| 120 | (equal (car (last toks)) ".")) | |
| 107 | (equal (car (last toks)) ".")) | |
| 121 | 108 | (setq toks (butlast toks))) |
| 122 | 109 | (let ((it (car toks))) |
| 123 | 110 | (when (equal it ".") |
| 124 | 111 | (setq it nil) |
| 125 | 112 | (setq toks nil)) |
| 126 | 113 | (cond ((and (equal "sub" it) |
| 127 | (cadr toks) | |
| 128 | (parse-integer (cadr toks) :junk-allowed t)) | |
| 129 | (let* ((no (read-from-string (cadr toks))) | |
| 130 | (mod (eval-mod-ext (cddr toks) nil)) | |
| 131 | (sub (nth-sub (1- no) mod))) | |
| 132 | (if sub | |
| 133 | (when change-context | |
| 134 | (change-context *last-module* sub)) | |
| 135 | (progn (princ "** Waring : No such sub-module") (terpri) nil)))) | |
| 136 | ((and (equal "param" it) | |
| 137 | (cadr toks) | |
| 138 | (parse-integer (cadr toks) :junk-allowed t)) | |
| 139 | (let* ((no (read-from-string (cadr toks))) | |
| 140 | (mod (eval-mod-ext (cddr toks) nil)) | |
| 141 | (params (module-parameters mod)) | |
| 142 | (param (nth (1- no) params))) | |
| 143 | (if param | |
| 144 | (when change-context | |
| 145 | (change-context *last-module* (cdr param))) | |
| 146 | (with-output-chaos-error ('no-such-parameter) | |
| 147 | (princ "No such parameter") | |
| 148 | )))) | |
| 149 | ((and (null toks) change-context force?) | |
| 150 | (when *last-module* | |
| 151 | (change-context *last-module* nil))) | |
| 152 | (t (eval-mod toks change-context)) | |
| 153 | ))) | |
| 114 | (cadr toks) | |
| 115 | (parse-integer (cadr toks) :junk-allowed t)) | |
| 116 | (let* ((no (read-from-string (cadr toks))) | |
| 117 | (mod (eval-mod-ext (cddr toks) nil)) | |
| 118 | (sub (nth-sub (1- no) mod))) | |
| 119 | (if sub | |
| 120 | (when change-context | |
| 121 | (change-context (get-context-module t) sub)) | |
| 122 | (progn (princ "** Waring : No such sub-module") (terpri) nil)))) | |
| 123 | ((and (equal "param" it) | |
| 124 | (cadr toks) | |
| 125 | (parse-integer (cadr toks) :junk-allowed t)) | |
| 126 | (let* ((no (read-from-string (cadr toks))) | |
| 127 | (mod (eval-mod-ext (cddr toks) nil)) | |
| 128 | (params (module-parameters mod)) | |
| 129 | (param (nth (1- no) params))) | |
| 130 | (if param | |
| 131 | (when change-context | |
| 132 | (change-context (get-context-module t) (cdr param))) | |
| 133 | (with-output-chaos-error ('no-such-parameter) | |
| 134 | (princ "No such parameter") | |
| 135 | )))) | |
| 136 | ((and (null toks) change-context force?) | |
| 137 | (when (get-context-module t) | |
| 138 | (change-context (get-context-module) nil))) | |
| 139 | (t (eval-mod toks change-context))))) | |
| 154 | 140 | |
| 155 | 141 | ;;; EOF |
| 0 | 0 | ;;;-*-Mode:LISP; Package: CHAOS; Base:10; Syntax:Common-lisp -*- |
| 1 | 1 | ;;; |
| 2 | ;;; Copyright (c) 2000-2014, Toshimi Sawada. All rights reserved. | |
| 2 | ;;; Copyright (c) 2000-2015, Toshimi Sawada. All rights reserved. | |
| 3 | 3 | ;;; |
| 4 | 4 | ;;; Redistribution and use in source and binary forms, with or without |
| 5 | 5 | ;;; modification, are permitted provided that the following conditions |
| 143 | 143 | ;;; |
| 144 | 144 | ;;; SHOW-FMOD* |
| 145 | 145 | ;;; |
| 146 | (defun show-fmod* (&optional (module (or *last-module* | |
| 147 | *current-module*))) | |
| 146 | (defun show-fmod* (&optional (module (get-context-module))) | |
| 148 | 147 | (let ((trs (get-module-trs module))) |
| 149 | ;; | |
| 150 | 148 | (princ "fmod ") |
| 151 | 149 | (print-mod-name module *standard-output* nil t) |
| 152 | 150 | (princ " is ") |
| 0 | 0 | ;;;-*- Mode:LISP; Package:CHAOS; Base:10; Syntax:Common-lisp -*- |
| 1 | 1 | ;;; |
| 2 | ;;; Copyright (c) 2000-2014, Toshimi Sawada. All rights reserved. | |
| 2 | ;;; Copyright (c) 2000-2015, Toshimi Sawada. All rights reserved. | |
| 3 | 3 | ;;; |
| 4 | 4 | ;;; Redistribution and use in source and binary forms, with or without |
| 5 | 5 | ;;; modification, are permitted provided that the following conditions |
| 27 | 27 | ;;; |
| 28 | 28 | (in-package :chaos) |
| 29 | 29 | #|============================================================================== |
| 30 | System: CHAOS | |
| 31 | Module: primitives | |
| 32 | File: absntax.lisp | |
| 30 | System: CHAOS | |
| 31 | Module: primitives | |
| 32 | File: absntax.lisp | |
| 33 | 33 | ==============================================================================|# |
| 34 | 34 | #-:chaos-debug |
| 35 | 35 | (declaim (optimize (speed 3) (safety 0) #-GCL (debug 0))) |
| 95 | 95 | ;;; :import-decl |
| 96 | 96 | ;;; / \ |
| 97 | 97 | ;;; :protecting :modexp |
| 98 | ;;; | | |
| 99 | ;;; "INT" | |
| 98 | ;;; | | |
| 99 | ;;; "INT" | |
| 100 | 100 | ;;; |
| 101 | 101 | ;;; where, :import-decl is a type tag which indicates this tree represents a |
| 102 | 102 | ;;; <ModuleImportation>. :protecting is an example of usage of `symbol' in tree, |
| 175 | 175 | ;;; |
| 176 | 176 | (defterm sort-ref (%ast) |
| 177 | 177 | :visible (name &optional qualifier) |
| 178 | :eval find-qual-sort ; the default meaning. | |
| 178 | :eval find-qual-sort ; the default meaning. | |
| 179 | 179 | :print print-sort-ref) |
| 180 | 180 | |
| 181 | 181 | (defun may-be-error-sort-ref? (ref) |
| 182 | 182 | (let ((name nil)) |
| 183 | 183 | (cond ((%is-sort-ref ref) (setq name (%sort-ref-name ref))) |
| 184 | ((symbolp ref) (setq name (string ref))) | |
| 185 | ((stringp ref) (setq name ref)) | |
| 186 | (t (with-output-panic-message () | |
| 187 | (format t "invalid sort reference ~a" ref) | |
| 188 | (chaos-error 'panic)))) | |
| 184 | ((symbolp ref) (setq name (string ref))) | |
| 185 | ((stringp ref) (setq name ref)) | |
| 186 | (t (with-output-panic-message () | |
| 187 | (format t "invalid sort reference ~a" ref) | |
| 188 | (chaos-error 'panic)))) | |
| 189 | 189 | (eql #\? (schar name 0)))) |
| 190 | ||
| 190 | ||
| 191 | 191 | ;;; * NOTE * |
| 192 | 192 | ;;; 1. As described above, the meaning of `sort-ref' is overloaded, this is |
| 193 | 193 | ;;; because of a feature of CafeOBJ for relaxing a restriction of subsort |
| 205 | 205 | ;;; representation = (%sort-decl name) |
| 206 | 206 | ;;; |
| 207 | 207 | (defterm sort-decl (%ast) |
| 208 | :visible (name ; one of string, symbol, | |
| 209 | ; ast `:sort-ref'. | |
| 210 | &optional hidden) ; non-nil iff hidden sorts. | |
| 208 | :visible (name ; one of string, symbol, | |
| 209 | ; ast `:sort-ref'. | |
| 210 | &optional hidden) ; non-nil iff hidden sorts. | |
| 211 | 211 | :eval declare-sort |
| 212 | 212 | :print print-sort-decl) |
| 213 | 213 | |
| 220 | 220 | ;;; |
| 221 | 221 | (defterm bsort-decl (%ast) |
| 222 | 222 | :visible (name token-predicate term-creator |
| 223 | term-printer term-predicate | |
| 224 | hidden) | |
| 223 | term-printer term-predicate | |
| 224 | hidden) | |
| 225 | 225 | :eval declare-bsort |
| 226 | 226 | :print print-bsort-decl) |
| 227 | 227 | |
| 378 | 378 | ;;; LET Declaration____________________________________________________________ |
| 379 | 379 | ;;; |
| 380 | 380 | (defterm let (%ast) |
| 381 | :visible (sym ; name | |
| 382 | value) ; value (pre-term). | |
| 381 | :visible (sym ; name | |
| 382 | value) ; value (pre-term). | |
| 383 | 383 | :eval eval-let |
| 384 | 384 | :print print-let-decl) |
| 385 | 385 | |
| 435 | 435 | :eval find-qual-rrule) |
| 436 | 436 | |
| 437 | 437 | ;;;============================================================================= |
| 438 | ;;; MODULE IMPORTATION | |
| 438 | ;;; MODULE IMPORTATION | |
| 439 | 439 | ;;;============================================================================= |
| 440 | 440 | |
| 441 | 441 | ;;; IMPORT DECLARATION__________________________________________________________ |
| 449 | 449 | :print print-import-decl) |
| 450 | 450 | |
| 451 | 451 | ;;;============================================================================= |
| 452 | ;;; SIGNATURE, AXIOM, MODULE | |
| 452 | ;;; SIGNATURE, AXIOM, MODULE | |
| 453 | 453 | ;;;============================================================================= |
| 454 | 454 | |
| 455 | 455 | ;;; SIGNATURE___________________________________________________________________ |
| 0 | 0 | ;;;-*- Mode:LISP; Package: Chaos; Base:10; Syntax:Common-lisp -*- |
| 1 | 1 | ;;; |
| 2 | ;;; Copyright (c) 2000-2014, Toshimi Sawada. All rights reserved. | |
| 2 | ;;; Copyright (c) 2000-2015, Toshimi Sawada. All rights reserved. | |
| 3 | 3 | ;;; |
| 4 | 4 | ;;; Redistribution and use in source and binary forms, with or without |
| 5 | 5 | ;;; modification, are permitted provided that the following conditions |
| 27 | 27 | ;;; |
| 28 | 28 | (in-package :chaos) |
| 29 | 29 | #|============================================================================== |
| 30 | System: Chaos | |
| 31 | Module: primitives | |
| 32 | File: baxiom.lisp | |
| 30 | System: Chaos | |
| 31 | Module: primitives | |
| 32 | File: baxiom.lisp | |
| 33 | 33 | ==============================================================================|# |
| 34 | 34 | #-:chaos-debug |
| 35 | 35 | (declaim (optimize (speed 3) (safety 0) #-GCL (debug 0))) |
| 41 | 41 | ;;; **************************************************************************** |
| 42 | 42 | |
| 43 | 43 | ;;;============================================================================= |
| 44 | ;;; AXIOM/REWRITE RULE | |
| 44 | ;;; AXIOM/REWRITE RULE | |
| 45 | 45 | ;;;============================================================================= |
| 46 | 46 | |
| 47 | 47 | ;;; ************ |
| 48 | 48 | ;;; REWRITE RULE : internal use only |
| 49 | 49 | ;;; ************ |
| 50 | 50 | |
| 51 | #|| | |
| 52 | (defterm rewrite-rule (object) | |
| 53 | :visible (type ; type, either ':equation or ':rule | |
| 54 | lhs ; | |
| 55 | rhs | |
| 56 | condition | |
| 57 | behavioural | |
| 58 | id-condition | |
| 59 | first-match-method | |
| 60 | next-match-method | |
| 61 | labels | |
| 62 | trace-flag) | |
| 63 | :int-printer print-rule-object | |
| 64 | :print print-rule-internal) | |
| 65 | ||# | |
| 66 | ||
| 67 | 51 | (defstruct (rewrite-rule (:include object (-type 'rewreite-rule)) |
| 68 | (:copier nil) | |
| 69 | (:constructor make-rewrite-rule) | |
| 70 | (:constructor | |
| 71 | rewrite-rule* (type lhs rhs condition behavioural | |
| 72 | id-condition first-match-method | |
| 73 | next-match-method labels | |
| 74 | trace-flag | |
| 75 | )) | |
| 76 | (:print-function print-rule-object)) | |
| 77 | (type nil :type symbol) ; type, either ':equation or ':rule | |
| 52 | (:copier nil) | |
| 53 | (:constructor make-rewrite-rule) | |
| 54 | (:constructor | |
| 55 | rewrite-rule* (type lhs rhs condition behavioural | |
| 56 | id-condition first-match-method | |
| 57 | next-match-method labels | |
| 58 | trace-flag | |
| 59 | )) | |
| 60 | (:print-function print-rule-object)) | |
| 61 | (type nil :type symbol) ; type, either ':equation or ':rule | |
| 78 | 62 | (lhs nil :type (or null term)) |
| 79 | 63 | (rhs nil :type (or null term)) |
| 80 | 64 | (condition nil :type (or null term)) |
| 86 | 70 | (trace-flag nil :type (or null t)) |
| 87 | 71 | (need-copy nil :type (or null t)) |
| 88 | 72 | (non-exec nil :type (or null t)) |
| 89 | (meta-and-or nil :type (or null t)) ; :m-and or :m-or | |
| 73 | (meta-and-or nil :type (or null t)) ; :m-and or :m-or | |
| 90 | 74 | ) |
| 91 | 75 | |
| 92 | 76 | (eval-when (:execute :load-toplevel) |
| 93 | 77 | (setf (get 'rewrite-rule :type-predicate) |
| 94 | (symbol-function 'rewrite-rule-p)) | |
| 78 | (symbol-function 'rewrite-rule-p)) | |
| 95 | 79 | (setf (symbol-function 'is-rewrite-rule) |
| 96 | (symbol-function 'rewrite-rule-p)) | |
| 80 | (symbol-function 'rewrite-rule-p)) | |
| 97 | 81 | (setf (get 'rewrite-rule :print) 'print-rule-internal)) |
| 98 | 82 | |
| 99 | 83 | (defun print-rule-object (obj stream &rest ignore) |
| 100 | 84 | (declare (ignore ignore)) |
| 101 | 85 | (if *current-module* |
| 102 | 86 | (progn |
| 103 | (format stream ":rule[~S: " (addr-of obj)) | |
| 104 | (print-axiom-brief obj stream) | |
| 105 | (format stream "]")) | |
| 87 | (format stream ":rule[~S: " (addr-of obj)) | |
| 88 | (print-axiom-brief obj stream) | |
| 89 | (format stream "]")) | |
| 106 | 90 | (format stream ":rule[~a]" (rewrite-rule-type obj)))) |
| 107 | 91 | |
| 108 | 92 | ;;; |
| 114 | 98 | (defmacro rule-condition (_rule) `(rewrite-rule-condition ,_rule)) |
| 115 | 99 | (defmacro rule-id-condition (_rule) `(rewrite-rule-id-condition ,_rule)) |
| 116 | 100 | (defmacro rule-first-match-method (_rule) `(rewrite-rule-first-match-method |
| 117 | ,_rule)) | |
| 101 | ,_rule)) | |
| 118 | 102 | (defmacro rule-next-match-method (_rule) `(rewrite-rule-next-match-method |
| 119 | ,_rule)) | |
| 103 | ,_rule)) | |
| 120 | 104 | (defmacro rule-labels (_rule) `(rewrite-rule-labels ,_rule)) |
| 121 | 105 | (defmacro rule-is-behavioural (_rule) `(rewrite-rule-behavioural ,_rule)) |
| 122 | 106 | (defmacro rule-trace-flag (_rule) `(rewrite-rule-trace-flag ,_rule)) |
| 126 | 110 | |
| 127 | 111 | ;;; Extended rewrite rule |
| 128 | 112 | ;;; |
| 129 | #|| | |
| 130 | (defterm ex-rewrite-rule (rewrite-rule) | |
| 131 | :visible (type | |
| 132 | lhs | |
| 133 | rhs | |
| 134 | condition | |
| 135 | behavioural | |
| 136 | id-condition | |
| 137 | first-match-method | |
| 138 | next-match-method | |
| 139 | extensions) | |
| 140 | :int-printer print-rule-object | |
| 141 | :print print-rule-internal) | |
| 142 | ||# | |
| 143 | 113 | |
| 144 | 114 | (defstruct (ex-rewrite-rule (:include rewrite-rule (-type 'ex-rewrite-rule)) |
| 145 | (:copier nil) | |
| 146 | (:print-function print-rule-object) | |
| 147 | (:constructor make-ex-rewrite-rule) | |
| 148 | (:constructor | |
| 149 | ex-rewrite-rule* (type lhs rhs condition | |
| 150 | behavioural id-condition | |
| 151 | first-match-method | |
| 152 | next-match-method | |
| 153 | extensions))) | |
| 115 | (:copier nil) | |
| 116 | (:print-function print-rule-object) | |
| 117 | (:constructor make-ex-rewrite-rule) | |
| 118 | (:constructor | |
| 119 | ex-rewrite-rule* (type lhs rhs condition | |
| 120 | behavioural id-condition | |
| 121 | first-match-method | |
| 122 | next-match-method | |
| 123 | extensions))) | |
| 154 | 124 | (extensions nil :type list)) |
| 155 | 125 | |
| 156 | 126 | (eval-when (:execute :load-toplevel) |
| 157 | 127 | (setf (get 'ex-rewrite-rule :type-predicate) |
| 158 | (symbol-function 'ex-rewrite-rule-p)) | |
| 128 | (symbol-function 'ex-rewrite-rule-p)) | |
| 159 | 129 | (setf (symbol-function 'is-ex-rewrite-rule) |
| 160 | (symbol-function 'ex-rewrite-rule-p)) | |
| 130 | (symbol-function 'ex-rewrite-rule-p)) | |
| 161 | 131 | (setf (get 'ex-rewrite-rule :print) |
| 162 | 'print-rule-internal)) | |
| 132 | 'print-rule-internal)) | |
| 163 | 133 | |
| 164 | 134 | (defmacro rule-extensions (_rule) `(ex-rewrite-rule-extensions ,_rule)) |
| 165 | 135 | |
| 169 | 139 | `(and (chaos-object? ,_*_obj) |
| 170 | 140 | (memq (object-type ,_*_obj) '(rewrite-rule ex-rewrite-rule))))) |
| 171 | 141 | |
| 172 | (defmacro is-rewrite-rule? (*--obj) ; synonym | |
| 142 | (defmacro is-rewrite-rule? (*--obj) ; synonym | |
| 173 | 143 | `(rewrite-rule-p ,*--obj)) |
| 174 | 144 | |
| 175 | 145 | ;;; CONSTRUCTOR |
| 176 | 146 | ;;; |
| 177 | 147 | (defmacro create-rewrite-rule (type lhs rhs condition behavioural |
| 178 | id-condition first-match-method | |
| 179 | next-match-method extensions | |
| 180 | &optional (meta-and-or nil)) | |
| 148 | id-condition first-match-method | |
| 149 | next-match-method extensions | |
| 150 | &optional (meta-and-or nil)) | |
| 181 | 151 | ` (create-ex-rewrite-rule ,type |
| 182 | ,lhs | |
| 183 | ,rhs | |
| 184 | ,condition | |
| 185 | ,behavioural | |
| 186 | ,id-condition | |
| 187 | ,first-match-method | |
| 188 | ,next-match-method | |
| 189 | ,extensions | |
| 190 | ,meta-and-or)) | |
| 152 | ,lhs | |
| 153 | ,rhs | |
| 154 | ,condition | |
| 155 | ,behavioural | |
| 156 | ,id-condition | |
| 157 | ,first-match-method | |
| 158 | ,next-match-method | |
| 159 | ,extensions | |
| 160 | ,meta-and-or)) | |
| 191 | 161 | |
| 192 | 162 | ;;; ***** |
| 193 | 163 | ;;; AXIOM________________________________________________________________________ |
| 194 | 164 | ;;; ***** |
| 195 | 165 | ;;; definition of axiom structure. |
| 196 | 166 | ;;; |
| 197 | #|| | |
| 198 | ||
| 199 | (defterm axiom (rewrite-rule) | |
| 200 | :visible (type ; :equation, :rule | |
| 201 | lhs ; left hand side. | |
| 202 | rhs ; right hand side. | |
| 203 | condition ; condition | |
| 204 | behavioural ; t iff axiom is behavioural | |
| 205 | ) | |
| 206 | :hidden (kind ; internaly categorized kind name of an | |
| 207 | ;; ac-extension : | |
| 208 | ;; a-extensions : these are now local to module. | |
| 209 | ) | |
| 210 | :int-printer print-axiom-object | |
| 211 | :print print-axiom-internal | |
| 212 | ) | |
| 213 | ||
| 214 | ||# | |
| 215 | ||
| 216 | 167 | (defstruct (axiom (:include rewrite-rule (-type 'axiom)) |
| 217 | (:copier nil) | |
| 218 | (:constructor make-axiom) | |
| 219 | (:constructor | |
| 220 | axiom* (type lhs rhs condition behavioural)) | |
| 221 | (:print-function print-axiom-object)) | |
| 222 | (kind nil :type symbol) ; internaly categorized kind name of an | |
| 168 | (:copier nil) | |
| 169 | (:constructor make-axiom) | |
| 170 | (:constructor | |
| 171 | axiom* (type lhs rhs condition behavioural)) | |
| 172 | (:print-function print-axiom-object)) | |
| 173 | (kind nil :type symbol) ; internaly categorized kind name of an | |
| 223 | 174 | ) |
| 224 | 175 | |
| 225 | 176 | (eval-when (:execute :load-toplevel) |
| 228 | 179 | (setf (symbol-function 'is-axiom) (symbol-function 'axiom-p)) |
| 229 | 180 | ) |
| 230 | 181 | |
| 231 | #|| | |
| 232 | (defstruct (axiom-exts (:type list)) | |
| 233 | (ac-extension nil) | |
| 234 | (a-extensions nil)) | |
| 235 | ||# | |
| 236 | ||
| 237 | 182 | (defun print-axiom-object (obj stream &rest ignore) |
| 238 | 183 | (declare (ignore ignore)) |
| 239 | 184 | (if *current-module* |
| 240 | 185 | (with-in-module (*current-module*) |
| 241 | (print-axiom-brief obj stream nil nil t)) | |
| 186 | (print-axiom-brief obj stream nil nil t)) | |
| 242 | 187 | (format stream ":axiom[~S]" (addr-of obj)))) |
| 243 | 188 | |
| 244 | 189 | ;;; Type predicate ------------------------------------------------------------- |
| 247 | 192 | |
| 248 | 193 | ;;; Primitive structure accessors ---------------------------------------------- |
| 249 | 194 | |
| 250 | ;;; (defmacro axiom-lhs (_a) `(%axiom-lhs ,_a)) | |
| 251 | ;;; (defmacro axiom-rhs (_a) `(%axiom-rhs ,_a)) | |
| 252 | ;;; (defmacro axiom-condition (_a) `(%axiom-condition ,_a)) | |
| 253 | ;;; (defmacro axiom-type (_a) `(%axiom-type ,_a)) | |
| 254 | ;;; (defmacro axiom-id-condition (_a) `(%axiom-id-condition ,_a)) | |
| 255 | ;;; (defmacro axiom-ac-extension (_a) `(%axiom-ac-extension ,_a)) | |
| 256 | ;;; (defmacro axiom-a-extensions (_a) `(%axiom-a-extensions ,_a)) | |
| 257 | ;;; (defmacro axiom-kind (_a) `(%axiom-kind ,_a)) | |
| 258 | ;;; (defmacro axiom-first-match-method (_a) `(%axiom-first-match-method ,_a)) | |
| 259 | ;;; (defmacro axiom-next-match-method (_a) `(%axiom-next-match-method ,_a)) | |
| 260 | ;;; (defmacro axiom-labels (_a) `(%axiom-labels ,_a)) | |
| 261 | ||
| 262 | 195 | (defmacro axiom-is-behavioural (_a) `(axiom-behavioural ,_a)) |
| 263 | 196 | |
| 264 | 197 | (defmacro axiom-is-for-cr (_a) `(object-info ,_a :cr)) |
| 266 | 199 | (defmacro axiom-contains-match-op (_a) `(object-info ,_a :match-op)) |
| 267 | 200 | |
| 268 | 201 | (defun axiom-extensions (_x &optional (_ext-rule-table |
| 269 | *current-ext-rule-table*)) | |
| 202 | *current-ext-rule-table*)) | |
| 270 | 203 | (declare (type axiom _x) |
| 271 | (type symbol _ext-rule-table) | |
| 272 | (values list)) | |
| 204 | (type symbol _ext-rule-table) | |
| 205 | (values list)) | |
| 273 | 206 | (cdr (assq _x (get _ext-rule-table :ext-rules)))) |
| 274 | 207 | |
| 275 | 208 | (defsetf axiom-extensions (_x &optional (_ext-rule-table |
| 276 | '*current-ext-rule-table*)) | |
| 209 | '*current-ext-rule-table*)) | |
| 277 | 210 | (_value) |
| 278 | 211 | ` (let* ((axiom ,_x) |
| 279 | (rule-table (get ,_ext-rule-table :ext-rules)) | |
| 280 | (pre (assq axiom rule-table)) | |
| 281 | (extensions ,_value)) | |
| 212 | (rule-table (get ,_ext-rule-table :ext-rules)) | |
| 213 | (pre (assq axiom rule-table)) | |
| 214 | (extensions ,_value)) | |
| 282 | 215 | (if pre |
| 283 | (setf (cdr pre) extensions) | |
| 284 | (if rule-table | |
| 285 | (setf (get ,_ext-rule-table :ext-rules) | |
| 286 | (nconc rule-table (list (cons axiom extensions)))) | |
| 287 | (setf (get ,_ext-rule-table :ext-rules) | |
| 288 | (list (cons axiom extensions))))) | |
| 216 | (setf (cdr pre) extensions) | |
| 217 | (if rule-table | |
| 218 | (setf (get ,_ext-rule-table :ext-rules) | |
| 219 | (nconc rule-table (list (cons axiom extensions)))) | |
| 220 | (setf (get ,_ext-rule-table :ext-rules) | |
| 221 | (list (cons axiom extensions))))) | |
| 289 | 222 | extensions)) |
| 290 | 223 | |
| 291 | ;; the following two macros are now just a synonym to axiom-extensions | |
| 292 | #|| | |
| 293 | 224 | (defmacro axiom-ac-extension (_x &optional |
| 294 | (ext-rule-table '*current-ext-rule-table*)) | |
| 295 | `(axiom-exts-ac-extension (gethash ,_x ,ext-rule-table))) | |
| 225 | (_ext-rule-table '*current-ext-rule-table*)) | |
| 226 | `(axiom-extensions ,_x ,_ext-rule-table)) | |
| 296 | 227 | |
| 297 | 228 | (defmacro axiom-a-extensions (_x &optional |
| 298 | (ext-rule-table '*current-ext-rule-table*)) | |
| 299 | `(axiom-exts-a-extensions (gethash ,_x ,ext-rule-table))) | |
| 300 | ||
| 301 | ||# | |
| 302 | (defmacro axiom-ac-extension (_x &optional | |
| 303 | (_ext-rule-table '*current-ext-rule-table*)) | |
| 304 | `(axiom-extensions ,_x ,_ext-rule-table)) | |
| 305 | ||
| 306 | (defmacro axiom-a-extensions (_x &optional | |
| 307 | (_ext-rule-table '*current-ext-rule-table*)) | |
| 229 | (_ext-rule-table '*current-ext-rule-table*)) | |
| 308 | 230 | `(axiom-extensions ,_x ,_ext-rule-table)) |
| 309 | 231 | |
| 310 | 232 | (defmacro !axiom-ac-extension (_ax &optional |
| 311 | (_ext-rule-table '*current-ext-rule-table*)) | |
| 233 | (_ext-rule-table '*current-ext-rule-table*)) | |
| 312 | 234 | `(axiom-extensions ,_ax ,_ext-rule-table)) |
| 313 | 235 | |
| 314 | 236 | (defmacro !axiom-a-extensions (_ax &optional |
| 315 | (_ext-rule-table '*current-ext-rule-table*)) | |
| 237 | (_ext-rule-table '*current-ext-rule-table*)) | |
| 316 | 238 | `(axiom-extensions ,_ax ,_ext-rule-table)) |
| 317 | ||
| 318 | #|| | |
| 319 | (defun !axiom-a-extensions (ax &optional | |
| 320 | (ext-rule-table *current-ext-rule-table*)) | |
| 321 | (let ((exts (axiom-extensions ax ext-rule-table))) | |
| 322 | (if exts | |
| 323 | (axiom-exts-a-extensions exts) | |
| 324 | nil))) | |
| 325 | ||
| 326 | (defsetf !axiom-a-extensions (_ax &optional | |
| 327 | (ext-rule-table '*current-ext-rule-table*)) | |
| 328 | (_value) | |
| 329 | ` (let ((exts (axiom-extensions ,_ax ,ext-rule-table))) | |
| 330 | (unless exts | |
| 331 | (setf (axiom-extensions ,_ax ,ext-rule-table) | |
| 332 | (make-axiom-exts))) | |
| 333 | (setf (axiom-exts-a-extensions exts) ,_value))) | |
| 334 | ||
| 335 | ||# | |
| 336 | ||
| 337 | 239 | |
| 338 | 240 | ;;; the basic constructor |
| 339 | 241 | ;;; create-axiom |
| 340 | 242 | ;;; |
| 341 | #|| | |
| 342 | (defun create-axiom (lhs rhs condition type behavioural id-condition | |
| 343 | ac-extension | |
| 344 | a-extensions kind first-match-method next-match-method | |
| 345 | labels) | |
| 346 | (let ((r (axiom* type lhs rhs condition behavioural))) | |
| 347 | (setf (axiom-id-condition r) id-condition) | |
| 348 | (when (or ac-extension a-extensions) | |
| 349 | (setf (axiom-extensions r) (make-axiom-exts))) | |
| 350 | (if ac-extension | |
| 351 | (setf (axiom-ac-extension r) ac-extension)) | |
| 352 | (if a-extensions | |
| 353 | (setf (axiom-a-extensions r) a-extensions)) | |
| 354 | (setf (axiom-kind r) kind) | |
| 355 | (setf (axiom-first-match-method r) first-match-method) | |
| 356 | (setf (axiom-next-match-method r) next-match-method) | |
| 357 | (setf (axiom-labels r) labels) | |
| 358 | r)) | |
| 359 | ||# | |
| 360 | ||
| 361 | 243 | (defun create-axiom (lhs |
| 362 | rhs | |
| 363 | condition | |
| 364 | type | |
| 365 | behavioural | |
| 366 | id-condition | |
| 367 | extensions | |
| 368 | kind | |
| 369 | first-match-method | |
| 370 | next-match-method | |
| 371 | labels | |
| 372 | &optional (meta-and-or nil)) | |
| 244 | rhs | |
| 245 | condition | |
| 246 | type | |
| 247 | behavioural | |
| 248 | id-condition | |
| 249 | extensions | |
| 250 | kind | |
| 251 | first-match-method | |
| 252 | next-match-method | |
| 253 | labels | |
| 254 | &optional (meta-and-or nil)) | |
| 373 | 255 | (declare (type term lhs rhs condition) |
| 374 | (type (or null t) behavioural) | |
| 375 | (type symbol type kind first-match-method next-match-method) | |
| 376 | (type list id-condition extensions labels) | |
| 377 | (values axiom)) | |
| 256 | (type (or null t) behavioural) | |
| 257 | (type symbol type kind first-match-method next-match-method) | |
| 258 | (type list id-condition extensions labels) | |
| 259 | (values axiom)) | |
| 378 | 260 | (let ((r (axiom* type lhs rhs condition behavioural))) |
| 379 | 261 | (setf (axiom-id-condition r) id-condition) |
| 380 | 262 | (when extensions |
| 384 | 266 | (setf (axiom-next-match-method r) next-match-method) |
| 385 | 267 | (setf (axiom-labels r) labels) |
| 386 | 268 | (setf (axiom-meta-and-or r) meta-and-or) |
| 387 | (set-context-module r) | |
| 269 | (set-object-context-module r) | |
| 388 | 270 | r)) |
| 389 | 271 | |
| 390 | 272 | (defmacro rule-is-builtin (_rule_) |
| 391 | 273 | ` (term$is-lisp-code? (term-body (rule-rhs ,_rule_)))) |
| 392 | 274 | |
| 393 | #|| | |
| 394 | (defun deallocate-axiom (ax) | |
| 395 | (deallocate-non-var (axiom-lhs ax)) | |
| 396 | (deallocate-non-var (axiom-rhs ax)) | |
| 397 | (let ((cond (axiom-condition ax))) | |
| 398 | (when (and cond | |
| 399 | (not (or (eq *bool-true* cond) | |
| 400 | (eq *bool-false* cond)))) | |
| 401 | (deallocate-non-var cond))) | |
| 402 | (when (axiom-ac-extension ax) | |
| 403 | (deallocate-axiom (axiom-ac-extension ax))) | |
| 404 | (mapc #'deallocate-axiom (axiom-a-extensions ax))) | |
| 405 | ||# | |
| 406 | ||
| 407 | 275 | ;;; AXIOM-CONTAINS-ERROR-METHOD? : Axiom -> Bool |
| 408 | 276 | ;;; retrurns true iff the axiom contains terms with error-method as top. |
| 409 | 277 | ;;; |
| 410 | 278 | (defun axiom-contains-error-method? (e) |
| 411 | 279 | (declare (type axiom e) |
| 412 | (values (or null t))) | |
| 280 | (values (or null t))) | |
| 413 | 281 | (macrolet ((error-method-term? (term) |
| 414 | (once-only (term) | |
| 415 | ` (and (term-is-application-form? (the term ,term)) | |
| 416 | (method-is-error-method (the method (term-head ,term))))))) | |
| 282 | (once-only (term) | |
| 283 | ` (and (term-is-application-form? (the term ,term)) | |
| 284 | (method-is-error-method (the method (term-head ,term))))))) | |
| 417 | 285 | (or (error-method-term? (axiom-lhs e)) |
| 418 | (error-method-term? (axiom-rhs e)) | |
| 419 | (error-method-term? (axiom-condition e))))) | |
| 286 | (error-method-term? (axiom-rhs e)) | |
| 287 | (error-method-term? (axiom-condition e))))) | |
| 420 | 288 | |
| 421 | 289 | ;;;============================================================================= |
| 422 | ;;; THEOREM | |
| 290 | ;;; THEOREM | |
| 423 | 291 | ;;;============================================================================= |
| 424 | 292 | |
| 425 | 293 | ;;;******** |
| 428 | 296 | |
| 429 | 297 | ;;; *NOT YET* |
| 430 | 298 | |
| 431 | #| | |
| 432 | (defterm theorem (object) | |
| 433 | :visible (value) ; the theorem itself | |
| 434 | :hidden (type ; type of thorem | |
| 435 | ; :eq = equation | |
| 436 | ; :rule = rule | |
| 437 | ; :fop = first order predicate | |
| 438 | ; :hol = higher order predicate | |
| 439 | module ; module object in which the theorem is | |
| 440 | ; specified. | |
| 441 | valid ; flag | |
| 442 | ; nil = unknown. | |
| 443 | ; :valid = the thorem is poved to be valid. | |
| 444 | ; :invalid = the theorem is proved to be | |
| 445 | ; invalid. | |
| 446 | )) | |
| 447 | |# | |
| 448 | ||
| 449 | ||
| 450 | 299 | ;;; EOF |
| 0 | 0 | ;;;-*-Mode:LISP; Package: CHAOS; Base:10; Syntax:Common-lisp -*- |
| 1 | 1 | ;;; |
| 2 | ;;; Copyright (c) 2000-2014, Toshimi Sawada. All rights reserved. | |
| 2 | ;;; Copyright (c) 2000-2015, Toshimi Sawada. All rights reserved. | |
| 3 | 3 | ;;; |
| 4 | 4 | ;;; Redistribution and use in source and binary forms, with or without |
| 5 | 5 | ;;; modification, are permitted provided that the following conditions |
| 28 | 28 | ;;; |
| 29 | 29 | (in-package :chaos) |
| 30 | 30 | #|============================================================================= |
| 31 | System:Chaos | |
| 32 | Module:chaos/primitives | |
| 33 | File:bflag.lisp | |
| 31 | System:Chaos | |
| 32 | Module:chaos/primitives | |
| 33 | File:bflag.lisp | |
| 34 | 34 | =============================================================================|# |
| 35 | 35 | #-:chaos-debug |
| 36 | 36 | (declaim (optimize (speed 3) (safety 0) #-GCL (debug 0))) |
| 42 | 42 | ;;; |
| 43 | 43 | (eval-when (:execute :compile-toplevel :load-toplevel) |
| 44 | 44 | (defstruct (chaos-flag (:type list) |
| 45 | (:conc-name "CFLG-")) | |
| 45 | (:conc-name "CFLG-")) | |
| 46 | 46 | (value nil :type t) |
| 47 | 47 | (canon-name nil :type symbol) |
| 48 | 48 | (name nil :type list) |
| 56 | 56 | |
| 57 | 57 | (defun canonicalize-flag-name (name) |
| 58 | 58 | (if (symbolp name) |
| 59 | name ; assumes this is canonicalized name | |
| 59 | name ; assumes this is canonicalized name | |
| 60 | 60 | (or (gethash name *chaos-flag-names*) |
| 61 | (with-output-chaos-error ('no-such-flag) | |
| 62 | (format t "no such flag ~s." name))))) | |
| 61 | (with-output-chaos-error ('no-such-flag) | |
| 62 | (format t "no such flag ~s." name))))) | |
| 63 | 63 | |
| 64 | 64 | (defmacro find-chaos-flag-or-error (name) |
| 65 | 65 | `(let ((n (canonicalize-flag-name ,name))) |
| 84 | 84 | (declare (type symbol group)) |
| 85 | 85 | (let ((flg nil)) |
| 86 | 86 | (maphash #'(lambda (x y) |
| 87 | (declare (ignore x)) | |
| 88 | (when (eq group (cflg-group y)) | |
| 89 | (push y flg))) | |
| 90 | *chaos-control-flags*) | |
| 87 | (declare (ignore x)) | |
| 88 | (when (eq group (cflg-group y)) | |
| 89 | (push y flg))) | |
| 90 | *chaos-control-flags*) | |
| 91 | 91 | flg)) |
| 92 | 92 | |
| 93 | 93 | |
| 94 | 94 | ;;; DECLARE-CHAOS-FLAG |
| 95 | 95 | ;;; |
| 96 | 96 | (defmacro declare-chaos-flag (&key names |
| 97 | canon-name | |
| 98 | initial-value | |
| 99 | (doc-string "") | |
| 100 | (group nil) | |
| 101 | (hook #'identity)) | |
| 97 | canon-name | |
| 98 | initial-value | |
| 99 | (doc-string "") | |
| 100 | (group nil) | |
| 101 | (hook #'identity)) | |
| 102 | 102 | `(let ((flg (make-chaos-flag :value ,initial-value |
| 103 | :name ,names | |
| 104 | :canon-name ,canon-name | |
| 105 | :group ,group | |
| 106 | :doc-string ,doc-string | |
| 107 | :hook ,hook))) | |
| 103 | :name ,names | |
| 104 | :canon-name ,canon-name | |
| 105 | :group ,group | |
| 106 | :doc-string ,doc-string | |
| 107 | :hook ,hook))) | |
| 108 | 108 | (dolist (name ,names) |
| 109 | 109 | (setf (gethash name *chaos-flag-names*) ,canon-name)) |
| 110 | 110 | (setf (gethash ,canon-name) flg) |
| 115 | 115 | (defun save-chaos-flags () |
| 116 | 116 | (let ((flags nil)) |
| 117 | 117 | (maphash #'(lambda (x y) |
| 118 | (push (cons x (cflg-value y)) | |
| 119 | flags)) | |
| 120 | *chaos-control-flags*) | |
| 118 | (push (cons x (cflg-value y)) | |
| 119 | flags)) | |
| 120 | *chaos-control-flags*) | |
| 121 | 121 | flags)) |
| 122 | 122 | |
| 123 | 123 | (defun restore-chaos-flags (flags) |
| 135 | 135 | |
| 136 | 136 | (defun find-chaos-flag-set (name) |
| 137 | 137 | (declare (type simple-string name) |
| 138 | (values (or chaos-flag-set null))) | |
| 138 | (values (or chaos-flag-set null))) | |
| 139 | 139 | (find-if #'(lambda (x) (string= name (chaos-flag-set-name x))) |
| 140 | *chaos-flag-set*)) | |
| 140 | *chaos-flag-set*)) | |
| 141 | 141 | |
| 142 | 142 | (defun create-chaos-flag-set (name) |
| 143 | 143 | (declare (type simple-string name)) |
| 151 | 151 | (let ((fset (find-chaos-flag-set name))) |
| 152 | 152 | (unless (chaos-flag :quiet) |
| 153 | 153 | (with-output-msg () |
| 154 | (format t "saving flags to ~a." name))) | |
| 154 | (format t "saving flags to ~a." name))) | |
| 155 | 155 | (if fset |
| 156 | (progn | |
| 157 | (unless (chaos-flag :quiet) | |
| 158 | (with-output-chaos-warning () | |
| 159 | (format t "changing flag set ~a with current values." name))) | |
| 160 | (setf (chaos-flag-set-flags fset) (save-chaos-flags))) | |
| 156 | (progn | |
| 157 | (unless (chaos-flag :quiet) | |
| 158 | (with-output-chaos-warning () | |
| 159 | (format t "changing flag set ~a with current values." name))) | |
| 160 | (setf (chaos-flag-set-flags fset) (save-chaos-flags))) | |
| 161 | 161 | (progn |
| 162 | (setq fset (create-chaos-flag-set name)) | |
| 163 | (push fset *chaos-flag-set*))) | |
| 162 | (setq fset (create-chaos-flag-set name)) | |
| 163 | (push fset *chaos-flag-set*))) | |
| 164 | 164 | t)) |
| 165 | 165 | |
| 166 | 166 | (defun restore-chaos-flag-set (name) |
| 168 | 168 | (let ((fset (find-chaos-flag-set name))) |
| 169 | 169 | (unless fset |
| 170 | 170 | (with-output-chaos-error ('no-such-flag-set) |
| 171 | (format t "no such flag set ~s." name))) | |
| 171 | (format t "no such flag set ~s." name))) | |
| 172 | 172 | (unless (chaos-flag :quiet) |
| 173 | 173 | (with-output-msg () |
| 174 | (format t "restoring flag set from ~s." name))) | |
| 174 | (format t "restoring flag set from ~s." name))) | |
| 175 | 175 | (restore-chaos-flags (chaos-flag-set-flags fset)) |
| 176 | 176 | t)) |
| 177 | 177 | |
| 0 | 0 | ;;;-*- Mode:LISP; Package: Chaos; Base:10; Syntax:Common-lisp -*- |
| 1 | 1 | ;;; |
| 2 | ;;; Copyright (c) 2000-2014, Toshimi Sawada. All rights reserved. | |
| 2 | ;;; Copyright (c) 2000-2015, Toshimi Sawada. All rights reserved. | |
| 3 | 3 | ;;; |
| 4 | 4 | ;;; Redistribution and use in source and binary forms, with or without |
| 5 | 5 | ;;; modification, are permitted provided that the following conditions |
| 27 | 27 | ;;; |
| 28 | 28 | (in-package :chaos) |
| 29 | 29 | #|============================================================================== |
| 30 | System: Chaos | |
| 31 | Module: primitives | |
| 32 | File: bmacro.lisp | |
| 30 | System: Chaos | |
| 31 | Module: primitives | |
| 32 | File: bmacro.lisp | |
| 33 | 33 | ==============================================================================|# |
| 34 | 34 | #-:chaos-debug |
| 35 | 35 | (declaim (optimize (speed 3) (safety 0) #-GCL (debug 0))) |
| 42 | 42 | |
| 43 | 43 | (defun print-macro (macro stream &rest ignore) |
| 44 | 44 | (declare (ignore ignore)) |
| 45 | (let ((mod (or *last-module* *current-module*))) | |
| 45 | (let ((mod (get-context-module t))) | |
| 46 | 46 | (if mod |
| 47 | (with-in-module (mod) | |
| 48 | (term-print (macro-lhs macro) stream) | |
| 49 | (terpri stream) | |
| 50 | (princ " ::= ") | |
| 51 | (term-print (macro-rhs macro) stream)) | |
| 47 | (with-in-module (mod) | |
| 48 | (term-print (macro-lhs macro) stream) | |
| 49 | (terpri stream) | |
| 50 | (princ " ::= ") | |
| 51 | (term-print (macro-rhs macro) stream)) | |
| 52 | 52 | (format t "#<MacroDecl: ~D>" (addr-of macro))))) |
| 53 | 53 | |
| 54 | 54 | ;;; EOF |
| 0 | 0 | ;;;-*- Mode:LISP; Package:CHAOS; Base:10; Syntax:Common-lisp -*- |
| 1 | 1 | ;;; |
| 2 | ;;; Copyright (c) 2000-2014, Toshimi Sawada. All rights reserved. | |
| 2 | ;;; Copyright (c) 2000-2015, Toshimi Sawada. All rights reserved. | |
| 3 | 3 | ;;; |
| 4 | 4 | ;;; Redistribution and use in source and binary forms, with or without |
| 5 | 5 | ;;; modification, are permitted provided that the following conditions |
| 27 | 27 | ;;; |
| 28 | 28 | (in-package :chaos) |
| 29 | 29 | #|============================================================================== |
| 30 | System: CHAOS | |
| 31 | Module: primitives | |
| 32 | File: bmodexp.lisp | |
| 30 | System: CHAOS | |
| 31 | Module: primitives | |
| 32 | File: bmodexp.lisp | |
| 33 | 33 | ==============================================================================|# |
| 34 | 34 | #-:chaos-debug |
| 35 | 35 | (declaim (optimize (speed 3) (safety 0) #-GCL (debug 0))) |
| 91 | 91 | (deftype modexp () '(or simple-string list)) |
| 92 | 92 | |
| 93 | 93 | (defparameter .modexp-keywords. '(%modexp %error %plus %rename %instantiation %view)) |
| 94 | ||
| 94 | ||
| 95 | 95 | (defun is-modexp? (object) |
| 96 | 96 | (or (stringp object) |
| 97 | 97 | (and (listp object) |
| 98 | (memq (car object) .modexp-keywords.)))) | |
| 98 | (memq (car object) .modexp-keywords.)))) | |
| 99 | 99 | |
| 100 | 100 | (defterm modexp (%ast) |
| 101 | 101 | :visible (value) |
| 115 | 115 | ;;; - source : sort-ref |
| 116 | 116 | ;;; - target : string representing new sort name. |
| 117 | 117 | ;;; |
| 118 | (defterm ren-sort (%ast) ; visible sort | |
| 118 | (defterm ren-sort (%ast) ; visible sort | |
| 119 | 119 | ;; :visible (source target) |
| 120 | 120 | :visible (&rest maps) |
| 121 | 121 | :print print-ren-sort) |
| 122 | 122 | |
| 123 | (defterm ren-hsort (%ast) ; hidden sort | |
| 123 | (defterm ren-hsort (%ast) ; hidden sort | |
| 124 | 124 | ;; :visible (source target) |
| 125 | 125 | :visible (&rest maps) |
| 126 | 126 | :print print-ren-sort) |
| 130 | 130 | ;;; - source : op-ref. |
| 131 | 131 | ;;; - target : string or list of string representing new operator name. |
| 132 | 132 | ;;; |
| 133 | (defterm ren-op (%ast) ; functional operator | |
| 133 | (defterm ren-op (%ast) ; functional operator | |
| 134 | 134 | ;; :visible (source target) |
| 135 | 135 | :visible (&rest maps) |
| 136 | 136 | :print print-ren-op) |
| 137 | 137 | |
| 138 | (defterm ren-bop (%ast) ; behavioural operator | |
| 138 | (defterm ren-bop (%ast) ; behavioural operator | |
| 139 | 139 | ;; :visible (source target) |
| 140 | 140 | :visible (&rest maps) |
| 141 | 141 | :print print-ren-op) |
| 204 | 204 | |
| 205 | 205 | (defun modexp-is-?name? (modexp) |
| 206 | 206 | (declare (type t modexp) |
| 207 | (values (or null t))) | |
| 207 | (values (or null t))) | |
| 208 | 208 | (and (consp modexp) (eq (car modexp) ':?name))) |
| 209 | 209 | |
| 210 | 210 | (defun ?name-name (modexp) |
| 216 | 216 | ;;; |
| 217 | 217 | (defun modexp-is-parameter-theory (e) |
| 218 | 218 | (declare (type t e) |
| 219 | (values (or null t))) | |
| 219 | (values (or null t))) | |
| 220 | 220 | (and (consp e) |
| 221 | 221 | (equal "::" (cadr e)))) |
| 222 | 222 | |
| 225 | 225 | ;;; **** |
| 226 | 226 | |
| 227 | 227 | (defterm view (%ast) |
| 228 | :visible (module ; theory module | |
| 229 | target ; target module | |
| 230 | map) ; mappings | |
| 228 | :visible (module ; theory module | |
| 229 | target ; target module | |
| 230 | map) ; mappings | |
| 231 | 231 | :print print-view-modexp) |
| 232 | 232 | |
| 233 | 233 | ;;; ******************** |
| 240 | 240 | ;;; |
| 241 | 241 | (defun modexp-is-error (val) |
| 242 | 242 | (declare (type t) |
| 243 | (values (or null t))) | |
| 243 | (values (or null t))) | |
| 244 | 244 | (and (consp val) (eq :error (car val)))) |
| 245 | 245 | |
| 246 | 246 | ;;; MODEXP-IS-SIMPLE-NAME : object -> Bool |
| 248 | 248 | ;;; |
| 249 | 249 | (defun modexp-is-simple-name (x) |
| 250 | 250 | (declare (type (or atom modexp) x) |
| 251 | (values (or null t))) | |
| 251 | (values (or null t))) | |
| 252 | 252 | (or (stringp x) |
| 253 | 253 | (symbolp x) |
| 254 | 254 | (modexp-is-parameter-theory x))) |
| 280 | 280 | |
| 281 | 281 | (defun find-view-in-env (view) |
| 282 | 282 | (declare (type modexp view) |
| 283 | (values (or null t))) | |
| 283 | (values (or null t))) | |
| 284 | 284 | (find-in-assoc-table *modexp-view-table* view)) |
| 285 | 285 | |
| 286 | 286 | (defun add-view-defn (view value) |
| 300 | 300 | ;;; module : module replacement, assoc list of (module . module). |
| 301 | 301 | ;;; |
| 302 | 302 | (defstruct (modmorph (:constructor create-modmorph (name sort op module))) |
| 303 | (name nil :type t) ; name of mapping; e.g. name of view or | |
| 304 | ; module. (taken from may be more than | |
| 305 | ; one view). | |
| 306 | (sort nil :type list) ; sort map. | |
| 307 | (op nil :type list) ; operator map, really is a method map. | |
| 308 | (module nil :type list) ; module map | |
| 303 | (name nil :type t) ; name of mapping; e.g. name of view or | |
| 304 | ; module. (taken from may be more than | |
| 305 | ; one view). | |
| 306 | (sort nil :type list) ; sort map. | |
| 307 | (op nil :type list) ; operator map, really is a method map. | |
| 308 | (module nil :type list) ; module map | |
| 309 | 309 | ) |
| 310 | 310 | |
| 311 | 311 | ;;; TODO : ugly |
| 319 | 319 | |
| 320 | 320 | (defmacro modmorph-assoc-images (_assoc-list _lst) |
| 321 | 321 | ` (mapcar #'(lambda (x) |
| 322 | (or (cdr (assq x ,_assoc-list)) | |
| 323 | x)) | |
| 324 | ,_lst)) | |
| 322 | (or (cdr (assq x ,_assoc-list)) | |
| 323 | x)) | |
| 324 | ,_lst)) | |
| 325 | 325 | |
| 326 | 326 | ;;; ****************************** |
| 327 | 327 | ;;; TOPLEVEL MODEXP INTERNAL FORMS |
| 0 | 0 | ;;;-*- Mode:LISP; Package: Chaos; Base:10; Syntax:Common-lisp -*- |
| 1 | 1 | ;;; |
| 2 | ;;; Copyright (c) 2000-2014, Toshimi Sawada. All rights reserved. | |
| 2 | ;;; Copyright (c) 2000-2015, Toshimi Sawada. All rights reserved. | |
| 3 | 3 | ;;; |
| 4 | 4 | ;;; Redistribution and use in source and binary forms, with or without |
| 5 | 5 | ;;; modification, are permitted provided that the following conditions |
| 27 | 27 | ;;; |
| 28 | 28 | (in-package :chaos) |
| 29 | 29 | #|============================================================================== |
| 30 | System: Chaos | |
| 31 | Module: primitives | |
| 32 | File: bmodule.lisp | |
| 30 | System: Chaos | |
| 31 | Module: primitives | |
| 32 | File: bmodule.lisp | |
| 33 | 33 | ==============================================================================|# |
| 34 | 34 | #-:chaos-debug |
| 35 | 35 | (declaim (optimize (speed 3) (safety 0) #-GCL (debug 0))) |
| 48 | 48 | ;;; MODULE __________________________________________________________________ |
| 49 | 49 | ;;; STRUCTURE |
| 50 | 50 | ;;; ********* |
| 51 | #|| | |
| 52 | (defterm module (top-object) | |
| 53 | :visible (name) ; module name (modexpr). | |
| 54 | :hidden (signature ; own signature. | |
| 55 | axiom-set ; set of own axioms. | |
| 56 | theorems ; set of own theorems, not used yet. | |
| 57 | parse-dictionary ; infos for term parsing. | |
| 58 | ex-info ; various compiled informations. | |
| 59 | trs ; corresponding semi-compiled TRS. | |
| 60 | context ; run time context | |
| 61 | ) | |
| 62 | :int-printer print-module-object | |
| 63 | :print print-module-internal) | |
| 64 | ||
| 65 | (defstruct (module (:include top-object (-type 'module)) | |
| 66 | (:conc-name "MODULE-") | |
| 67 | (:constructor make-module) | |
| 68 | (:constructor module* (name)) | |
| 69 | (:print-function print-module-object) | |
| 70 | ) | |
| 71 | (signature nil :type (or null signature-struct)) | |
| 72 | ; own signature. | |
| 73 | (axiom-set nil :type (or null axiom-set)) | |
| 74 | ; set of own axioms. | |
| 75 | (theorems nil :type list) ; set of own theorems, not used yet. | |
| 76 | (parse-dictionary nil :type (or null parse-dictionary)) | |
| 77 | ; infos for term parsing. | |
| 78 | (ex-info nil :type list) ; various compiled informations. | |
| 79 | (trs nil :type (or null trs)) ; corresponding semi-compiled TRS. | |
| 80 | (context nil | |
| 81 | :type (or null module-context)) | |
| 82 | ; run time context | |
| 83 | (alias nil :type list) | |
| 84 | ) | |
| 85 | ||
| 86 | (eval-when (:execute :load-toplevel) | |
| 87 | (setf (get 'module :type-predicate) (symbol-function 'module-p)) | |
| 88 | (setf (get 'module :eval) nil) | |
| 89 | (setf (get 'module :print) 'print-module-internal) | |
| 90 | ) | |
| 91 | ||
| 92 | ||# | |
| 93 | ||
| 94 | ;;; type predicate | |
| 95 | ||
| 96 | ;;; (defmacro module-p (_object) `(is-module ,_object)) | |
| 97 | 51 | |
| 98 | 52 | ;;; module name |
| 99 | 53 | ;;; name ::= string |
| 105 | 59 | |
| 106 | 60 | (defun module-is-parameter-theory (m) |
| 107 | 61 | (declare (type t m) |
| 108 | (values (or null t))) | |
| 62 | (values (or null t))) | |
| 109 | 63 | (let ((name (if (module-p m) |
| 110 | (module-name m) | |
| 111 | m))) | |
| 64 | (module-name m) | |
| 65 | m))) | |
| 112 | 66 | (cond ((modexp-is-simple-name name) |
| 113 | (modexp-is-parameter-theory name)) | |
| 114 | ((%is-rename name) | |
| 115 | (module-is-parameter-theory (%rename-module name))) | |
| 116 | ((int-rename-p name) | |
| 117 | (module-is-parameter-theory (int-rename-module name))) | |
| 118 | ((%is-instantiation name) | |
| 119 | (module-is-parameter-theory (%instantiation-module name))) | |
| 120 | ((int-instantiation-p name) | |
| 121 | (module-is-parameter-theory (int-instantiation-module name))) | |
| 122 | (t nil)))) | |
| 67 | (modexp-is-parameter-theory name)) | |
| 68 | ((%is-rename name) | |
| 69 | (module-is-parameter-theory (%rename-module name))) | |
| 70 | ((int-rename-p name) | |
| 71 | (module-is-parameter-theory (int-rename-module name))) | |
| 72 | ((%is-instantiation name) | |
| 73 | (module-is-parameter-theory (%instantiation-module name))) | |
| 74 | ((int-instantiation-p name) | |
| 75 | (module-is-parameter-theory (int-instantiation-module name))) | |
| 76 | (t nil)))) | |
| 123 | 77 | |
| 124 | 78 | ;;; **************** |
| 125 | 79 | ;;; MODULE-INTERFACE___________________________________________________________ |
| 134 | 88 | (defmacro module-parameters (_mod) `(object-parameters ,_mod)) |
| 135 | 89 | |
| 136 | 90 | (defmacro module-exporting-modules (_mod) `(object-exporting-objects ,_mod)) |
| 137 | ||
| 91 | ||
| 138 | 92 | ;;; (defmacro module-decl-form (_mod) `(object-decl-form ,_mod)) |
| 139 | 93 | |
| 140 | 94 | ;;; ** structure of interface-dag ********************************************** |
| 158 | 112 | |
| 159 | 113 | |
| 160 | 114 | < (M . nil) ( < (M2 . pr) ( < (M3 . pr ) nil > < (M4 . ex ) #1= nil> ) > |
| 161 | < (M5 . ex) ( < (M4 . pr) #1 > ) > | |
| 162 | ) > | |
| 115 | < (M5 . ex) ( < (M4 . pr) #1 > ) > | |
| 116 | ) > | |
| 163 | 117 | |
| 164 | 118 | -----------------------------------------------------------------------------||# |
| 165 | 119 | (defmacro module-dag-submodules (module) |
| 166 | 120 | ` (when (module-interface ,module) |
| 167 | 121 | (let ((dag (module-dag ,module))) |
| 168 | (if dag | |
| 169 | (dag-node-subnodes (module-dag ,module)) | |
| 170 | nil)))) | |
| 122 | (if dag | |
| 123 | (dag-node-subnodes (module-dag ,module)) | |
| 124 | nil)))) | |
| 171 | 125 | |
| 172 | 126 | ;;; for downward compatibility |
| 173 | 127 | ;;; |
| 174 | 128 | (defun module-direct-submodules (module) |
| 175 | 129 | (declare (type module module)) |
| 176 | 130 | (delete-if #'(lambda (x) |
| 177 | (memq (cdr x) '(:modmorph :view))) | |
| 178 | (the list | |
| 179 | (mapcar #'dag-node-datum (the list | |
| 180 | (module-dag-submodules module)))))) | |
| 181 | ||
| 182 | (defun module-submodules (module) ; just an abbriviation for downward compat. | |
| 131 | (memq (cdr x) '(:modmorph :view))) | |
| 132 | (the list | |
| 133 | (mapcar #'dag-node-datum (the list | |
| 134 | (module-dag-submodules module)))))) | |
| 135 | ||
| 136 | (defun module-submodules (module) ; just an abbriviation for downward compat. | |
| 183 | 137 | (declare (type module) |
| 184 | (values list)) | |
| 138 | (values list)) | |
| 185 | 139 | (delete-if #'(lambda (x) |
| 186 | (memq (cdr x) '(:modmorph :view))) | |
| 187 | (the list (mapcar #'dag-node-datum | |
| 188 | (the list | |
| 189 | (module-dag-submodules module)))))) | |
| 140 | (memq (cdr x) '(:modmorph :view))) | |
| 141 | (the list (mapcar #'dag-node-datum | |
| 142 | (the list | |
| 143 | (module-dag-submodules module)))))) | |
| 190 | 144 | |
| 191 | 145 | ;;; dag intialization |
| 192 | 146 | (defun initialize-module-dag (module) |
| 193 | 147 | (declare (type module) |
| 194 | (values t)) | |
| 148 | (values t)) | |
| 195 | 149 | (initialize-depend-dag module)) |
| 196 | 150 | |
| 197 | 151 | ;;; BASIC UTILS for accessing module DAG |
| 200 | 154 | |
| 201 | 155 | (defun module-all-submodules (mod) |
| 202 | 156 | (declare (type module mod) |
| 203 | (values list)) | |
| 157 | (values list)) | |
| 204 | 158 | (let ((res (cons nil nil))) |
| 205 | 159 | (gather-submodules mod res) |
| 206 | 160 | (car res) )) |
| 207 | 161 | |
| 208 | 162 | (defun gather-submodules (mod res) |
| 209 | 163 | (declare (type module mod) |
| 210 | (type list res) | |
| 211 | (values list)) | |
| 164 | (type list res) | |
| 165 | (values list)) | |
| 212 | 166 | (let ((dmods (module-direct-submodules mod))) |
| 213 | 167 | (dolist (dmod dmods) |
| 214 | 168 | (unless (or (eq (cdr dmod) :modmorph) |
| 215 | (member dmod (car res) :test #'equal)) | |
| 216 | (push dmod (car res)) | |
| 217 | (gather-submodules (car dmod) res))))) | |
| 169 | (member dmod (car res) :test #'equal)) | |
| 170 | (push dmod (car res)) | |
| 171 | (gather-submodules (car dmod) res))))) | |
| 218 | 172 | |
| 219 | 173 | (defun get-module-dependency (mod) |
| 220 | 174 | (let ((res (cons nil nil))) |
| 223 | 177 | |
| 224 | 178 | (defun gather-module-dependency (mod res) |
| 225 | 179 | (let ((dmods (mapcar #'dag-node-datum |
| 226 | (module-dag-submodules mod)))) | |
| 180 | (module-dag-submodules mod)))) | |
| 227 | 181 | (dolist (dmod dmods) |
| 228 | 182 | (unless (member dmod (car res) :test #'equal) |
| 229 | (push dmod (car res)) | |
| 230 | (gather-module-dependency (car dmod) res))))) | |
| 183 | (push dmod (car res)) | |
| 184 | (gather-module-dependency (car dmod) res))))) | |
| 231 | 185 | |
| 232 | 186 | ;;; Imported modules of a module are organized into the slot `submodules' |
| 233 | 187 | ;;; in a form of list "(module . mode) ...". |
| 237 | 191 | ;;; |
| 238 | 192 | (defun get-importing-path (module2 module) |
| 239 | 193 | (declare (type module module2 module) |
| 240 | (values list)) | |
| 194 | (values list)) | |
| 241 | 195 | (let ((subs (module-direct-submodules module))) |
| 242 | 196 | (let ((im (assq module2 subs))) |
| 243 | 197 | (if im |
| 244 | (list im) | |
| 245 | (dolist (s subs) | |
| 246 | (let ((path (list s))) | |
| 247 | (let ((im2 (get-importing-path module2 (car s)))) | |
| 248 | (if im2 | |
| 249 | (return-from get-importing-path | |
| 250 | (nconc path im2)))))))))) | |
| 251 | ||
| 252 | (defun get-real-importing-mode (module2 &optional (module (or *current-module* | |
| 253 | *last-module*))) | |
| 198 | (list im) | |
| 199 | (dolist (s subs) | |
| 200 | (let ((path (list s))) | |
| 201 | (let ((im2 (get-importing-path module2 (car s)))) | |
| 202 | (if im2 | |
| 203 | (return-from get-importing-path | |
| 204 | (nconc path im2)))))))))) | |
| 205 | ||
| 206 | (defun get-real-importing-mode (module2 &optional (module (get-context-module))) | |
| 254 | 207 | (declare (type module module2 module) |
| 255 | (values symbol)) | |
| 256 | ;; | |
| 208 | (values symbol)) | |
| 257 | 209 | (let ((path (get-importing-path module2 module))) |
| 258 | 210 | (let ((mode nil)) |
| 259 | 211 | (dolist (e path mode) |
| 260 | (if (null mode) | |
| 261 | (setq mode (cdr e)) | |
| 262 | (if (eq (car e) module2) | |
| 263 | (return-from get-real-importing-mode | |
| 264 | (case mode | |
| 265 | (:protecting (cdr e)) | |
| 266 | (:extending (case (cdr e) | |
| 267 | (:protecting :?extending) | |
| 268 | (otherwise (cdr e)))) | |
| 269 | (otherwise (cdr e)))) | |
| 270 | (case mode | |
| 271 | (:protecting (setq mode (cdr e))) | |
| 272 | (:extending (unless (eq :protecting (cdr e)) | |
| 273 | (setq mode (cdr e)))) | |
| 274 | (otherwise (setq mode (cdr e)))))))))) | |
| 212 | (if (null mode) | |
| 213 | (setq mode (cdr e)) | |
| 214 | (if (eq (car e) module2) | |
| 215 | (return-from get-real-importing-mode | |
| 216 | (case mode | |
| 217 | (:protecting (cdr e)) | |
| 218 | (:extending (case (cdr e) | |
| 219 | (:protecting :?extending) | |
| 220 | (otherwise (cdr e)))) | |
| 221 | (otherwise (cdr e)))) | |
| 222 | (case mode | |
| 223 | (:protecting (setq mode (cdr e))) | |
| 224 | (:extending (unless (eq :protecting (cdr e)) | |
| 225 | (setq mode (cdr e)))) | |
| 226 | (otherwise (setq mode (cdr e)))))))))) | |
| 275 | 227 | |
| 276 | 228 | ;;; does module1 extend module2 ? |
| 277 | 229 | ;;; |
| 332 | 284 | ;;; (defmacro parameter-theory-arg-name (_mod_) `(car (module-name ,_mod_))) |
| 333 | 285 | (defun parameter-theory-arg-name (mod) |
| 334 | 286 | (cond ((module-p mod) |
| 335 | (let ((name (module-name mod))) | |
| 336 | (cond ((%is-rename name) | |
| 337 | (parameter-theory-arg-name (%rename-module name))) | |
| 338 | ((int-rename-p name) | |
| 339 | (parameter-theory-arg-name (int-rename-module name))) | |
| 340 | ((%is-instantiation name) | |
| 341 | (parameter-theory-arg-name (%instantiation-module name))) | |
| 342 | ((int-instantiation-p name) | |
| 343 | (parameter-theory-arg-name (int-instantiation-module name))) | |
| 344 | (t (parameter-theory-arg-name (module-name mod)))))) | |
| 345 | ((modexp-is-parameter-theory mod) | |
| 346 | (car mod)) | |
| 347 | (t (with-output-panic-message () | |
| 348 | (format t "expecting arg name, given invalid object: ~s" mod))))) | |
| 287 | (let ((name (module-name mod))) | |
| 288 | (cond ((%is-rename name) | |
| 289 | (parameter-theory-arg-name (%rename-module name))) | |
| 290 | ((int-rename-p name) | |
| 291 | (parameter-theory-arg-name (int-rename-module name))) | |
| 292 | ((%is-instantiation name) | |
| 293 | (parameter-theory-arg-name (%instantiation-module name))) | |
| 294 | ((int-instantiation-p name) | |
| 295 | (parameter-theory-arg-name (int-instantiation-module name))) | |
| 296 | (t (parameter-theory-arg-name (module-name mod)))))) | |
| 297 | ((modexp-is-parameter-theory mod) | |
| 298 | (car mod)) | |
| 299 | (t (with-output-panic-message () | |
| 300 | (format t "expecting arg name, given invalid object: ~s" mod))))) | |
| 349 | 301 | |
| 350 | 302 | (defun parameter-module-theory (mod) |
| 351 | 303 | (cond ((module-p mod) |
| 352 | (let ((name (module-name mod))) | |
| 353 | (cond ((%is-rename name) | |
| 354 | (parameter-module-theory (%rename-module name))) | |
| 355 | ((int-rename-p name) | |
| 356 | (parameter-module-theory (int-rename-module name))) | |
| 357 | ((%is-instantiation name) | |
| 358 | (parameter-module-theory (%instantiation-module name))) | |
| 359 | ((int-instantiation-p name) | |
| 360 | (parameter-module-theory (int-instantiation-module name))) | |
| 361 | (t (parameter-module-theory (module-name mod)))))) | |
| 362 | ((modexp-is-parameter-theory mod) | |
| 363 | (third mod)) | |
| 364 | (t (with-output-panic-message () | |
| 365 | (format t "expecting theory, given invalid object: ~s" mod))))) | |
| 304 | (let ((name (module-name mod))) | |
| 305 | (cond ((%is-rename name) | |
| 306 | (parameter-module-theory (%rename-module name))) | |
| 307 | ((int-rename-p name) | |
| 308 | (parameter-module-theory (int-rename-module name))) | |
| 309 | ((%is-instantiation name) | |
| 310 | (parameter-module-theory (%instantiation-module name))) | |
| 311 | ((int-instantiation-p name) | |
| 312 | (parameter-module-theory (int-instantiation-module name))) | |
| 313 | (t (parameter-module-theory (module-name mod)))))) | |
| 314 | ((modexp-is-parameter-theory mod) | |
| 315 | (third mod)) | |
| 316 | (t (with-output-panic-message () | |
| 317 | (format t "expecting theory, given invalid object: ~s" mod))))) | |
| 366 | 318 | |
| 367 | 319 | (defun parameter-module-context (mod) |
| 368 | 320 | (cond ((module-p mod) |
| 369 | (let ((name (module-name mod))) | |
| 370 | (cond ((%is-rename name) | |
| 371 | (parameter-module-context (%rename-module name))) | |
| 372 | ((int-rename-p name) | |
| 373 | (parameter-module-context (int-rename-module name))) | |
| 374 | ((%is-instantiation name) | |
| 375 | (parameter-module-context (%instantiation-module name))) | |
| 376 | ((int-instantiation-p name) | |
| 377 | (parameter-module-context (int-instantiation-module name))) | |
| 378 | (t (parameter-module-context (module-name mod)))))) | |
| 379 | ((modexp-is-parameter-theory mod) | |
| 380 | (fourth mod)) | |
| 381 | (t (with-output-panic-message () | |
| 382 | (format t "expecting parameter context, given invalid object: ~s" mod))))) | |
| 321 | (let ((name (module-name mod))) | |
| 322 | (cond ((%is-rename name) | |
| 323 | (parameter-module-context (%rename-module name))) | |
| 324 | ((int-rename-p name) | |
| 325 | (parameter-module-context (int-rename-module name))) | |
| 326 | ((%is-instantiation name) | |
| 327 | (parameter-module-context (%instantiation-module name))) | |
| 328 | ((int-instantiation-p name) | |
| 329 | (parameter-module-context (int-instantiation-module name))) | |
| 330 | (t (parameter-module-context (module-name mod)))))) | |
| 331 | ((modexp-is-parameter-theory mod) | |
| 332 | (fourth mod)) | |
| 333 | (t (with-output-panic-message () | |
| 334 | (format t "expecting parameter context, given invalid object: ~s" mod))))) | |
| 383 | 335 | |
| 384 | 336 | ;;; ** EXPORTING MODULES ******************************************************* |
| 385 | 337 | |
| 386 | 338 | (defun module-direct-exporting-modules (mod) |
| 387 | 339 | (declare (type module mod) |
| 388 | (values list)) | |
| 340 | (values list)) | |
| 389 | 341 | (module-exporting-modules mod)) |
| 390 | 342 | |
| 391 | 343 | (defun module-all-exporting-modules (mod) |
| 392 | 344 | (declare (type module mod) |
| 393 | (values list)) | |
| 345 | (values list)) | |
| 394 | 346 | (let ((res (cons nil nil))) |
| 395 | 347 | (gather-exporting-modules mod res) |
| 396 | 348 | (delete-duplicates (car res) :test #'equal))) |
| 397 | 349 | |
| 398 | 350 | (defun gather-exporting-modules (mod res) |
| 399 | 351 | (declare (type module mod) |
| 400 | (type list res) | |
| 401 | (values list)) | |
| 352 | (type list res) | |
| 353 | (values list)) | |
| 402 | 354 | (let ((dmods (module-exporting-modules mod))) |
| 403 | 355 | (dolist (dmod dmods) |
| 404 | 356 | (unless (member dmod (car res) :test #'eq :key #'car) |
| 405 | (push dmod (car res)) | |
| 406 | (gather-exporting-modules (car dmod) res))))) | |
| 357 | (push dmod (car res)) | |
| 358 | (gather-exporting-modules (car dmod) res))))) | |
| 407 | 359 | |
| 408 | 360 | ;;; ** INTERFACE INITIALIZATIONS ********************************************** |
| 409 | 361 | ;;; |
| 410 | 362 | (defun initialize-module-interface (module) |
| 411 | 363 | (declare (type module module) |
| 412 | (values t)) | |
| 364 | (values t)) | |
| 413 | 365 | (initialize-object-interface (module-interface module))) |
| 414 | 366 | |
| 415 | 367 | ;;; ********* |
| 418 | 370 | ;;; gathers own signature infomations of a module. stored in module's `signature' |
| 419 | 371 | ;;; slot. |
| 420 | 372 | |
| 421 | #|| | |
| 422 | (defstruct (signature-struct (:conc-name "SIGNATURE$") | |
| 423 | ;; #+gcl (:static t) | |
| 424 | ) | |
| 425 | (sorts nil :type list) ; list of own sorts. | |
| 426 | (sort-relations nil :type list) ; list of subsort relations. | |
| 427 | (operators nil :type list) ; list of operators declared in the | |
| 428 | ; module. | |
| 429 | (opattrs nil :type list) ; explicitly declared operator | |
| 430 | ; attributes in a form of AST. | |
| 431 | (principal-sort nil :type atom) ; principal sort of the module. | |
| 432 | ) | |
| 433 | ||
| 434 | ||# | |
| 435 | 373 | |
| 436 | 374 | ;;; accessors via module, all are setf'able. |
| 437 | 375 | |
| 440 | 378 | `(signature$sorts (module-signature ,_mod))) |
| 441 | 379 | |
| 442 | 380 | (defmacro module-sort-relations (_mod) `(signature$sort-relations |
| 443 | (module-signature ,_mod))) | |
| 381 | (module-signature ,_mod))) | |
| 444 | 382 | (defmacro module-operators (_mod) `(signature$operators (module-signature |
| 445 | ,_mod))) | |
| 383 | ,_mod))) | |
| 446 | 384 | |
| 447 | 385 | (defmacro module-opattrs (_mod) `(signature$opattrs (module-signature ,_mod))) |
| 448 | 386 | (defmacro module-principal-sort (_mod) `(signature$principal-sort |
| 449 | (module-signature ,_mod))) | |
| 387 | (module-signature ,_mod))) | |
| 450 | 388 | |
| 451 | 389 | ;;; intialization |
| 452 | 390 | (defun initialize-signature (sig) |
| 453 | 391 | (declare (type signature-struct sig) |
| 454 | (values t)) | |
| 392 | (values t)) | |
| 455 | 393 | (setf (signature$sorts sig) nil |
| 456 | (signature$sort-relations sig) nil | |
| 457 | (signature$operators sig) nil | |
| 458 | (signature$opattrs sig) nil | |
| 459 | (signature$principal-sort sig) nil)) | |
| 394 | (signature$sort-relations sig) nil | |
| 395 | (signature$operators sig) nil | |
| 396 | (signature$opattrs sig) nil | |
| 397 | (signature$principal-sort sig) nil)) | |
| 460 | 398 | |
| 461 | 399 | (defun clean-up-signature (sig) |
| 462 | 400 | (initialize-signature sig)) |
| 467 | 405 | ;;; gathers own axioms and explicitly declared variables of a module. |
| 468 | 406 | ;;; stored in module's `axioms' slot. |
| 469 | 407 | |
| 470 | #|| | |
| 471 | (defstruct (axiom-set (:conc-name "AXIOM-SET$") | |
| 472 | ;; #+gcl (:static t) | |
| 473 | ) | |
| 474 | (variables nil :type list) ; assoc list of explicitly declared | |
| 475 | ; variables. | |
| 476 | ; ((variable-name . variable) ...) | |
| 477 | (equations nil :type list) ; list of equtions declared in the module. | |
| 478 | (rules nil :type list) ; list of rules declared in the module. | |
| 479 | ) | |
| 480 | ||
| 481 | ||# | |
| 482 | ||
| 483 | 408 | ;;; accessors from module object, all are setf'able. |
| 484 | 409 | |
| 485 | 410 | (defmacro module-variables (_mod) `(axiom-set$variables (module-axiom-set |
| 486 | ,_mod))) | |
| 411 | ,_mod))) | |
| 487 | 412 | (defmacro module-equations (_mod) `(axiom-set$equations (module-axiom-set |
| 488 | ,_mod))) | |
| 413 | ,_mod))) | |
| 489 | 414 | (defmacro module-rules (_mod) `(axiom-set$rules (module-axiom-set ,_mod))) |
| 490 | 415 | |
| 491 | 416 | ;;; intialization |
| 492 | 417 | |
| 493 | 418 | (defun initialize-axiom-set (axset) |
| 494 | 419 | (declare (type axiom-set axset) |
| 495 | (values t)) | |
| 420 | (values t)) | |
| 496 | 421 | (setf (axiom-set$variables axset) nil |
| 497 | (axiom-set$equations axset) nil | |
| 498 | (axiom-set$rules axset) nil)) | |
| 422 | (axiom-set$equations axset) nil | |
| 423 | (axiom-set$rules axset) nil)) | |
| 499 | 424 | |
| 500 | 425 | (defun clean-up-axiom-set (axset) |
| 501 | 426 | (declare (type axiom-set axset) |
| 502 | (values t)) | |
| 427 | (values t)) | |
| 503 | 428 | (initialize-axiom-set axset)) |
| 504 | 429 | |
| 505 | 430 | ;;; ***************** |
| 516 | 441 | ;;; builtin-info part of builtin sorts. |
| 517 | 442 | ;;; |
| 518 | 443 | |
| 519 | #|| | |
| 520 | (defstruct (parse-dictionary (:conc-name "DICTIONARY-") | |
| 521 | ;; #+gcl (:static t) | |
| 522 | ) | |
| 523 | (table (make-hash-table :test #'equal :size 50) | |
| 524 | :type (or null hash-table)) | |
| 525 | (builtins nil :type list) | |
| 526 | (juxtaposition nil :type list) ; list of juxtaposition methods. | |
| 527 | ) | |
| 528 | ||# | |
| 529 | ||
| 530 | 444 | ;;; accessors via module, all are setf'able |
| 531 | 445 | |
| 532 | 446 | (defmacro module-dictionary-table (_mod) `(dictionary-table |
| 533 | (module-parse-dictionary | |
| 534 | ,_mod))) | |
| 447 | (module-parse-dictionary | |
| 448 | ,_mod))) | |
| 535 | 449 | (defmacro module-dictionary-builtins (_mod) `(dictionary-builtins |
| 536 | (module-parse-dictionary ,_mod))) | |
| 450 | (module-parse-dictionary ,_mod))) | |
| 537 | 451 | (defmacro module-juxtaposition (_mod) `(dictionary-juxtaposition |
| 538 | (module-parse-dictionary ,_mod))) | |
| 452 | (module-parse-dictionary ,_mod))) | |
| 539 | 453 | |
| 540 | 454 | ;;; clear-parse-dict : Dictionary -> Dictionary |
| 541 | 455 | ;;; |
| 542 | 456 | (defun clear-parse-dict (dict) |
| 543 | 457 | (declare (type parse-dictionary dict) |
| 544 | (values parse-dictionary)) | |
| 458 | (values parse-dictionary)) | |
| 545 | 459 | (clrhash (dictionary-table dict)) |
| 546 | 460 | (setf (dictionary-builtins dict) nil |
| 547 | (dictionary-juxtaposition dict) nil) | |
| 461 | (dictionary-juxtaposition dict) nil) | |
| 548 | 462 | dict) |
| 549 | 463 | |
| 550 | 464 | ;;; initialization |
| 551 | 465 | (defun initialize-parse-dictionary (pd) |
| 552 | 466 | (declare (type parse-dictionary pd) |
| 553 | (values t)) | |
| 467 | (values t)) | |
| 554 | 468 | (if (dictionary-table pd) |
| 555 | 469 | (clrhash (dictionary-table pd))) |
| 556 | 470 | (setf (dictionary-builtins pd) nil |
| 557 | (dictionary-juxtaposition pd) nil)) | |
| 471 | (dictionary-juxtaposition pd) nil)) | |
| 558 | 472 | |
| 559 | 473 | (defun clean-up-parse-dictionary (dict) |
| 560 | 474 | (declare (type parse-dictionary dict) |
| 561 | (values t)) | |
| 475 | (values t)) | |
| 562 | 476 | (initialize-parse-dictionary dict) |
| 563 | 477 | (setf (dictionary-table dict) nil)) |
| 564 | 478 | |
| 566 | 480 | ;;; TRS________________________________________________________________________ |
| 567 | 481 | ;;; *** |
| 568 | 482 | |
| 569 | #|| | |
| 570 | (let ((.ext-rule-table-symbol-num. 0)) | |
| 571 | (declare (type fixnum .ext-rule-table-symbol-num.)) | |
| 572 | (defun make-ext-rule-table-name () | |
| 573 | (declare (values symbol)) | |
| 574 | (intern (format nil "ext-rule-table-~d" (incf .ext-rule-table-symbol-num.)))) | |
| 575 | ) | |
| 576 | ||
| 577 | ;;; The structure TRS is a representative of flattened module. | |
| 578 | ||
| 579 | (defstruct (TRS (:conc-name trs$) | |
| 580 | ;; #+gcl (:static t) | |
| 581 | ) | |
| 582 | (module nil :type (or null module)) ; the reverse pointer | |
| 583 | ;; SIGNATURE INFO | |
| 584 | (opinfo-table (make-hash-table :test #'eq) | |
| 585 | :type (or null hash-table)) | |
| 586 | ; operator infos | |
| 587 | (sort-order (make-hash-table :test #'eq) | |
| 588 | :type (or null hash-table)) | |
| 589 | ; transitive closure of sort-relations | |
| 590 | ;; (ext-rule-table (make-hash-table :test #'eq)) | |
| 591 | (ext-rule-table (make-ext-rule-table-name) | |
| 592 | :type symbol) | |
| 593 | ; assoc table of rule A,AC extensions | |
| 594 | ;; | |
| 595 | (sorts nil :type list) ; list of all sorts | |
| 596 | (operators nil :type list) ; list of all operators | |
| 597 | ;; REWRITE RULES | |
| 598 | (rules nil :type list) ; list of all rewrite rules. | |
| 599 | ;; INFO FOR EXTERNAL INTERFACE ----------------------------------- | |
| 600 | (sort-name-map nil :type list) | |
| 601 | (op-info-map nil :type list) | |
| 602 | (op-rev-table nil :type list) | |
| 603 | ;; GENERATED OPS & AXIOMS for equalities & if_then_else_fi | |
| 604 | ;; for proof support system. | |
| 605 | (sort-graph nil :type list) | |
| 606 | (err-sorts nil :type list) | |
| 607 | (dummy-methods nil :type list) | |
| 608 | (sem-relations nil :type list) ; without error sorts | |
| 609 | (sem-axioms nil :type list) ; ditto | |
| 610 | ;; a status TRAM interface generated? | |
| 611 | (tram nil :type symbol) ; nil,:eq, or :all | |
| 612 | ) | |
| 613 | ||
| 614 | ||# | |
| 615 | ||
| 616 | 483 | ;;; accessor via module, all are setf'able. |
| 617 | 484 | (defmacro module-rewrite-rules (_mod) `(trs$rules (module-trs ,_mod))) |
| 618 | 485 | (defmacro module-all-rules (_mod) `(trs$rules (module-trs ,_mod))) ; synonym |
| 619 | 486 | |
| 620 | 487 | (defmacro module-all-sorts (_mod_) `(trs$sorts (module-trs ,_mod_))) |
| 621 | 488 | (defmacro module-all-operators (_mod_) `(trs$operators |
| 622 | (module-trs ,_mod_))) | |
| 489 | (module-trs ,_mod_))) | |
| 623 | 490 | (defmacro module-sort-order (_mod_) `(trs$sort-order |
| 624 | (module-trs ,_mod_))) | |
| 491 | (module-trs ,_mod_))) | |
| 625 | 492 | (defmacro module-opinfo-table (_mod_) `(trs$opinfo-table |
| 626 | (module-trs ,_mod_))) | |
| 493 | (module-trs ,_mod_))) | |
| 627 | 494 | |
| 628 | 495 | (defmacro module-ext-rule-table (_mod_) |
| 629 | 496 | `(trs$ext-rule-table (module-trs ,_mod_))) |
| 650 | 517 | ;;; initialization |
| 651 | 518 | (defun initialize-trs-ext-interface (trs) |
| 652 | 519 | (declare (type trs trs) |
| 653 | (values t)) | |
| 520 | (values t)) | |
| 654 | 521 | (setf (trs$sort-name-map trs) nil |
| 655 | (trs$op-info-map trs) nil | |
| 656 | (trs$op-rev-table trs) nil | |
| 657 | (trs$sort-graph trs) nil | |
| 658 | (trs$err-sorts trs) nil | |
| 659 | (trs$dummy-methods trs) nil | |
| 660 | (trs$sem-relations trs) nil | |
| 661 | (trs$sem-axioms trs) nil | |
| 662 | (trs$tram trs) nil) | |
| 522 | (trs$op-info-map trs) nil | |
| 523 | (trs$op-rev-table trs) nil | |
| 524 | (trs$sort-graph trs) nil | |
| 525 | (trs$err-sorts trs) nil | |
| 526 | (trs$dummy-methods trs) nil | |
| 527 | (trs$sem-relations trs) nil | |
| 528 | (trs$sem-axioms trs) nil | |
| 529 | (trs$tram trs) nil) | |
| 663 | 530 | ) |
| 664 | 531 | |
| 665 | 532 | (defun initialize-trs (trs mod) |
| 666 | 533 | (declare (type trs trs) |
| 667 | (type module mod) | |
| 668 | (values t)) | |
| 534 | (type module mod) | |
| 535 | (values t)) | |
| 669 | 536 | (setf (trs$module trs) mod) |
| 670 | 537 | (setf (trs$sorts trs) nil |
| 671 | (trs$operators trs) nil | |
| 672 | (trs$rules trs) nil) | |
| 538 | (trs$operators trs) nil | |
| 539 | (trs$rules trs) nil) | |
| 673 | 540 | (initialize-trs-ext-interface trs) |
| 674 | 541 | (if (the (or null hash-table) (trs$sort-order trs)) |
| 675 | 542 | (clrhash (trs$sort-order trs)) |
| 676 | 543 | (setf (trs$sort-order trs) |
| 677 | (make-hash-table :test #'eq))) | |
| 544 | (make-hash-table :test #'eq))) | |
| 678 | 545 | (if (the (or null hash-table) (trs$opinfo-table trs)) |
| 679 | 546 | (clrhash (trs$opinfo-table trs)) |
| 680 | 547 | (setf (trs$opinfo-table trs) |
| 681 | (make-hash-table :test #'eq))) | |
| 548 | (make-hash-table :test #'eq))) | |
| 682 | 549 | #|| |
| 683 | 550 | (if (trs$ext-rule-table trs) |
| 684 | 551 | (clrhash (trs$ext-rule-table trs)) |
| 685 | 552 | (setf (trs$ext-rule-table trs) |
| 686 | (make-hash-table :test #'eq))) | |
| 553 | (make-hash-table :test #'eq))) | |
| 687 | 554 | ||# |
| 688 | 555 | (if (trs$ext-rule-table trs) |
| 689 | 556 | (setf (get (trs$ext-rule-table trs) :ext-rules) |
| 690 | nil) | |
| 557 | nil) | |
| 691 | 558 | (setf (trs$ext-rule-table trs) |
| 692 | (make-ext-rule-table-name))) | |
| 559 | (make-ext-rule-table-name))) | |
| 693 | 560 | ) |
| 694 | 561 | |
| 695 | 562 | (defun clean-up-trs (trs) |
| 696 | 563 | (declare (type trs trs) |
| 697 | (values t)) | |
| 564 | (values t)) | |
| 698 | 565 | (setf (trs$module trs) nil) |
| 699 | 566 | (setf (trs$sorts trs) nil |
| 700 | (trs$operators trs) nil | |
| 701 | (trs$rules trs) nil) | |
| 567 | (trs$operators trs) nil | |
| 568 | (trs$rules trs) nil) | |
| 702 | 569 | (initialize-trs-ext-interface trs) |
| 703 | 570 | (if (trs$sort-order trs) |
| 704 | 571 | (clrhash (trs$sort-order trs))) |
| 706 | 573 | (if (trs$opinfo-table trs) |
| 707 | 574 | (clrhash (trs$opinfo-table trs))) |
| 708 | 575 | (setf (trs$opinfo-table trs) nil) |
| 709 | #|| | |
| 710 | (if (trs$ext-rule-table trs) | |
| 711 | (clrhash (trs$ext-rule-table trs))) | |
| 712 | ||# | |
| 713 | 576 | (setf (get (trs$ext-rule-table trs) :ext-rules) nil) |
| 714 | 577 | ) |
| 715 | 578 | |
| 717 | 580 | ;;; CONTEXT_____________________________________________________________________ |
| 718 | 581 | ;;; ******* |
| 719 | 582 | ;;; holds some run time context infos. |
| 720 | ||
| 721 | #|| | |
| 722 | (defstruct (module-context | |
| 723 | ;; #+gcl (:static t) | |
| 724 | ) | |
| 725 | (bindings nil :type list) ; top level let binding | |
| 726 | (special-bindings nil :type list) ; users $$variables ... | |
| 727 | ($$term nil :type list) ; $$term | |
| 728 | ($$subterm nil :type list) ; $$subterm | |
| 729 | ($$action-stack nil :type list) ; action stack for apply | |
| 730 | ($$selection-stack nil :type list) ; selection stack for choose | |
| 731 | ($$stop-pattern nil :type list) ; stop pattern | |
| 732 | ) | |
| 733 | ||# | |
| 734 | ||
| 735 | 583 | ;;; accessors via module, all are setf'able. |
| 736 | 584 | |
| 737 | 585 | (defmacro module-bindings (_mod) `(module-context-bindings (module-context |
| 738 | ,_mod))) | |
| 586 | ,_mod))) | |
| 739 | 587 | (defmacro module-special-bindings (_mod) `(module-context-bindings |
| 740 | (module-context ,_mod))) | |
| 588 | (module-context ,_mod))) | |
| 741 | 589 | (defmacro module-$$term (_mod) `(module-context-$$term (module-context ,_mod))) |
| 742 | 590 | (defmacro module-$$subterm (_mod) `(module-context-$$subterm (module-context |
| 743 | ,_mod))) | |
| 591 | ,_mod))) | |
| 744 | 592 | (defmacro module-$$action-stack (_mod) `(module-context-$$action-stack |
| 745 | (module-context ,_mod))) | |
| 593 | (module-context ,_mod))) | |
| 746 | 594 | (defmacro module-$$selection-stack (_mod) `(module-context-$$selection-stack |
| 747 | (module-context ,_mod))) | |
| 595 | (module-context ,_mod))) | |
| 748 | 596 | |
| 749 | 597 | ;;; intialization |
| 750 | 598 | (defun initialize-module-context (context) |
| 751 | (declare (type module-context context) | |
| 752 | (values t)) | |
| 599 | (declare (type module-dyn-context context) | |
| 600 | (values t)) | |
| 753 | 601 | (setf (module-context-bindings context) nil |
| 754 | (module-context-special-bindings context) nil | |
| 755 | (module-context-$$term context) nil | |
| 756 | (module-context-$$subterm context) nil | |
| 757 | (module-context-$$action-stack context) nil | |
| 758 | (module-context-$$selection-stack context) nil | |
| 759 | (module-context-$$ptree context) nil) | |
| 602 | (module-context-special-bindings context) nil | |
| 603 | (module-context-$$term context) nil | |
| 604 | (module-context-$$subterm context) nil | |
| 605 | (module-context-$$action-stack context) nil | |
| 606 | (module-context-$$selection-stack context) nil | |
| 607 | (module-context-$$ptree context) nil) | |
| 760 | 608 | ) |
| 761 | 609 | |
| 762 | 610 | (defun clean-up-context (context) |
| 763 | (declare (type module-context context) | |
| 764 | (values t)) | |
| 611 | (declare (type module-dyn-context context) | |
| 612 | (values t)) | |
| 765 | 613 | (initialize-module-context context)) |
| 766 | 614 | |
| 767 | 615 | ;;; ************** |
| 776 | 624 | ;;; protected-modules ; list of modules imported as :protecting |
| 777 | 625 | ;;; module-type ; one of :hard, :user, :system |
| 778 | 626 | ;;; module-kind ; one of :theory, :object, :module |
| 779 | ;;; void-sorts ; list of sorts with no constructor. | |
| 780 | ;;; void-methods ; list of methods with some arity | |
| 781 | ;;; ; contains void sort. | |
| 782 | ;;; sorts-for-regularity ; list of sorts generated to make the | |
| 783 | ;;; ; module's signature regular. | |
| 784 | ;;; methods-for-regularity ; list of methods generated to make the | |
| 785 | ;;; ; module's signaure regular. | |
| 786 | ;;; | |
| 787 | ;;; methods-with-rwl-axiom nil ; methods for which the congruence | |
| 788 | ;;; ; relation w.r.t ==> is already generated. | |
| 789 | ;;; rules-with-rwl-axiom nil ; rules for which the congruence | |
| 790 | ;;; ; relation w.r.t ==> is already generated. | |
| 791 | ;;; beh-attributes nil ; list of operator method which is attribute | |
| 792 | ;;; beh-methods nil ; list of operator method which is method | |
| 627 | ;;; void-sorts ; list of sorts with no constructor. | |
| 628 | ;;; void-methods ; list of methods with some arity | |
| 629 | ;;; ; contains void sort. | |
| 630 | ;;; sorts-for-regularity ; list of sorts generated to make the | |
| 631 | ;;; ; module's signature regular. | |
| 632 | ;;; methods-for-regularity ; list of methods generated to make the | |
| 633 | ;;; ; module's signaure regular. | |
| 634 | ;;; | |
| 635 | ;;; methods-with-rwl-axiom nil ; methods for which the congruence | |
| 636 | ;;; ; relation w.r.t ==> is already generated. | |
| 637 | ;;; rules-with-rwl-axiom nil ; rules for which the congruence | |
| 638 | ;;; ; relation w.r.t ==> is already generated. | |
| 639 | ;;; beh-attributes nil ; list of operator method which is attribute | |
| 640 | ;;; beh-methods nil ; list of operator method which is method | |
| 793 | 641 | ;;; methods-with-beh-axiom nil |
| 794 | ;;; beh-axioms-prooved nil ; | |
| 642 | ;;; beh-axioms-prooved nil ; | |
| 795 | 643 | ;;; psort-decl ; declaration form of principal sort |
| 796 | 644 | ;;; error-op-decl ; declaration forms of explicit error |
| 797 | ;;; ; operators. may contain illegual ones. | |
| 798 | ;;; macros | |
| 799 | ;;; | |
| 645 | ||
| 800 | 646 | (defun module-infos (mod) (object-misc-info mod)) |
| 647 | ||
| 801 | 648 | (defsetf module-infos (mod) (values) |
| 802 | 649 | `(setf (object-misc-info ,mod) ,values)) |
| 803 | 650 | |
| 808 | 655 | ;;; TYPE |
| 809 | 656 | (defmacro module-type (_mod) |
| 810 | 657 | `(getf (object-misc-info ,_mod) ':module-type)) |
| 811 | ||
| 658 | ||
| 812 | 659 | (defmacro module-is-hard-wired (_mod_) |
| 813 | 660 | `(eq :hard (module-type ,_mod_))) |
| 814 | 661 | |
| 823 | 670 | (defmacro module-hidden (_mod) |
| 824 | 671 | ` (getf (object-misc-info ,_mod) ':module-hidden)) |
| 825 | 672 | |
| 826 | ;;; KIND | |
| 827 | (defmacro module-kind (_mod) | |
| 828 | `(getf (object-misc-info ,_mod) ':module-kind)) | |
| 829 | ||
| 830 | (defmacro module-is-theory (_mod_) `(eq :theory (module-kind ,_mod_))) | |
| 831 | ||
| 832 | (defmacro module-is-object (_mod_) `(eq :object (module-kind ,_mod_))) | |
| 833 | ||
| 834 | (defmacro module-is-final (_mod_) `(eq :theory (module-kind ,_mod_))) | |
| 835 | ||
| 836 | (defmacro module-is-loose (_mod_) | |
| 837 | ` (memq (module-kind ,_mod_) '(:module :ots))) | |
| 838 | ||
| 839 | (defmacro module-is-initial (_mod_) `(eq (module-kind ,_mod_) :object)) | |
| 840 | ||
| 841 | 673 | ;;; REGULARITY |
| 842 | 674 | (defmacro module-is-regular (_mod) |
| 843 | 675 | `(getf (object-misc-info ,_mod) ':modle-is-regular)) |
| 844 | ||
| 845 | ;;; ALL-SUBMODULES-LIST -- cached data | |
| 846 | ;;; OBSOLETE | |
| 847 | ;;; (defun module-all-submodules-list (mod) | |
| 848 | ;;; (or (object-misc-info-all-submodules-list (object-misc-info mod)) | |
| 849 | ;;; (setf (object-misc-info-all-submodules-list (object-misc-info mod)) | |
| 850 | ;;; (mapcar #'car (module-all-submodules mod))))) | |
| 851 | 676 | |
| 852 | 677 | ;;; ADD-IMPORTED-MODULE : module mode submodule [alias] -> void |
| 853 | 678 | ;;; (for downward comatibility.) |
| 858 | 683 | (when (rassoc alias (module-alias module) :test #'equal) |
| 859 | 684 | (with-output-chaos-error ('invalid-alias) |
| 860 | 685 | (format t "Alias name ~A is already used for module ~A." |
| 861 | alias | |
| 862 | (get-module-print-name submod)))) | |
| 686 | alias | |
| 687 | (get-module-print-name submod)))) | |
| 863 | 688 | (push (cons submod alias) (module-alias module))) |
| 864 | 689 | |
| 865 | 690 | (defun add-imported-module (module mode submodule &optional alias) |
| 866 | 691 | (declare (type module module submodule) |
| 867 | (type symbol mode) | |
| 868 | (values t)) | |
| 692 | (type symbol mode) | |
| 693 | (values t)) | |
| 869 | 694 | ;; (setf (module-ex-info-all-submodules-list (object-misc-info module)) nil) |
| 870 | 695 | (when alias |
| 871 | 696 | (add-module-alias module submodule alias)) |
| 875 | 700 | ;;; |
| 876 | 701 | (defun module-includes-rwl (mod) |
| 877 | 702 | (declare (type module mod) |
| 878 | (type (or null t))) | |
| 703 | (type (or null t))) | |
| 879 | 704 | (assq *rwl-module* (module-all-submodules mod))) |
| 880 | 705 | |
| 881 | 706 | |
| 933 | 758 | |
| 934 | 759 | (defun initialize-module-instance-db (mod) |
| 935 | 760 | (declare (type module mod) |
| 936 | (values t)) | |
| 761 | (values t)) | |
| 937 | 762 | (let ((db (module-instance-db mod))) |
| 938 | 763 | (if db |
| 939 | (clrhash db) | |
| 940 | (setf (module-instance-db mod) (make-hash-table :test #'equal))))) | |
| 764 | (clrhash db) | |
| 765 | (setf (module-instance-db mod) (make-hash-table :test #'equal))))) | |
| 941 | 766 | |
| 942 | 767 | (defun clear-module-instance-db (mod) |
| 943 | 768 | (declare (type module mod) |
| 944 | (values t)) | |
| 769 | (values t)) | |
| 945 | 770 | (let ((db (module-instance-db mod))) |
| 946 | 771 | (declare (type (or null hash-table) db)) |
| 947 | 772 | (if db (clrhash db)))) |
| 1027 | 852 | (defmacro sort-is-for-regularity? (_s &optional _mod) |
| 1028 | 853 | (once-only (_s _mod) |
| 1029 | 854 | (if _mod |
| 1030 | ` (and (eq (sort-module ,_s) ,_mod) | |
| 1031 | (member ,_s (module-sorts-for-regularity ,_mod) :test #'eq)) | |
| 1032 | ` (member ,_s (module-sorts-for-regularity (sort-module ,_s)) :test #'eq)))) | |
| 855 | ` (and (eq (sort-module ,_s) ,_mod) | |
| 856 | (member ,_s (module-sorts-for-regularity ,_mod) :test #'eq)) | |
| 857 | ` (member ,_s (module-sorts-for-regularity (sort-module ,_s)) :test #'eq)))) | |
| 1033 | 858 | |
| 1034 | 859 | (defmacro method-is-for-regularity? (_m &optional _mod) |
| 1035 | 860 | (once-only (_m _mod) |
| 1036 | 861 | (if _mod |
| 1037 | ` (and (eq (method-module ,_m) ,_mod) | |
| 1038 | (member ,_m (module-methods-for-regularity ,_mod) :test #'eq)) | |
| 1039 | ` (member ,_m (module-methods-for-regularity (method-module ,_m)) | |
| 1040 | :test #'eq)))) | |
| 862 | ` (and (eq (method-module ,_m) ,_mod) | |
| 863 | (member ,_m (module-methods-for-regularity ,_mod) :test #'eq)) | |
| 864 | ` (member ,_m (module-methods-for-regularity (method-module ,_m)) | |
| 865 | :test #'eq)))) | |
| 1041 | 866 | |
| 1042 | 867 | ;;; PRINCIPAL SORT DECLARATION _________________________________________________ |
| 1043 | 868 | |
| 1074 | 899 | (defmacro module-ambig-sorts (_m) `(getf (object-misc-info ,_m) ':ambig-sorts)) |
| 1075 | 900 | (defmacro module-ambig-ops (_m) `(getf (object-misc-info ,_m) ':ambig-ops)) |
| 1076 | 901 | |
| 1077 | ;;; EX-INFO INITIALIZATION ----------------------------------------------------- | |
| 1078 | ;;; OBSOLETE | |
| 1079 | ||
| 1080 | #|| | |
| 1081 | (defun initialize-module-ex-info (ex-info) | |
| 1082 | (setf (module-ex-info-protected-modules ex-info) nil | |
| 1083 | (module-ex-info-hard-wired ex-info) nil | |
| 1084 | (module-ex-info-kind ex-info) nil | |
| 1085 | (module-ex-info-all-submodules-list ex-info) nil | |
| 1086 | (module-ex-info-infos ex-info) nil)) | |
| 1087 | ||
| 1088 | (defun clean-up-ex-info (ex-info) | |
| 1089 | (initialize-module-ex-info ex-info)) | |
| 1090 | ||
| 1091 | ||# | |
| 1092 | ||
| 1093 | 902 | ;;; ************* |
| 1094 | 903 | ;;; Module status_______________________________________________________________ |
| 1095 | 904 | ;;; ************* |
| 1099 | 908 | ;;; 1 : regularized -- NOT USED. |
| 1100 | 909 | ;;; 2 : prepared for parsing |
| 1101 | 910 | ;;; 3 : prepared for rewriting |
| 1102 | ;;; | |
| 911 | (defparameter module-initial -1) | |
| 912 | (defparameter module-inconsistent 0) | |
| 913 | (defparameter module-regularized 1) | |
| 914 | (defparameter module-ready-parsing 2) | |
| 915 | (defparameter module-ready-rewriting 3) | |
| 916 | ||
| 1103 | 917 | ;;; o Adding new sort or operator declarations makes the module status to 0. |
| 1104 | 918 | ;;; o Adding new rule makes the module status to at most 2. |
| 1105 | 919 | ;;; o Some changes in any submodule makes the status to 0. |
| 1106 | 920 | ;;; (should be more fine grained checking for statu change). |
| 1107 | ;;; | |
| 1108 | ;;; (defmacro module-status (_mod) `(object-status ,_mod)) | |
| 1109 | 921 | |
| 1110 | 922 | ;;; initial inconsistent status |
| 1111 | 923 | |
| 1112 | (defmacro module-is-inconsistent (_module) | |
| 1113 | `(object-is-inconsistent ,_module)) | |
| 924 | (defun module-is-inconsistent (_module) | |
| 925 | (object-is-inconsistent _module)) | |
| 1114 | 926 | |
| 1115 | 927 | (defun mark-module-as-inconsistent (_module) |
| 1116 | 928 | (mark-object-as-inconsistent _module)) |
| 1118 | 930 | ;;; parsing preparation |
| 1119 | 931 | |
| 1120 | 932 | (defmacro need-parsing-preparation (_module) |
| 1121 | `(< (module-status ,_module) 2)) | |
| 933 | `(< (module-status ,_module) module-ready-parsing)) | |
| 1122 | 934 | |
| 1123 | 935 | (defmacro module-is-ready-for-parsing (_module) |
| 1124 | `(>= (module-status ,_module) 2)) | |
| 936 | `(>= (module-status ,_module) module-ready-parsing)) | |
| 1125 | 937 | |
| 1126 | 938 | (defmacro mark-module-ready-for-parsing (_module) |
| 1127 | `(setf (module-status ,_module) (max 2 (module-status ,_module)))) | |
| 939 | `(setf (module-status ,_module) (max module-ready-parsing (module-status ,_module)))) | |
| 1128 | 940 | |
| 1129 | 941 | (defmacro mark-need-parsing-preparation (_module) |
| 1130 | `(setf (module-status ,_module) (min 1 (module-status ,_module)))) | |
| 942 | `(setf (module-status ,_module) (min module-regularized (module-status ,_module)))) | |
| 1131 | 943 | |
| 1132 | 944 | ;;; rewriting preparation |
| 1133 | 945 | |
| 1134 | 946 | (defmacro need-rewriting-preparation (_module) |
| 1135 | `(< (module-status ,_module) 3)) | |
| 947 | `(< (module-status ,_module) module-ready-rewriting)) | |
| 1136 | 948 | |
| 1137 | 949 | (defmacro module-is-ready-for-rewriting (_module) |
| 1138 | `(>= (module-status ,_module) 3)) | |
| 950 | `(>= (module-status ,_module) module-ready-rewriting)) | |
| 1139 | 951 | |
| 1140 | 952 | (defmacro mark-module-as-consistent (_module) |
| 1141 | `(setf (module-status ,_module) 3)) | |
| 953 | `(setf (module-status ,_module) module-ready-rewriting)) | |
| 1142 | 954 | |
| 1143 | 955 | (defmacro mark-module-ready-for-rewriting (_module) |
| 1144 | 956 | `(mark-module-as-consistent ,_module)) |
| 1145 | 957 | |
| 1146 | 958 | (defmacro mark-module-need-rewriting-preparation (_module) |
| 1147 | `(setf (module-status ,_module) (min 2 (module-status ,_module)))) | |
| 959 | `(setf (module-status ,_module) (min module-ready-parsing (module-status ,_module)))) | |
| 1148 | 960 | |
| 1149 | 961 | ;;; some handy procs. |
| 1150 | 962 | |
| 1157 | 969 | (defmacro needs-rule (&optional (_module '*current-module*)) |
| 1158 | 970 | `(compile-module ,_module)) |
| 1159 | 971 | |
| 1160 | ;;; ******* | |
| 1161 | ;;; PRINTER | |
| 1162 | ;;; ******* | |
| 1163 | ||
| 1164 | (defun print-module-object (obj stream &rest ignore) | |
| 1165 | (declare (ignore ignore) | |
| 1166 | (type module obj) | |
| 1167 | (type stream stream) | |
| 1168 | (values t)) | |
| 1169 | (if (or (module-is-inconsistent obj) | |
| 1170 | (null (module-name obj))) | |
| 1171 | (format stream "[:module \"~a\"]" (module-name obj)) | |
| 1172 | (cond ((module-is-object obj) | |
| 1173 | (format stream ":mod![\"~a\"]" (module-print-name obj))) | |
| 1174 | ((module-is-theory obj) | |
| 1175 | (format stream ":mod*[\"~a\"]" (module-print-name obj))) | |
| 1176 | (t (format stream ":mod[\"~a\"]" (module-print-name obj)))))) | |
| 1177 | ||
| 1178 | 972 | ;;; ********************************* |
| 1179 | 973 | ;;; Constructing RUN TIME ENVIRONMENT ----------------------------------------- |
| 1180 | 974 | ;;; ********************************* |
| 1185 | 979 | ;;; module. |
| 1186 | 980 | ;;; *current-opinfo-table* : operator information table of the current module . |
| 1187 | 981 | ;;; |
| 1188 | ||
| 1189 | 982 | (defmacro with-in-module ((_module_) &body body) |
| 1190 | 983 | (once-only (_module_) |
| 1191 | 984 | ` (block with-in-module |
| 1192 | (let* ((*current-module* ,_module_) | |
| 1193 | (*current-sort-order* (module-sort-order *current-module*)) | |
| 1194 | (*current-opinfo-table* (module-opinfo-table *current-module*)) | |
| 1195 | (*current-ext-rule-table* (module-ext-rule-table *current-module*))) | |
| 1196 | (declare (special *current-module* | |
| 1197 | *current-sort-order* | |
| 1198 | *current-opinfo-table* | |
| 1199 | *current-ext-rule-table*)) | |
| 1200 | ;; | |
| 1201 | ,@body)))) | |
| 985 | (let* ((*current-module* ,_module_) | |
| 986 | (*current-sort-order* (module-sort-order *current-module*)) | |
| 987 | (*current-opinfo-table* (module-opinfo-table *current-module*)) | |
| 988 | (*current-ext-rule-table* (module-ext-rule-table *current-module*))) | |
| 989 | (declare (special *current-module* | |
| 990 | *current-sort-order* | |
| 991 | *current-opinfo-table* | |
| 992 | *current-ext-rule-table*)) | |
| 993 | ;; | |
| 994 | ,@body)))) | |
| 1202 | 995 | |
| 1203 | 996 | (defun change-current-module (mod) |
| 1204 | 997 | (declare (type (or null module) mod) |
| 1205 | (values t)) | |
| 998 | (values t)) | |
| 1206 | 999 | (when mod |
| 1207 | 1000 | (setf *current-module* mod |
| 1208 | *current-sort-order* (module-sort-order mod) | |
| 1209 | *current-opinfo-table* (module-opinfo-table mod) | |
| 1210 | *current-ext-rule-table* (module-ext-rule-table mod)) | |
| 1001 | *current-sort-order* (module-sort-order mod) | |
| 1002 | *current-opinfo-table* (module-opinfo-table mod) | |
| 1003 | *current-ext-rule-table* (module-ext-rule-table mod)) | |
| 1211 | 1004 | mod)) |
| 1212 | 1005 | |
| 1213 | 1006 | ;;; ********* |
| 1235 | 1028 | #-gcl |
| 1236 | 1029 | (defun equal-top-level (x y) |
| 1237 | 1030 | (cond ((stringp x) (equal x y)) |
| 1238 | ((atom x) (eql x y)) | |
| 1239 | ((atom y) nil) | |
| 1240 | (t (and (equal-top-level (car x) (car y)) | |
| 1241 | (equal-top-level (cdr x) (cdr y)))))) | |
| 1031 | ((atom x) (eql x y)) | |
| 1032 | ((atom y) nil) | |
| 1033 | (t (and (equal-top-level (car x) (car y)) | |
| 1034 | (equal-top-level (cdr x) (cdr y)))))) | |
| 1242 | 1035 | |
| 1243 | 1036 | #+gcl |
| 1244 | 1037 | (si::define-inline-function equal-top-level (x y) |
| 1245 | 1038 | (cond ((stringp x) (equal x y)) |
| 1246 | ((atom x) (eql x y)) | |
| 1247 | ((atom y) nil) | |
| 1248 | (t (and (equal-top-level (car x) (car y)) | |
| 1249 | (equal-top-level (cdr x) (cdr y)))))) | |
| 1039 | ((atom x) (eql x y)) | |
| 1040 | ((atom y) nil) | |
| 1041 | (t (and (equal-top-level (car x) (car y)) | |
| 1042 | (equal-top-level (cdr x) (cdr y)))))) | |
| 1250 | 1043 | |
| 1251 | 1044 | (defun find-equivalent-module-in-env (me) |
| 1252 | 1045 | (dolist (entry *modules-so-far-table*) |
| 1253 | 1046 | (let ((key (car entry)) |
| 1254 | (val (cdr entry))) | |
| 1047 | (val (cdr entry))) | |
| 1255 | 1048 | (when (equal-top-level me key) |
| 1256 | (return-from find-equivalent-module-in-env val)))) | |
| 1049 | (return-from find-equivalent-module-in-env val)))) | |
| 1257 | 1050 | nil) |
| 1258 | 1051 | |
| 1259 | 1052 | ;;; used in eval-module |
| 1303 | 1096 | (declare (type (or null module) context)) |
| 1304 | 1097 | (if context |
| 1305 | 1098 | (or (get-modexp-local (list me (module-name context))) |
| 1306 | (find-modexp-eval me) | |
| 1307 | (find-global-module me)) | |
| 1099 | (find-modexp-eval me) | |
| 1100 | (find-global-module me)) | |
| 1308 | 1101 | (or (find-modexp-eval me) |
| 1309 | (find-global-module me)))) | |
| 1102 | (find-global-module me)))) | |
| 1310 | 1103 | |
| 1311 | 1104 | (defun find-module-in-env-ext (name &optional (context *current-module*) |
| 1312 | no-error) | |
| 1105 | no-error) | |
| 1313 | 1106 | (declare (type (or module simple-string) name) |
| 1314 | (type (or null module) context)) | |
| 1107 | (type (or null module) context)) | |
| 1315 | 1108 | ;; |
| 1316 | 1109 | (when (module-p name) |
| 1317 | 1110 | (return-from find-module-in-env-ext name)) |
| 1324 | 1117 | ;; scan qualifires from right to left |
| 1325 | 1118 | ;; the last one is the target we are looking for. |
| 1326 | 1119 | (let ((c context) |
| 1327 | (tmod nil)) | |
| 1120 | (tmod nil)) | |
| 1328 | 1121 | (dolist (qname (reverse quals)) |
| 1329 | (let ((subs (module-all-submodules c))) | |
| 1330 | (setq tmod (or (find-module-in-sublist qname subs c) | |
| 1331 | ;; Wed Feb 17 13:27:44 JST 1999 | |
| 1332 | ;; (find-module-in-env qname c) | |
| 1333 | nil)) | |
| 1334 | (unless tmod | |
| 1335 | (when no-error | |
| 1336 | (return-from find-module-in-env-ext nil)) | |
| 1337 | ;; (break) | |
| 1338 | (with-output-chaos-error ('no-such-module) | |
| 1339 | (format t "no such module ~a in the context " | |
| 1340 | qname) | |
| 1341 | (print-mod-name context *standard-output* t) | |
| 1342 | )) | |
| 1343 | (when (atom tmod) (setq tmod (list tmod))) | |
| 1344 | (when (cdr tmod) | |
| 1345 | (with-output-chaos-error ('ambiguous-module-name) | |
| 1346 | (format t "module name ~a is ambiguous in the context." | |
| 1347 | qname) | |
| 1348 | (print-mod-name context *standard-output* t) | |
| 1349 | )) | |
| 1350 | (setq c (car tmod)))) | |
| 1122 | (let ((subs (module-all-submodules c))) | |
| 1123 | (setq tmod (or (find-module-in-sublist qname subs c) | |
| 1124 | ;; Wed Feb 17 13:27:44 JST 1999 | |
| 1125 | ;; (find-module-in-env qname c) | |
| 1126 | nil)) | |
| 1127 | (unless tmod | |
| 1128 | (when no-error | |
| 1129 | (return-from find-module-in-env-ext nil)) | |
| 1130 | ;; (break) | |
| 1131 | (with-output-chaos-error ('no-such-module) | |
| 1132 | (format t "no such module ~a in the context " | |
| 1133 | qname) | |
| 1134 | (print-mod-name context *standard-output* t) | |
| 1135 | )) | |
| 1136 | (when (atom tmod) (setq tmod (list tmod))) | |
| 1137 | (when (cdr tmod) | |
| 1138 | (with-output-chaos-error ('ambiguous-module-name) | |
| 1139 | (format t "module name ~a is ambiguous in the context." | |
| 1140 | qname) | |
| 1141 | (print-mod-name context *standard-output* t) | |
| 1142 | )) | |
| 1143 | (setq c (car tmod)))) | |
| 1351 | 1144 | (car tmod)))) |
| 1352 | 1145 | |
| 1353 | 1146 | (defun find-module-in-sublist (name subs &optional (context *current-module*)) |
| 1354 | 1147 | (let ((res nil)) |
| 1355 | 1148 | (when context |
| 1356 | 1149 | (let ((als (rassoc name (module-alias context) :test #'equal))) |
| 1357 | (when als | |
| 1358 | (push (car als) res)))) | |
| 1150 | (when als | |
| 1151 | (push (car als) res)))) | |
| 1359 | 1152 | (dolist (sub subs) |
| 1360 | 1153 | (let* ((smod (car sub)) |
| 1361 | (sname (module-name smod))) | |
| 1362 | ;; we eliminate :using | |
| 1363 | (unless (eq (cdr sub) :using) | |
| 1364 | (cond ((modexp-is-parameter-theory sname) | |
| 1365 | (if (equal name (car sname)) | |
| 1366 | (pushnew smod res))) | |
| 1367 | (t (if (equal name sname) | |
| 1368 | (pushnew smod res))))))) | |
| 1154 | (sname (module-name smod))) | |
| 1155 | ;; we eliminate :using | |
| 1156 | (unless (eq (cdr sub) :using) | |
| 1157 | (cond ((modexp-is-parameter-theory sname) | |
| 1158 | (if (equal name (car sname)) | |
| 1159 | (pushnew smod res))) | |
| 1160 | (t (if (equal name sname) | |
| 1161 | (pushnew smod res))))))) | |
| 1369 | 1162 | res)) |
| 1370 | 1163 | |
| 1371 | 1164 | ;;; ************** |
| 1382 | 1175 | |
| 1383 | 1176 | (defun clear-method-info-hash () |
| 1384 | 1177 | (setf .method1. nil |
| 1385 | .method-tab1. nil | |
| 1386 | .method-val1. nil | |
| 1387 | .method2. nil | |
| 1388 | .method-tab2. nil | |
| 1389 | .method-val2. nil)) | |
| 1178 | .method-tab1. nil | |
| 1179 | .method-val1. nil | |
| 1180 | .method2. nil | |
| 1181 | .method-tab2. nil | |
| 1182 | .method-val2. nil)) | |
| 1390 | 1183 | |
| 1391 | 1184 | ;;; INITIALIZE-MODULE |
| 1392 | 1185 | |
| 1393 | 1186 | (defun initialize-module (mod) |
| 1394 | 1187 | (declare (type module mod) |
| 1395 | (values t)) | |
| 1396 | ;; | |
| 1397 | (setf (module-status mod) -1) ; initial state. | |
| 1188 | (values t)) | |
| 1189 | (setf (module-status mod) module-initial) ; initial state. | |
| 1398 | 1190 | (setf (module-decl-form mod) nil) |
| 1399 | 1191 | ;; interface |
| 1400 | 1192 | (if (the (or null ex-interface) (module-interface mod)) |
| 1416 | 1208 | (setf (module-parse-dictionary mod) (make-parse-dictionary))) |
| 1417 | 1209 | ;; misc infos |
| 1418 | 1210 | (setf (object-misc-info mod) nil) |
| 1419 | ;;; (if (object-misc-info mod) | |
| 1420 | ;;; (initialize-module-ex-info (module-ex-info mod)) | |
| 1421 | ;;; (setf (module-ex-info mod) (make-module-ex-info))) | |
| 1422 | 1211 | ;; trs |
| 1423 | 1212 | (if (the (or null trs) (module-trs mod)) |
| 1424 | 1213 | (initialize-trs (module-trs mod) mod) |
| 1425 | 1214 | (setf (module-trs mod) (make-trs :module mod))) |
| 1426 | 1215 | ;; context |
| 1427 | (if (the (or null module-context) (module-context mod)) | |
| 1216 | (if (the (or null module-dyn-context) (module-context mod)) | |
| 1428 | 1217 | (initialize-module-context (module-context mod)) |
| 1429 | (setf (module-context mod) (make-module-context))) | |
| 1218 | (setf (module-context mod) (make-module-dyn-context :object mod))) | |
| 1430 | 1219 | ;; symbol table |
| 1431 | 1220 | (setf (module-alias mod) nil) |
| 1432 | 1221 | (setf (module-symbol-table mod) (make-symbol-table)) |
| 1433 | 1222 | ;; print name |
| 1434 | ;; (setf (module-print-name mod) (make-module-print-name2 mod)) | |
| 1435 | 1223 | (setf (module-print-name mod) (make-module-print-name mod)) |
| 1436 | 1224 | ;; |
| 1437 | 1225 | (clear-tmp-sort-cache) |
| 0 | 0 | ;;;-*- Mode:LISP; Package: Chaos; Base:10; Syntax:Common-lisp -*- |
| 1 | 1 | ;;; |
| 2 | ;;; Copyright (c) 2000-2014, Toshimi Sawada. All rights reserved. | |
| 2 | ;;; Copyright (c) 2000-2015, Toshimi Sawada. All rights reserved. | |
| 3 | 3 | ;;; |
| 4 | 4 | ;;; Redistribution and use in source and binary forms, with or without |
| 5 | 5 | ;;; modification, are permitted provided that the following conditions |
| 27 | 27 | ;;; |
| 28 | 28 | (in-package :chaos) |
| 29 | 29 | #|============================================================================== |
| 30 | System: Chaos | |
| 31 | Module: primitives | |
| 32 | File: bobject.lisp | |
| 30 | System: Chaos | |
| 31 | Module: primitives | |
| 32 | File: bobject.lisp | |
| 33 | 33 | ==============================================================================|# |
| 34 | 34 | #-:chaos-debug |
| 35 | 35 | (declaim (optimize (speed 3) (safety 0) #-GCL (debug 0))) |
| 52 | 52 | ;;; definition of semantic object & internal data structure. |
| 53 | 53 | ;;; all objects defined in this file inherits either %object or %int-object. |
| 54 | 54 | |
| 55 | #|| | |
| 56 | ;;; term structure of semantic object of Chaos. | |
| 57 | (defterm object () :category ':object) | |
| 58 | ||
| 59 | (defterm static-object () :category ':static-object) | |
| 60 | ||
| 61 | ;;; structure of internal object of Chaos. | |
| 62 | (defterm int-object () :category ':int-object) | |
| 63 | ||
| 64 | (defterm static-int-object () :category ':static-int-object) | |
| 65 | ||# | |
| 66 | ||
| 67 | 55 | (defstruct (object (:conc-name "OBJECT-") |
| 68 | (:constructor make-object) | |
| 69 | (:constructor object* nil) | |
| 70 | (:copier nil) | |
| 71 | (:include %chaos-object (-type 'object)) | |
| 72 | (:print-function chaos-pr-object)) | |
| 56 | (:constructor make-object) | |
| 57 | (:constructor object* nil) | |
| 58 | (:copier nil) | |
| 59 | (:include %chaos-object (-type 'object)) | |
| 60 | (:print-function chaos-pr-object)) | |
| 73 | 61 | (misc-info nil :type list) |
| 74 | 62 | (context-mod nil)) |
| 75 | 63 | |
| 76 | 64 | (defmacro object-info (_obj _info) |
| 77 | 65 | ` (getf (object-misc-info ,_obj) ,_info)) |
| 78 | 66 | |
| 79 | (defun set-context-module (obj &optional (mod *current-module*)) | |
| 80 | (setf (object-context-mod obj) mod)) | |
| 81 | ||
| 82 | (eval-when (:execute :load-toplevel) | |
| 83 | (setf (symbol-function 'is-object)(symbol-function 'object-p)) | |
| 84 | (setf (get 'object ':type-predicate) (symbol-function 'is-object)) | |
| 85 | (setf (get 'object :eval) nil) | |
| 86 | (setf (get 'object :print) nil)) | |
| 67 | (defun set-object-context-module (obj &optional (context-mod (get-context-module))) | |
| 68 | (setf (object-context-mod obj) context-mod)) | |
| 69 | ||
| 70 | ; (eval-when (:execute :load-toplevel) | |
| 71 | ; (setf (symbol-function 'is-object)(symbol-function 'object-p)) | |
| 72 | ; (setf (get 'object ':type-predicate) (symbol-function 'is-object)) | |
| 73 | ; (setf (get 'object :eval) nil) | |
| 74 | ; (setf (get 'object :print) nil)) | |
| 87 | 75 | |
| 88 | 76 | ;;; ********* |
| 89 | 77 | ;;; INTERFACE |
| 91 | 79 | ;;; gathers informations for external interface of a top-level objects. |
| 92 | 80 | |
| 93 | 81 | (defstruct (ex-interface (:conc-name "INTERFACE$")) |
| 94 | (dag nil :type (or null dag-node)) ; DAG of dependency hierarchy. | |
| 95 | (parameters nil :type list) ; list of parmeter modules. | |
| 96 | ; (also in dag). | |
| 97 | (exporting-objects nil :type list) ; list of objects depending this one. | |
| 98 | ; (object . mode) | |
| 99 | ; mode ::= :protecting | :exporting | :using | |
| 100 | ; | :modmorph | :view | |
| 82 | (dag nil :type (or null dag-node)) ; DAG of dependency hierarchy. | |
| 83 | (parameters nil :type list) ; list of parmeter modules. | |
| 84 | ; (also in dag). | |
| 85 | (exporting-objects nil :type list) ; list of objects depending this one. | |
| 86 | ; (object . mode) | |
| 87 | ; mode ::= :protecting | :exporting | :using | |
| 88 | ; | :modmorph | :view | |
| 101 | 89 | ) |
| 102 | 90 | |
| 103 | 91 | ;;; ************ |
| 118 | 106 | |
| 119 | 107 | (defun canonicalize-object-name (nm) |
| 120 | 108 | (cond ((stringp nm) |
| 121 | (intern nm)) | |
| 122 | ((consp nm) | |
| 123 | (if (cdr nm) | |
| 124 | (mapcar #'canonicalize-object-name nm) | |
| 125 | (canonicalize-object-name (car nm)))) | |
| 126 | ((symbolp nm) nm) | |
| 127 | ((module-p nm) (canonicalize-object-name (module-name nm))) | |
| 128 | (t | |
| 129 | ;; do nothing | |
| 130 | ;; (error "internal error, illegal name object ~s" nm) | |
| 131 | ))) | |
| 109 | (intern nm)) | |
| 110 | ((consp nm) | |
| 111 | (if (cdr nm) | |
| 112 | (mapcar #'canonicalize-object-name nm) | |
| 113 | (canonicalize-object-name (car nm)))) | |
| 114 | ((symbolp nm) nm) | |
| 115 | ((module-p nm) (canonicalize-object-name (module-name nm))) | |
| 116 | (t | |
| 117 | ;; do nothing | |
| 118 | ))) | |
| 132 | 119 | |
| 133 | 120 | (defun symbol-table-add (table nm obj) |
| 134 | 121 | (when (and (module-p obj) |
| 135 | (module-is-parameter-theory obj)) | |
| 122 | (module-is-parameter-theory obj)) | |
| 136 | 123 | (setq nm (car (module-name obj)))) |
| 137 | 124 | (let ((name (canonicalize-object-name nm))) |
| 138 | 125 | (pushnew name (symbol-table-names table) :test #'equal) |
| 139 | 126 | (let* ((map (symbol-table-map table)) |
| 140 | (tbl (gethash name map))) | |
| 127 | (tbl (gethash name map))) | |
| 141 | 128 | (unless tbl |
| 142 | (setf tbl (setf (gethash name map) (make-stable)))) | |
| 129 | (setf tbl (setf (gethash name map) (make-stable)))) | |
| 143 | 130 | (cond ((sort-p obj) |
| 144 | (pushnew obj (stable-sorts tbl))) | |
| 145 | ((operator-p obj) | |
| 146 | (pushnew obj (stable-operators tbl))) | |
| 147 | ((module-p obj) | |
| 148 | (if (module-is-parameter-theory obj) | |
| 149 | (pushnew obj (stable-parameters tbl)) | |
| 150 | (pushnew obj (stable-submodules tbl)))) | |
| 151 | ((axiom-p obj) | |
| 152 | (pushnew obj (stable-axioms tbl))) | |
| 153 | ((and (termp obj) | |
| 154 | (term-is-variable? obj)) | |
| 155 | (pushnew obj (stable-variables tbl))) | |
| 156 | (t (pushnew obj (stable-unknowns tbl)))) | |
| 131 | (pushnew obj (stable-sorts tbl))) | |
| 132 | ((operator-p obj) | |
| 133 | (pushnew obj (stable-operators tbl))) | |
| 134 | ((module-p obj) | |
| 135 | (if (module-is-parameter-theory obj) | |
| 136 | (pushnew obj (stable-parameters tbl)) | |
| 137 | (pushnew obj (stable-submodules tbl)))) | |
| 138 | ((axiom-p obj) | |
| 139 | (pushnew obj (stable-axioms tbl))) | |
| 140 | ((and (termp obj) | |
| 141 | (term-is-variable? obj)) | |
| 142 | (pushnew obj (stable-variables tbl))) | |
| 143 | (t (pushnew obj (stable-unknowns tbl)))) | |
| 157 | 144 | tbl))) |
| 158 | 145 | |
| 159 | (defun symbol-table-get (name &optional (module *current-module*)) | |
| 146 | (defun symbol-table-get (name &optional (module (get-context-module))) | |
| 160 | 147 | (let ((gname (canonicalize-object-name name))) |
| 161 | 148 | (gethash gname (symbol-table-map |
| 162 | (module-symbol-table module))))) | |
| 163 | ||
| 164 | #|| | |
| 165 | (defun pr-symbol-table (st stream &rest ignore) | |
| 166 | (let ((names (copy-list (symbol-table-names st)))) | |
| 167 | (setq names (sort names #'ob<)) | |
| 168 | (dolist (name names) | |
| 169 | (pr-name name (gethash name (symbol-table-map st)) stream)))) | |
| 170 | ||
| 171 | (defun get-object-type (obj) | |
| 172 | (cond ((module-p obj) :module) | |
| 173 | ((sort-p obj) :sort) | |
| 174 | ((operator-p obj) :operator) | |
| 175 | ((axiom-p obj) :axiom) | |
| 176 | ((term-is-variable? obj) :variable) | |
| 177 | (t :unknown))) | |
| 178 | ||
| 179 | (defun get-obj-info (obj) | |
| 180 | (let ((type (get-object-type obj))) | |
| 181 | (cond ((or (eq type :variable) | |
| 182 | (eq (object-context-mod obj) *current-module*)) | |
| 183 | (list obj type "of the current module")) | |
| 184 | ((eq type :unknown) | |
| 185 | (list obj type "unknown type of object")) | |
| 186 | ((object-context-mod obj) | |
| 187 | (list obj | |
| 188 | type | |
| 189 | (concatenate 'string "of module " | |
| 190 | (with-output-to-string (str) | |
| 191 | (print-mod-name (object-context-mod obj) | |
| 192 | str | |
| 193 | t))))) | |
| 194 | (t (list obj type ""))))) | |
| 195 | ||
| 196 | (defun pr-name (name objs stream) | |
| 197 | (format stream "~&~A~8T" name) | |
| 198 | (dolist (obj objs) | |
| 199 | (let ((info (get-obj-info obj))) | |
| 200 | (format stream ": ~A ~A~%" (second info) (third info))))) | |
| 201 | ||# | |
| 149 | (module-symbol-table module))))) | |
| 202 | 150 | |
| 203 | 151 | ;;;============================================================================= |
| 204 | 152 | ;;; TOP-OBJECT _________________________________________________________________ |
| 206 | 154 | |
| 207 | 155 | ;;; represents common structure of top-level semantic objects. |
| 208 | 156 | ;;; |
| 209 | #|| | |
| 210 | (defterm top-object (object) ; was (static-object) | |
| 211 | :visible (name) ; name. | |
| 212 | :hidden (interface ; external interface. | |
| 213 | status ; object status. | |
| 214 | decl-form ; declaration form | |
| 215 | ) | |
| 216 | ) | |
| 217 | ||# | |
| 218 | 157 | (defstruct (top-object (:conc-name "TOP-OBJECT-") |
| 219 | (:constructor make-top-object) | |
| 220 | (:constructor top-object* (name)) | |
| 221 | (:copier nil) | |
| 222 | (:include object (-type 'top-object))) | |
| 158 | (:constructor make-top-object) | |
| 159 | (:constructor top-object* (name)) | |
| 160 | (:copier nil) | |
| 161 | (:include object (-type 'top-object))) | |
| 223 | 162 | (name nil) |
| 224 | 163 | (interface (make-ex-interface) :type (or null ex-interface)) |
| 225 | 164 | (status -1 :type fixnum) |
| 226 | 165 | (decl-form nil :type list) |
| 227 | 166 | (symbol-table (make-symbol-table) :type symbol-table)) |
| 228 | 167 | |
| 229 | (eval-when (:execute :load-toplevel) | |
| 230 | (setf (symbol-function 'is-top-object)(symbol-function 'top-object-p)) | |
| 231 | (setf (get 'top-object ':type-predicate) (symbol-function 'is-top-object)) | |
| 232 | (setf (get 'top-object :eval) nil) | |
| 233 | (setf (get 'top-object :print) nil)) | |
| 168 | ; (eval-when (:execute :load-toplevel) | |
| 169 | ; (setf (symbol-function 'is-top-object)(symbol-function 'top-object-p)) | |
| 170 | ; (setf (get 'top-object ':type-predicate) (symbol-function 'is-top-object)) | |
| 171 | ; (setf (get 'top-object :eval) nil) | |
| 172 | ; (setf (get 'top-object :print) nil)) | |
| 234 | 173 | |
| 235 | 174 | ;;; |
| 236 | 175 | ;;; basic accessors via top-object |
| 240 | 179 | |
| 241 | 180 | (defun object-parameters (_object) |
| 242 | 181 | (declare (type top-object _object) |
| 243 | (values list)) | |
| 182 | (values list)) | |
| 244 | 183 | (let ((interf (top-object-interface _object))) |
| 245 | 184 | (if interf |
| 246 | (interface$parameters interf) | |
| 247 | nil))) | |
| 185 | (interface$parameters interf) | |
| 186 | nil))) | |
| 248 | 187 | |
| 249 | 188 | (defsetf object-parameters (_obj) (_value) |
| 250 | 189 | ` (let ((interf (top-object-interface ,_obj))) |
| 251 | 190 | (unless interf |
| 252 | (with-output-panic-message () | |
| 253 | (princ "invalid interface of object ") | |
| 254 | (print-chaos-object ,_obj) | |
| 255 | (chaos-error 'panic))) | |
| 191 | (with-output-panic-message () | |
| 192 | (princ "invalid interface of object ") | |
| 193 | (print-chaos-object ,_obj) | |
| 194 | (chaos-error 'panic))) | |
| 256 | 195 | (setf (interface$parameters interf) ,_value))) |
| 257 | 196 | |
| 258 | 197 | (defun object-exporting-objects (_object) |
| 259 | 198 | (declare (type top-object _object) |
| 260 | (values list)) | |
| 199 | (values list)) | |
| 261 | 200 | (let ((interf (top-object-interface _object))) |
| 262 | 201 | (if interf |
| 263 | (interface$exporting-objects interf) | |
| 264 | nil))) | |
| 202 | (interface$exporting-objects interf) | |
| 203 | nil))) | |
| 265 | 204 | |
| 266 | 205 | (defsetf object-exporting-objects (_object) (_value) |
| 267 | 206 | ` (let ((interf (top-object-interface ,_object))) |
| 268 | 207 | (unless interf |
| 269 | (with-output-panic-message () | |
| 270 | (princ "exporting-objects: invalid interface of object ") | |
| 271 | (print-chaos-object ,_object) | |
| 272 | (chaos-error 'panic))) | |
| 208 | (with-output-panic-message () | |
| 209 | (princ "exporting-objects: invalid interface of object ") | |
| 210 | (print-chaos-object ,_object) | |
| 211 | (chaos-error 'panic))) | |
| 273 | 212 | (setf (interface$exporting-objects interf) ,_value))) |
| 274 | 213 | |
| 275 | 214 | (defun object-direct-sub-objects (_object) |
| 276 | 215 | (declare (type top-object _object) |
| 277 | (values list)) | |
| 216 | (values list)) | |
| 278 | 217 | (let ((interf (top-object-interface _object))) |
| 279 | 218 | (if interf |
| 280 | (mapcar #'dag-node-datum | |
| 281 | (dag-node-subnodes (interface$dag interf))) | |
| 282 | nil))) | |
| 219 | (mapcar #'dag-node-datum | |
| 220 | (dag-node-subnodes (interface$dag interf))) | |
| 221 | nil))) | |
| 283 | 222 | |
| 284 | 223 | (defun object-all-sub-objects (object) |
| 285 | 224 | (declare (type top-object object) |
| 286 | (values list)) | |
| 225 | (values list)) | |
| 287 | 226 | (when (top-object-interface object) |
| 288 | 227 | (let ((res (cons nil nil))) |
| 289 | 228 | (gather-sub-objects object res) |
| 291 | 230 | |
| 292 | 231 | (defun gather-sub-objects (object res) |
| 293 | 232 | (declare (type top-object object) |
| 294 | (type list res) | |
| 295 | (values list)) | |
| 233 | (type list res) | |
| 234 | (values list)) | |
| 296 | 235 | (let ((dmods (object-direct-sub-objects object))) |
| 297 | 236 | (dolist (dmod dmods) |
| 298 | 237 | (unless (member dmod (car res) :test #'equal) |
| 299 | (push dmod (car res)) | |
| 300 | (gather-sub-objects (car dmod) res))))) | |
| 238 | (push dmod (car res)) | |
| 239 | (gather-sub-objects (car dmod) res))))) | |
| 301 | 240 | |
| 302 | 241 | (defun object-all-exporting-objects (object) |
| 303 | 242 | (declare (type top-object object) |
| 304 | (values list)) | |
| 243 | (values list)) | |
| 305 | 244 | (when (top-object-interface object) |
| 306 | 245 | (let ((res (cons nil nil))) |
| 307 | 246 | (gather-exporting-objects object res) |
| 309 | 248 | |
| 310 | 249 | (defun gather-exporting-objects (object res) |
| 311 | 250 | (declare (type top-object object) |
| 312 | (type list res) | |
| 313 | (values list)) | |
| 251 | (type list res) | |
| 252 | (values list)) | |
| 314 | 253 | (let ((dmods (object-exporting-objects object))) |
| 315 | 254 | (dolist (dmod dmods) |
| 316 | 255 | (unless (member dmod (car res) :test #'equal) |
| 317 | (push dmod (car res)) | |
| 318 | (gather-exporting-objects (car dmod) res))))) | |
| 256 | (push dmod (car res)) | |
| 257 | (gather-exporting-objects (car dmod) res))))) | |
| 319 | 258 | |
| 320 | 259 | ;;; |
| 321 | 260 | ;;; initialization |
| 322 | 261 | ;;; |
| 323 | 262 | (defun initialize-depend-dag (object) |
| 324 | 263 | (declare (type top-object object) |
| 325 | (values t)) | |
| 264 | (values t)) | |
| 326 | 265 | (let ((dag (object-depend-dag object))) |
| 327 | 266 | (if dag |
| 328 | (setf (dag-node-subnodes dag) nil) | |
| 329 | (let ((node (create-dag-node (cons object nil) nil))) | |
| 330 | (setf (object-depend-dag object) node))))) | |
| 267 | (setf (dag-node-subnodes dag) nil) | |
| 268 | (let ((node (create-dag-node (cons object nil) nil))) | |
| 269 | (setf (object-depend-dag object) node))))) | |
| 331 | 270 | |
| 332 | 271 | (defun initialize-object-interface (interface) |
| 333 | 272 | (declare (type ex-interface interface) |
| 334 | (values t)) | |
| 273 | (values t)) | |
| 335 | 274 | (setf (interface$parameters interface) nil) |
| 336 | (setf (interface$exporting-objects interface) nil) | |
| 337 | ) | |
| 275 | (setf (interface$exporting-objects interface) nil)) | |
| 338 | 276 | |
| 339 | 277 | (defun clean-up-ex-interface (interface) |
| 340 | 278 | (declare (type ex-interface interface) |
| 341 | (values t)) | |
| 279 | (values t)) | |
| 342 | 280 | (setf (interface$dag interface) nil) |
| 343 | 281 | (setf (interface$parameters interface) nil) |
| 344 | (setf (interface$exporting-objects interface) nil) | |
| 345 | ) | |
| 282 | (setf (interface$exporting-objects interface) nil)) | |
| 346 | 283 | |
| 347 | 284 | ;;; |
| 348 | 285 | ;;; setting dependency |
| 349 | 286 | ;;; |
| 350 | 287 | (defun add-depend-relation (object mode subobject) |
| 351 | 288 | (declare (type top-object object) |
| 352 | (type symbol mode) | |
| 353 | (type top-object subobject) | |
| 354 | (values t)) | |
| 289 | (type symbol mode) | |
| 290 | (type top-object subobject) | |
| 291 | (values t)) | |
| 355 | 292 | ;; set dag |
| 356 | 293 | (let ((dag (object-depend-dag object))) |
| 357 | 294 | (unless dag |
| 360 | 297 | (let ((sub-dag (object-depend-dag subobject))) |
| 361 | 298 | (unless sub-dag (break "Panic! no object dag of subobject...")) |
| 362 | 299 | (let* ((submod-datum (cons subobject mode)) |
| 363 | (s-node (create-dag-node submod-datum | |
| 364 | (dag-node-subnodes sub-dag)))) | |
| 365 | (push s-node (dag-node-subnodes dag))))) | |
| 300 | (s-node (create-dag-node submod-datum | |
| 301 | (dag-node-subnodes sub-dag)))) | |
| 302 | (push s-node (dag-node-subnodes dag))))) | |
| 366 | 303 | ;; make exporting relation |
| 367 | ;; (pushnew (cons object mode) (object-exporting-objects subobject) :test #'equal) | |
| 368 | (pushnew (cons object mode) (object-exporting-objects subobject) :test #'equal) | |
| 369 | ) | |
| 304 | (pushnew (cons object mode) (object-exporting-objects subobject) :test #'equal)) | |
| 370 | 305 | |
| 371 | 306 | ;;; ****** |
| 372 | 307 | ;;; STATUS |
| 390 | 325 | ;;; |
| 391 | 326 | (defun propagate-object-change (exporting-objects) |
| 392 | 327 | (declare (type list exporting-objects) |
| 393 | (values t)) | |
| 328 | (values t)) | |
| 394 | 329 | (dolist (eobj exporting-objects) |
| 395 | 330 | (mark-object-as-inconsistent (car eobj)) |
| 396 | 331 | (propagate-object-change (object-exporting-objects (car eobj))))) |
| 435 | 370 | ;;; builtin-info part of builtin sorts. |
| 436 | 371 | ;;; |
| 437 | 372 | |
| 438 | (defstruct (parse-dictionary (:conc-name "DICTIONARY-") | |
| 439 | ;; #+gcl (:static t) | |
| 440 | ) | |
| 373 | (defstruct (parse-dictionary (:conc-name "DICTIONARY-")) | |
| 441 | 374 | (table (make-hash-table :test #'equal :size 50) |
| 442 | :type (or null hash-table)) | |
| 375 | :type (or null hash-table)) | |
| 443 | 376 | (builtins nil :type list) |
| 444 | (juxtaposition nil :type list) ; list of juxtaposition methods. | |
| 377 | (juxtaposition nil :type list) ; list of juxtaposition methods. | |
| 445 | 378 | ) |
| 446 | 379 | |
| 447 | 380 | ;;; ********* |
| 451 | 384 | ;;; slot. |
| 452 | 385 | |
| 453 | 386 | (defstruct (signature-struct (:conc-name "SIGNATURE$") |
| 454 | (:print-function print-signature)) | |
| 455 | (module nil) ; module | |
| 456 | (sorts nil :type list) ; list of own sorts. | |
| 457 | (sort-relations nil :type list) ; list of subsort relations. | |
| 458 | (operators nil :type list) ; list of operators declared in the | |
| 459 | ; module. | |
| 460 | (opattrs nil :type list) ; explicitly declared operator | |
| 461 | ; attributes in a form of AST. | |
| 462 | (principal-sort nil :type atom) ; principal sort of the module. | |
| 387 | (:print-function print-signature)) | |
| 388 | (module nil) ; module | |
| 389 | (sorts nil :type list) ; list of own sorts. | |
| 390 | (sort-relations nil :type list) ; list of subsort relations. | |
| 391 | (operators nil :type list) ; list of operators declared in the | |
| 392 | ; module. | |
| 393 | (opattrs nil :type list) ; explicitly declared operator | |
| 394 | ; attributes in a form of AST. | |
| 395 | (principal-sort nil :type atom) ; principal sort of the module. | |
| 463 | 396 | ) |
| 464 | 397 | |
| 465 | 398 | (defun print-signature (obj stream &rest ignore) |
| 474 | 407 | ;;; stored in module's `axioms' slot. |
| 475 | 408 | |
| 476 | 409 | (defstruct (axiom-set (:conc-name "AXIOM-SET$") |
| 477 | (:print-function print-axiom-set)) | |
| 478 | (module nil) ; contaning module | |
| 479 | (variables nil :type list) ; assoc list of explicitly declared | |
| 480 | ; variables. | |
| 481 | ; ((variable-name . variable) ...) | |
| 482 | (equations nil :type list) ; list of equtions declared in the module. | |
| 483 | (rules nil :type list) ; list of rules declared in the module. | |
| 410 | (:print-function print-axiom-set)) | |
| 411 | (module nil) ; contaning module | |
| 412 | (variables nil :type list) ; assoc list of explicitly declared | |
| 413 | ; variables. | |
| 414 | ; ((variable-name . variable) ...) | |
| 415 | (equations nil :type list) ; list of equtions declared in the module. | |
| 416 | (rules nil :type list) ; list of rules declared in the module. | |
| 484 | 417 | ) |
| 485 | 418 | |
| 486 | 419 | (defun print-axiom-set (obj stream &rest ignore) |
| 502 | 435 | ;;; The structure TRS is a representative of flattened module. |
| 503 | 436 | |
| 504 | 437 | (defstruct (TRS (:conc-name trs$) |
| 505 | (:print-function print-trs)) | |
| 506 | (module nil :type (or null top-object)) ; the reverse pointer | |
| 438 | (:print-function print-trs)) | |
| 439 | (module nil :type (or null top-object)) ; the reverse pointer | |
| 507 | 440 | ;; SIGNATURE INFO |
| 508 | (opinfo-table (make-hash-table :test #'eq) | |
| 509 | :type (or null hash-table)) | |
| 510 | ; operator infos | |
| 441 | (opinfo-table (make-hash-table :test #'eq) | |
| 442 | :type (or null hash-table)) | |
| 443 | ; operator infos | |
| 511 | 444 | (sort-order (make-hash-table :test #'eq) |
| 512 | :type (or null hash-table)) | |
| 513 | ; transitive closure of sort-relations | |
| 445 | :type (or null hash-table)) | |
| 446 | ; transitive closure of sort-relations | |
| 514 | 447 | ;; (ext-rule-table (make-hash-table :test #'eq)) |
| 515 | 448 | (ext-rule-table (make-ext-rule-table-name) |
| 516 | :type symbol) | |
| 517 | ; assoc table of rule A,AC extensions | |
| 449 | :type symbol) | |
| 450 | ; assoc table of rule A,AC extensions | |
| 518 | 451 | ;; |
| 519 | (sorts nil :type list) ; list of all sorts | |
| 520 | (operators nil :type list) ; list of all operators | |
| 452 | (sorts nil :type list) ; list of all sorts | |
| 453 | (operators nil :type list) ; list of all operators | |
| 521 | 454 | ;; REWRITE RULES |
| 522 | (rules nil :type list) ; list of all rewrite rules. | |
| 455 | (rules nil :type list) ; list of all rewrite rules. | |
| 523 | 456 | ;; INFO FOR EXTERNAL INTERFACE ----------------------------------- |
| 524 | 457 | (sort-name-map nil :type list) |
| 525 | 458 | (op-info-map nil :type list) |
| 529 | 462 | (sort-graph nil :type list) |
| 530 | 463 | (err-sorts nil :type list) |
| 531 | 464 | (dummy-methods nil :type list) |
| 532 | (sem-relations nil :type list) ; without error sorts | |
| 533 | (sem-axioms nil :type list) ; ditto | |
| 465 | (sem-relations nil :type list) ; without error sorts | |
| 466 | (sem-axioms nil :type list) ; ditto | |
| 534 | 467 | ;; a status TRAM interface generated? |
| 535 | (tram nil :type symbol) ; nil,:eq, or :all | |
| 468 | (tram nil :type symbol) ; nil,:eq, or :all | |
| 536 | 469 | ) |
| 537 | 470 | |
| 538 | 471 | (defun print-trs (obj stream &rest ignore) |
| 540 | 473 | (let ((mod (trs$module obj))) |
| 541 | 474 | (format stream "'[:trs \"~a\"]" (make-module-print-name2 mod)))) |
| 542 | 475 | |
| 543 | ;;; ******* | |
| 544 | ;;; CONTEXT_____________________________________________________________________ | |
| 545 | ;;; ******* | |
| 546 | ;;; holds some run time context infos. | |
| 547 | ||
| 548 | (defstruct (module-context | |
| 549 | ;; #+gcl (:static t) | |
| 550 | ) | |
| 551 | (bindings nil :type list) ; top level let binding | |
| 552 | (special-bindings nil :type list) ; users $$variables ... | |
| 553 | ($$term nil :type list) ; $$term | |
| 554 | ($$subterm nil :type list) ; $$subterm | |
| 555 | ($$action-stack nil :type list) ; action stack for apply | |
| 556 | ($$selection-stack nil :type list) ; selection stack for choose | |
| 557 | ($$stop-pattern nil :type list) ; stop pattern | |
| 558 | ($$ptree nil) ; proof tree | |
| 476 | ;;; ****************** | |
| 477 | ;;; MODULE-DYN-CONTEXT___________________________________________________________ | |
| 478 | ;;; ****************** | |
| 479 | ;;; holds run time dynamic infomation of a module. | |
| 480 | ||
| 481 | (defstruct (module-dyn-context (:conc-name "MODULE-CONTEXT-")) | |
| 482 | (object nil :type (or null object)) ; module | |
| 483 | (bindings nil :type list) ; top level let binding | |
| 484 | (special-bindings nil :type list) ; users $$variables ... | |
| 485 | ($$term nil :type list) ; $$term | |
| 486 | ($$subterm nil :type list) ; $$subterm | |
| 487 | ($$action-stack nil :type list) ; action stack for apply | |
| 488 | ($$selection-stack nil :type list) ; selection stack for choose | |
| 489 | ($$stop-pattern nil :type list) ; stop pattern | |
| 490 | ($$ptree nil) ; proof tree | |
| 559 | 491 | ) |
| 560 | 492 | |
| 561 | 493 | ;;; |
| 563 | 495 | ;;; MODULE __________________________________________________________________ |
| 564 | 496 | ;;; STRUCTURE |
| 565 | 497 | ;;; ********* |
| 566 | #|| | |
| 567 | (defterm module (top-object) | |
| 568 | :visible (name) ; module name (modexpr). | |
| 569 | :hidden (signature ; own signature. | |
| 570 | axiom-set ; set of own axioms. | |
| 571 | theorems ; set of own theorems, not used yet. | |
| 572 | parse-dictionary ; infos for term parsing. | |
| 573 | ex-info ; various compiled informations. | |
| 574 | trs ; corresponding semi-compiled TRS. | |
| 575 | context ; run time context | |
| 576 | ) | |
| 577 | :int-printer print-module-object | |
| 578 | :print print-module-internal) | |
| 579 | ||# | |
| 580 | ||
| 581 | 498 | (defstruct (module (:include top-object (-type 'module)) |
| 582 | (:conc-name "MODULE-") | |
| 583 | (:constructor make-module) | |
| 584 | (:constructor module* (name)) | |
| 585 | (:print-function print-module-object) | |
| 586 | ) | |
| 499 | (:conc-name "MODULE-") | |
| 500 | (:constructor make-module) | |
| 501 | (:constructor module* (name)) | |
| 502 | (:print-function print-module-object)) | |
| 587 | 503 | (print-name "" :type string) |
| 588 | 504 | (signature nil :type (or null signature-struct)) |
| 589 | ; own signature. | |
| 505 | ; own signature. | |
| 590 | 506 | (axiom-set nil :type (or null axiom-set)) |
| 591 | ; set of own axioms. | |
| 592 | (theorems nil :type list) ; set of own theorems, not used yet. | |
| 507 | ; set of own axioms. | |
| 508 | (theorems nil :type list) ; set of own theorems, not used yet. | |
| 593 | 509 | (parse-dictionary nil :type (or null parse-dictionary)) |
| 594 | ; infos for term parsing. | |
| 595 | ;; (ex-info nil :type list) ; various compiled informations. | |
| 596 | (trs nil :type (or null trs)) ; corresponding semi-compiled TRS. | |
| 510 | ; infos for term parsing. | |
| 511 | (trs nil :type (or null trs)) ; corresponding semi-compiled TRS. | |
| 597 | 512 | (context nil |
| 598 | :type (or null module-context)) | |
| 599 | ; run time context | |
| 600 | (alias nil :type list) | |
| 601 | ) | |
| 602 | ||
| 603 | (eval-when (:execute :load-toplevel) | |
| 604 | (setf (get 'module :type-predicate) (symbol-function 'module-p)) | |
| 605 | (setf (get 'module :eval) nil) | |
| 606 | (setf (get 'module :print) 'print-module-internal) | |
| 607 | ) | |
| 513 | :type (or null module-dyn-context)) | |
| 514 | ; run time context | |
| 515 | (alias nil :type list) ; alias names for a module generated from complex modexpr | |
| 516 | ) | |
| 517 | ||
| 518 | ;;; KIND | |
| 519 | (defmacro module-kind (_mod) | |
| 520 | `(getf (object-misc-info ,_mod) ':module-kind)) | |
| 521 | ||
| 522 | (defmacro module-is-theory (_mod_) `(eq :theory (module-kind ,_mod_))) | |
| 523 | ||
| 524 | (defmacro module-is-object (_mod_) `(eq :object (module-kind ,_mod_))) | |
| 525 | ||
| 526 | (defmacro module-is-final (_mod_) `(eq :theory (module-kind ,_mod_))) | |
| 527 | ||
| 528 | (defmacro module-is-loose (_mod_) | |
| 529 | ` (memq (module-kind ,_mod_) '(:module :ots))) | |
| 530 | ||
| 531 | (defmacro module-is-initial (_mod_) `(eq (module-kind ,_mod_) :object)) | |
| 532 | ||
| 533 | ;;; PRINTER | |
| 534 | ||
| 535 | (defun print-module-object (obj stream &rest ignore) | |
| 536 | (declare (ignore ignore) | |
| 537 | (type module obj) | |
| 538 | (type stream stream) | |
| 539 | (values t)) | |
| 540 | (if (or (module-is-inconsistent obj) | |
| 541 | (null (module-name obj))) | |
| 542 | (format stream ":module[\"~a\"]" (module-name obj)) | |
| 543 | (cond ((module-is-object obj) | |
| 544 | (format stream ":mod![\"~a\"]" (module-print-name obj))) | |
| 545 | ((module-is-theory obj) | |
| 546 | (format stream ":mod*[\"~a\"]" (module-print-name obj))) | |
| 547 | (t (format stream ":mod[\"~a\"]" (module-print-name obj)))))) | |
| 608 | 548 | |
| 609 | 549 | ;;; **** |
| 610 | 550 | ;;; VIEW _______________________________________________________________________ |
| 616 | 556 | ;;;----------------------------------------------------------------------------- |
| 617 | 557 | |
| 618 | 558 | (defstruct (view-struct (:include top-object (-type 'view-struct)) |
| 619 | (:conc-name "VIEW-STRUCT-") | |
| 620 | (:constructor make-view-struct) | |
| 621 | (:constructor view-struct* (name)) | |
| 622 | (:copier nil) | |
| 623 | (:print-function print-view-struct-object)) | |
| 559 | (:conc-name "VIEW-STRUCT-") | |
| 560 | (:constructor make-view-struct) | |
| 561 | (:constructor view-struct* (name)) | |
| 562 | (:copier nil) | |
| 563 | (:print-function print-view-struct-object)) | |
| 624 | 564 | (src nil :type (or null module)) |
| 625 | 565 | (target nil :type (or null module)) |
| 626 | 566 | (sort-maps nil :type list) |
| 633 | 573 | |
| 634 | 574 | (defun print-view-struct-object (obj stream &rest ignore) |
| 635 | 575 | (declare (ignore ignore)) |
| 636 | (format stream "#<view ~a: ~s => ~s | ~s>" | |
| 637 | (view-struct-name obj) | |
| 638 | (view-struct-src obj) | |
| 639 | (view-struct-target obj) | |
| 640 | (addr-of obj))) | |
| 576 | (format stream ":view[~a: ~s => ~s | ~s]" | |
| 577 | (view-struct-name obj) | |
| 578 | (view-struct-src obj) | |
| 579 | (view-struct-target obj) | |
| 580 | (addr-of obj))) | |
| 641 | 581 | |
| 642 | 582 | |
| 643 | 583 | ;;; EOF |
| 0 | 0 | ;;-*- Mode:LISP; Package: Chaos; Base:10; Syntax:Common-lisp -*- |
| 1 | 1 | ;;; |
| 2 | ;;; Copyright (c) 2000-2014, Toshimi Sawada. All rights reserved. | |
| 2 | ;;; Copyright (c) 2000-2015, Toshimi Sawada. All rights reserved. | |
| 3 | 3 | ;;; |
| 4 | 4 | ;;; Redistribution and use in source and binary forms, with or without |
| 5 | 5 | ;;; modification, are permitted provided that the following conditions |
| 27 | 27 | ;;; |
| 28 | 28 | (in-package :chaos) |
| 29 | 29 | #|============================================================================== |
| 30 | System: Chaos | |
| 31 | Module: primitives | |
| 32 | File: boperator.lisp | |
| 30 | System: Chaos | |
| 31 | Module: primitives | |
| 32 | File: boperator.lisp | |
| 33 | 33 | ==============================================================================|# |
| 34 | 34 | #-:chaos-debug |
| 35 | 35 | (declaim (optimize (speed 3) (safety 0) #-GCL (debug 0))) |
| 42 | 42 | ;;;***************************************************************************** |
| 43 | 43 | |
| 44 | 44 | ;;;============================================================================= |
| 45 | ;;; OPERATORS & friends | |
| 45 | ;;; OPERATORS & friends | |
| 46 | 46 | ;;;============================================================================= |
| 47 | 47 | |
| 48 | 48 | ;;; An operator is a folder which holds each specific operations (methods) |
| 104 | 104 | ;;; prec and cprec are used for `default' value for methods. |
| 105 | 105 | ;;; |
| 106 | 106 | (defstruct opsyntax |
| 107 | (token-seq nil :type list) ; list of terminal(string)s and arguments' | |
| 108 | ; place holders (symbol T). | |
| 109 | ; ex. ("if" T "then" T "else" T "fi") | |
| 110 | ; means that the operator has a syntax | |
| 111 | ; <if_then_else_fi> ::= "if" term "then" | |
| 112 | ; term "else" term | |
| 113 | ; "fi" | |
| 114 | (mixfix nil :type (or null t)) ; T iff the syntax is `mixfix'. | |
| 115 | (type nil :type symbol) ; one of 'juxtaposition, 'latefix, 'antefix. | |
| 116 | (prec nil :type (or null fixnum)) ; parsing precedence of the operator. | |
| 107 | (token-seq nil :type list) ; list of terminal(string)s and arguments' | |
| 108 | ; place holders (symbol T). | |
| 109 | ; ex. ("if" T "then" T "else" T "fi") | |
| 110 | ; means that the operator has a syntax | |
| 111 | ; <if_then_else_fi> ::= "if" term "then" | |
| 112 | ; term "else" term | |
| 113 | ; "fi" | |
| 114 | (mixfix nil :type (or null t)) ; T iff the syntax is `mixfix'. | |
| 115 | (type nil :type symbol) ; one of 'juxtaposition, 'latefix, 'antefix. | |
| 116 | (prec nil :type (or null fixnum)) ; parsing precedence of the operator. | |
| 117 | 117 | (cprec nil :type (or null fixnum)) |
| 118 | ; computed prec, used by `simple-parser'. | |
| 119 | (assoc nil :type symbol) ; associativity of the operator, | |
| 120 | ; 'l-assoc or 'r-assoc. | |
| 118 | ; computed prec, used by `simple-parser'. | |
| 119 | (assoc nil :type symbol) ; associativity of the operator, | |
| 120 | ; 'l-assoc or 'r-assoc. | |
| 121 | 121 | ) |
| 122 | 122 | |
| 123 | 123 | |
| 124 | 124 | ;;; ******** |
| 125 | 125 | ;;; OPERATOR __________________________________________________________________ |
| 126 | 126 | ;;; ******** |
| 127 | #|| | |
| 128 | (defterm operator (object) ; (static-object) | |
| 129 | :visible (name) ; list of `symbol' & `number of arguments'. | |
| 130 | :hidden (module | |
| 131 | strategy | |
| 132 | theory | |
| 133 | syntax | |
| 134 | memo | |
| 135 | print-name | |
| 136 | hidden | |
| 137 | ) | |
| 138 | :int-printer print-operator-object | |
| 139 | :print print-operator-internal) | |
| 140 | ||
| 141 | ||# | |
| 142 | ||
| 143 | 127 | (defstruct (operator (:include object (-type 'operator)) |
| 144 | (:constructor make-operator) | |
| 145 | (:constructor operator* (name)) | |
| 146 | (:copier nil) | |
| 147 | (:print-function print-operator-object)) | |
| 128 | (:constructor make-operator) | |
| 129 | (:constructor operator* (name)) | |
| 130 | (:copier nil) | |
| 131 | (:print-function print-operator-object)) | |
| 148 | 132 | (name nil :type list) |
| 149 | (module nil :type (or null module)) | |
| 150 | 133 | (strategy nil :type list) |
| 151 | 134 | (theory nil :type (or null op-theory)) |
| 152 | 135 | (syntax nil :type (or null opsyntax)) |
| 161 | 144 | |
| 162 | 145 | (defun print-operator-object (obj stream &rest ignore) |
| 163 | 146 | (declare (ignore ignore)) |
| 164 | (format stream "(:op ~s : ~x)" (operator-name obj) (addr-of obj)) | |
| 165 | ) | |
| 166 | ||
| 167 | ;;; (defmacro operator-p (_o) `(is-operator ,_o)) | |
| 147 | (format stream ":op[~s : ~x]" (operator-name obj) (addr-of obj))) | |
| 168 | 148 | |
| 169 | 149 | ;;; Basic accessors ---------------------------------------------------------- |
| 170 | ||
| 171 | ;;; (defmacro operator-name (_operator) `(%operator-name ,_operator)) | |
| 150 | (defmacro operator-module (op) | |
| 151 | `(object-context-mod ,op)) | |
| 172 | 152 | (defmacro operator-symbol (_operator) `(car (operator-name ,_operator))) |
| 173 | 153 | (defmacro operator-num-args (_operator) `(cdr (operator-name ,_operator))) |
| 174 | ;;; (defmacro operator-module (_operator) `(%operator-module ,_operator)) | |
| 175 | ;;; (defmacro operator-hidden (_operator) `(%operator-hidden ,_operator)) | |
| 176 | 154 | |
| 177 | 155 | ;;; id = (name . module) |
| 178 | 156 | (defmacro operator-id (__operator) |
| 179 | 157 | (once-only (__operator) |
| 180 | 158 | `(cons (operator-name ,__operator) (operator-module ,__operator)))) |
| 181 | 159 | (defmacro operator-module-id (__operator) `(module-name (operator-module |
| 182 | ,__operator))) | |
| 183 | ;;; (defmacro operator-strategy (__operator) `(%operator-strategy ,__operator)) | |
| 160 | ,__operator))) | |
| 184 | 161 | (defmacro operator-rewrite-strategy (__operator) |
| 185 | 162 | `(operator-strategy ,__operator)) |
| 186 | ;;; (defmacro operator-theory (__operator) `(%operator-theory ,__operator)) | |
| 187 | ;;; (defmacro operator-syntax (__operator) `(%operator-syntax ,__operator)) | |
| 188 | ;;; (defmacro operator-print-name (__operator) `(%operator-print-name ,__operator)) | |
| 189 | ;;; (defmacro operator-memo (__operator) `(%operator-memo ,__operator)) | |
| 190 | 163 | |
| 191 | 164 | (defun explode-operator-name (op-symbol) |
| 192 | 165 | (declare (type list op-symbol) |
| 193 | (values list)) | |
| 166 | (values list)) | |
| 194 | 167 | (mapcar #'(lambda (s) (if (equal s "_") |
| 195 | t | |
| 196 | s)) | |
| 197 | op-symbol)) | |
| 168 | t | |
| 169 | s)) | |
| 170 | op-symbol)) | |
| 198 | 171 | |
| 199 | 172 | (defun make-operator-token-seq (operator) |
| 200 | 173 | (declare (type operator operator) |
| 201 | (values list)) | |
| 174 | (values list)) | |
| 202 | 175 | (explode-operator-name (operator-symbol operator))) |
| 203 | 176 | |
| 204 | 177 | (defun operator-syntactic-type-from-name (token-seq) |
| 205 | 178 | (declare (type list token-seq) |
| 206 | (values symbol)) | |
| 179 | (values symbol)) | |
| 207 | 180 | (if (eq t (car token-seq)) |
| 208 | 181 | (if (eq t (cadr token-seq)) |
| 209 | 'juxtaposition | |
| 210 | 'latefix) | |
| 182 | 'juxtaposition | |
| 183 | 'latefix) | |
| 211 | 184 | 'antefix)) |
| 212 | 185 | |
| 213 | 186 | ;;; Predicate ------------------------------------------------------------------ |
| 232 | 205 | ;; just the same as (equal (operator-id op1) (operator-id op2)) |
| 233 | 206 | ;; but little bit faster... |
| 234 | 207 | ` (and (operator-eql ,op1_ ,op2_) |
| 235 | (eq (operator-module ,op1_) (operator-module ,op2_))))) | |
| 208 | (eq (operator-module ,op1_) (operator-module ,op2_))))) | |
| 236 | 209 | |
| 237 | 210 | ;;; OPERATOR-IS-BEHAVIOURAL |
| 238 | 211 | ;;; |
| 241 | 214 | |
| 242 | 215 | ;;; Constructor of Operator body.----------------------------------------------- |
| 243 | 216 | (defvar *opname-table* nil) |
| 244 | #|| | |
| 245 | (eval-when (:execute :load-toplevel) | |
| 246 | (setf *opname-table* (make-hash-table :test #'equal))) | |
| 247 | ||# | |
| 248 | 217 | |
| 249 | 218 | (defun canonicalize-op-name (name) |
| 250 | 219 | (declare (type list name) |
| 251 | (values list)) | |
| 220 | (values list)) | |
| 252 | 221 | (or (cdr (assoc name *opname-table* :test #'equal)) |
| 253 | 222 | (prog1 |
| 254 | name | |
| 255 | (push (cons name name) *opname-table*)))) | |
| 256 | ||
| 257 | #|| | |
| 258 | (defvar .operator-recycler.) | |
| 259 | (eval-when (:execute :load-toplevel) | |
| 260 | (setq .operator-recycler. (make-hash-table :test #'equal))) | |
| 261 | ||
| 262 | (defun allocate-operator (name num-args module) | |
| 263 | (let* ((name (canonicalize-op-name (cons name num-args))) | |
| 264 | (key (cons name module)) | |
| 265 | (op (gethash key .operator-recycler.))) | |
| 266 | (if op | |
| 267 | op | |
| 268 | (progn | |
| 269 | (setq op (operator* name)) | |
| 270 | (setf (operator-module op) module) | |
| 271 | (when (modexp-is-simple-name (module-name module)) | |
| 272 | (setf (gethash key .operator-recycler.) op)) | |
| 273 | op)))) | |
| 274 | ||
| 275 | ||# | |
| 223 | name | |
| 224 | (push (cons name name) *opname-table*)))) | |
| 276 | 225 | |
| 277 | 226 | (defun allocate-operator (name num-args module) |
| 278 | 227 | (declare (type list name) |
| 279 | (type fixnum num-args) | |
| 280 | (type module module) | |
| 281 | (values operator)) | |
| 228 | (type fixnum num-args) | |
| 229 | (type module module) | |
| 230 | (values operator)) | |
| 282 | 231 | (let ((name (canonicalize-op-name (cons name num-args))) |
| 283 | (op nil)) | |
| 232 | (op nil)) | |
| 284 | 233 | (setq op (operator* name)) |
| 285 | 234 | (setf (operator-module op) module) |
| 286 | 235 | op)) |
| 287 | 236 | |
| 288 | 237 | (defun new-operator (&key name num-args |
| 289 | module strategy theory syntax print-name) | |
| 238 | module strategy theory syntax print-name) | |
| 290 | 239 | |
| 291 | 240 | (declare (type list name) |
| 292 | (type (or null fixnum) num-args) | |
| 293 | (type (or null module) module) | |
| 294 | (type (or null list) strategy) | |
| 295 | (type (or null op-theory) theory) | |
| 296 | (type t print-name) | |
| 297 | (values operator)) | |
| 241 | (type (or null fixnum) num-args) | |
| 242 | (type (or null module) module) | |
| 243 | (type (or null list) strategy) | |
| 244 | (type (or null op-theory) theory) | |
| 245 | (type t print-name) | |
| 246 | (values operator)) | |
| 298 | 247 | (let ((o (allocate-operator name num-args module))) |
| 299 | 248 | (setf (operator-strategy o) strategy |
| 300 | (operator-theory o) theory | |
| 301 | (operator-syntax o) syntax | |
| 302 | (operator-print-name o) print-name) | |
| 249 | (operator-theory o) theory | |
| 250 | (operator-syntax o) syntax | |
| 251 | (operator-print-name o) print-name) | |
| 303 | 252 | o)) |
| 304 | ||
| 305 | 253 | |
| 306 | 254 | ;;; accessors of an operator's syntax via operator. |
| 307 | 255 | ;;; |
| 326 | 274 | (defun make-print-operator-id (op-nam) |
| 327 | 275 | (declare (type t op-nam)) |
| 328 | 276 | (cond ((and (consp op-nam) |
| 329 | (stringp (car op-nam))) | |
| 330 | (if (cdr op-nam) | |
| 331 | (reduce #'(lambda (a b) | |
| 332 | (declare (type (or simple-string symbol) a b)) | |
| 333 | (concatenate 'string | |
| 334 | (the simple-string (string a)) | |
| 335 | (the simple-string (string b)))) | |
| 336 | op-nam) | |
| 337 | (the simple-string (car op-nam)))) | |
| 338 | ((symbolp op-nam) (string (the symbol op-nam))) | |
| 339 | (t (break "Internal error: invalid op-nam ~S" op-nam)))) | |
| 277 | (stringp (car op-nam))) | |
| 278 | (if (cdr op-nam) | |
| 279 | (reduce #'(lambda (a b) | |
| 280 | (declare (type (or simple-string symbol) a b)) | |
| 281 | (concatenate 'string | |
| 282 | (the simple-string (string a)) | |
| 283 | (the simple-string (string b)))) | |
| 284 | op-nam) | |
| 285 | (the simple-string (car op-nam)))) | |
| 286 | ((symbolp op-nam) (string (the symbol op-nam))) | |
| 287 | (t (break "Internal error: invalid op-nam ~S" op-nam)))) | |
| 340 | 288 | |
| 341 | 289 | (defun cmake-operator-print-name (operator) |
| 342 | 290 | (declare (type operator operator)) |
| 343 | 291 | (let ((nam (operator-name operator)) |
| 344 | (mixfix (operator-is-mixfix operator))) | |
| 292 | (mixfix (operator-is-mixfix operator))) | |
| 345 | 293 | (if mixfix |
| 346 | (make-print-operator-id (car nam)) | |
| 347 | (format nil "~a/~d" | |
| 348 | (make-print-operator-id (car nam)) | |
| 349 | (cdr nam))))) | |
| 294 | (make-print-operator-id (car nam)) | |
| 295 | (format nil "~a/~d" | |
| 296 | (make-print-operator-id (car nam)) | |
| 297 | (cdr nam))))) | |
| 350 | 298 | |
| 351 | 299 | ;;; ****** |
| 352 | 300 | ;;; OPINFO |
| 362 | 310 | ;;; constructor |
| 363 | 311 | (defun make-opinfo (&key operator methods method-table) |
| 364 | 312 | (declare (type (or null operator) operator) |
| 365 | (type list methods) | |
| 366 | (type list method-table) | |
| 367 | (values list)) | |
| 313 | (type list methods) | |
| 314 | (type list method-table) | |
| 315 | (values list)) | |
| 368 | 316 | (list operator methods method-table)) |
| 369 | 317 | |
| 370 | 318 | (defun opinfo-p (object) |
| 371 | 319 | (declare (type t object) |
| 372 | (values (or null t))) | |
| 320 | (values (or null t))) | |
| 373 | 321 | (and (listp object) |
| 374 | 322 | (listp (cdr (last object))) |
| 375 | 323 | (= 3 (length object)) |
| 387 | 335 | ;;; |
| 388 | 336 | (defmacro get-operator-info (_*operator _*infos) |
| 389 | 337 | `(car (member ,_*operator ,_*infos :test #'(lambda (x y) |
| 390 | (operator= x (opinfo-operator y)))))) | |
| 338 | (operator= x (opinfo-operator y)))))) | |
| 391 | 339 | |
| 392 | 340 | ;;; The following accessors accepts operator object and the list of opinfo. |
| 393 | 341 | ;;; |
| 457 | 405 | ;;; ***************************************************************************** |
| 458 | 406 | |
| 459 | 407 | ;;; * NOTE* The slots defined here are all module idependent. |
| 460 | #|| | |
| 461 | (defterm method (object) | |
| 462 | :visible (name ; operator name (canonicalized). | |
| 463 | arity ; arity, list of argument sorts. | |
| 464 | coarity) ; coarity | |
| 465 | :hidden (module ; the module it belongs. | |
| 466 | constructor ; flag, t iff the method is a | |
| 467 | ; constructor. not yet used. | |
| 468 | supplied-strategy ; user supplied rewrite strategy. | |
| 469 | form ; describes the form of a term with the | |
| 470 | ; method as top. used for parsing. | |
| 471 | precedence ; precedence used for parsing. | |
| 472 | associativity ; associative info used for parsing. | |
| 473 | memo ; t iff the rewriting will be memoized. | |
| 474 | behavioural ; t iff the method is behavioural method. | |
| 475 | coherent ; t iff the method is behaviourally coherent. | |
| 476 | error ; t iff the method is error method and user | |
| 477 | ; defined. | |
| 478 | ) | |
| 479 | :int-printer print-method-object | |
| 480 | :print print-method-internal) | |
| 481 | ||# | |
| 482 | 408 | |
| 483 | 409 | (defstruct (method (:include object (-type 'method)) |
| 484 | (:constructor make-method) | |
| 485 | (:constructor method* (name arity coarity)) | |
| 486 | (:copier nil) | |
| 487 | (:print-function print-method-object)) | |
| 488 | (name nil :type list) ; operator name (canonicalized). | |
| 489 | (arity nil :type list) ; arity, list of argument sorts. | |
| 490 | (coarity nil :type (or null sort*)) ; coarity | |
| 491 | (module nil :type (or null module)) ; the module it belongs. | |
| 492 | (constructor nil :type (or null t)) ; flag, t iff the method is a | |
| 493 | ; constructor. not yet used. | |
| 494 | (supplied-strategy nil :type list) ; user supplied rewrite strategy. | |
| 495 | (form nil :type list) ; describes the form of a term with the | |
| 496 | ; method as top. used for parsing. | |
| 410 | (:constructor make-method) | |
| 411 | (:constructor method* (name arity coarity)) | |
| 412 | (:copier nil) | |
| 413 | (:print-function print-method-object)) | |
| 414 | (name nil :type list) ; operator name (canonicalized). | |
| 415 | (arity nil :type list) ; arity, list of argument sorts. | |
| 416 | (coarity nil :type (or null sort*)) ; coarity | |
| 417 | (constructor nil :type (or null t)) ; flag, t iff the method is a | |
| 418 | ; constructor. | |
| 419 | (supplied-strategy nil :type list) ; user supplied rewrite strategy. | |
| 420 | (form nil :type list) ; describes the form of a term with the | |
| 421 | ; method as top. used for parsing. | |
| 497 | 422 | (precedence nil :type (or null fixnum)) |
| 498 | ; precedence used for parsing. | |
| 499 | (associativity nil :type symbol) ; associative info used for parsing. | |
| 500 | (behavioural nil :type (or null t)) ; t iff the method is behavioural method. | |
| 501 | ;; (coherent nil :type (or null t)) ; t iff the method is behaviourally coherent. | |
| 502 | (error nil :type (or null t)) ; t iff the method is error method and user | |
| 503 | ; defined. | |
| 423 | ; precedence used for parsing. | |
| 424 | (associativity nil :type symbol) ; associative info used for parsing. | |
| 425 | (behavioural nil :type (or null t)) ; t iff the method is behavioural method. | |
| 426 | (error nil :type (or null t)) ; t iff the method is error method and user | |
| 427 | ; defined. | |
| 504 | 428 | (derived-from nil :type (or null method)) |
| 505 | 429 | (has-memo nil :type (or null t)) |
| 506 | (id-symbol nil :type symbol) | |
| 507 | ) | |
| 430 | (id-symbol nil :type symbol)) | |
| 508 | 431 | |
| 509 | 432 | (eval-when (:execute :load-toplevel) |
| 510 | 433 | (setf (symbol-function 'is-method) (symbol-function 'method-p)) |
| 513 | 436 | |
| 514 | 437 | (defun print-method-object (obj stream &rest ignore) |
| 515 | 438 | (declare (ignore ignore)) |
| 516 | (format stream "[:operator ~a]" (method-name obj))) | |
| 439 | (format stream ":op[~a]" (method-name obj))) | |
| 517 | 440 | |
| 518 | 441 | ;;; Primitive constructor ------------------------------------------------------ |
| 519 | 442 | |
| 521 | 444 | ;;; |
| 522 | 445 | (defmacro create-operator-method (_name _arity _coarity) |
| 523 | 446 | `(let ((meth (method* ,_name ,_arity ,_coarity))) |
| 524 | (set-context-module meth) | |
| 447 | (set-object-context-module meth) | |
| 525 | 448 | meth)) |
| 526 | 449 | |
| 527 | 450 | ;;; Primitive type predicate --------------------------------------------------- |
| 530 | 453 | |
| 531 | 454 | ;;; Primitive accessors -------------------------------------------------------- |
| 532 | 455 | |
| 533 | ;;; (defmacro method-name (_m) `(%method-name ,_m)) | |
| 456 | (defmacro method-module (m) | |
| 457 | `(object-context-mod ,m)) | |
| 458 | ||
| 534 | 459 | (defmacro method-symbol (_m) `(car (method-name ,_m))) |
| 535 | ;;; (defmacro method-arity (_m) `(%method-arity ,_m)) | |
| 536 | ;;; (defmacro method-coarity (_m) `(%method-coarity ,_m)) | |
| 537 | ;;; (defmacro method-constructor (_m) `(%method-constructor ,_m)) | |
| 538 | ;;; (defmacro method-form (_m) `(%method-form ,_m)) | |
| 539 | ;;; (defmacro method-supplied-strategy (_m) `(%method-supplied-strategy ,_m)) | |
| 540 | ;;; (defmacro method-precedence (_m) `(%method-precedence ,_m)) | |
| 541 | ;;; (defmacro method-memo (_m) `(%method-memo ,_m)) | |
| 542 | ;;; (defmacro method-module (_m) `(%method-module ,_m)) | |
| 543 | ;;; (defmacro method-associativity (_m) `(%method-associativity ,_m)) | |
| 544 | ;;; (defmacro method-behavioural (_m) `(%method-behavioural ,_m)) | |
| 460 | ||
| 545 | 461 | (defmacro method-is-behavioural (_m) `(method-behavioural ,_m)) ; synonym |
| 546 | ;;; (defmacro method-is-coherent (_m) `(method-coherent ,_m)) | |
| 462 | ||
| 547 | 463 | (defmacro method-is-user-defined-error-method (_m) |
| 548 | 464 | `(method-error ,_m)) |
| 549 | 465 | |
| 553 | 469 | (defun method-is-derived-from (m) |
| 554 | 470 | (let ((df (method-derived-from m))) |
| 555 | 471 | (if df |
| 556 | (or (method-is-derived-from df) | |
| 557 | df) | |
| 558 | nil))) | |
| 472 | (or (method-is-derived-from df) | |
| 473 | df) | |
| 474 | nil))) | |
| 559 | 475 | |
| 560 | 476 | ;;; synonym |
| 561 | 477 | (defmacro method-is-constructor? (m) |
| 575 | 491 | |
| 576 | 492 | (defun allocate-operator-method (name arity coarity) |
| 577 | 493 | (declare (type list name) |
| 578 | (type list arity) | |
| 579 | (type sort* coarity) | |
| 580 | (values method)) | |
| 581 | #|| | |
| 582 | (let ((key (list name arity coarity))) | |
| 583 | (or (gethash key .operator-method-recycler.) | |
| 584 | (let ((meth (method* name arity coarity))) | |
| 585 | (setf (gethash key .operator-method-recycler.) meth) | |
| 586 | meth))) | |
| 587 | ||# | |
| 588 | (create-operator-method name arity coarity) | |
| 589 | ) | |
| 494 | (type list arity) | |
| 495 | (type sort* coarity) | |
| 496 | (values method)) | |
| 497 | (create-operator-method name arity coarity)) | |
| 590 | 498 | |
| 591 | 499 | (defun make-method-id-symbol (method) |
| 592 | 500 | (let* ((nam (method-name method)) |
| 593 | (mixfix (find-if #'(lambda (x) (string= x "_")) (car nam)))) | |
| 501 | (mixfix (find-if #'(lambda (x) (string= x "_")) (car nam)))) | |
| 594 | 502 | (if mixfix |
| 595 | (intern (make-print-operator-id (car nam))) | |
| 596 | (intern (format nil "~a/~d" | |
| 597 | (make-print-operator-id (car nam)) | |
| 598 | (cdr nam)))))) | |
| 503 | (intern (make-print-operator-id (car nam))) | |
| 504 | (intern (format nil "~a/~d" | |
| 505 | (make-print-operator-id (car nam)) | |
| 506 | (cdr nam)))))) | |
| 599 | 507 | |
| 600 | 508 | (defun make-operator-method (&key name arity coarity) |
| 601 | 509 | (declare (type list name arity) |
| 602 | (type (or null sort*) coarity) | |
| 603 | (values method)) | |
| 510 | (type (or null sort*) coarity) | |
| 511 | (values method)) | |
| 604 | 512 | (let ((meth (allocate-operator-method name arity coarity))) |
| 605 | 513 | (declare (type method meth)) |
| 606 | (setf (method-module meth) *current-module* | |
| 607 | (method-constructor meth) nil | |
| 608 | (method-supplied-strategy meth) nil | |
| 609 | (method-precedence meth) nil | |
| 610 | (method-associativity meth) nil | |
| 611 | (method-id-symbol meth) (make-method-id-symbol meth)) | |
| 514 | (setf (method-module meth) (get-context-module) | |
| 515 | (method-constructor meth) nil | |
| 516 | (method-supplied-strategy meth) nil | |
| 517 | (method-precedence meth) nil | |
| 518 | (method-associativity meth) nil | |
| 519 | (method-id-symbol meth) (make-method-id-symbol meth)) | |
| 612 | 520 | meth)) |
| 613 | 521 | |
| 614 | 522 | ;;; EQUALITIES AMONG METHODS |
| 624 | 532 | |
| 625 | 533 | ;;; The same object. |
| 626 | 534 | (defmacro method= (*_*meth1 *_*meth2) `(eq ,*_*meth1 ,*_*meth2)) |
| 535 | ||
| 627 | 536 | (defun method-w= (m1 m2) |
| 628 | 537 | (or (method= m1 m2) |
| 629 | 538 | (when (and (sort= (method-coarity m1) *sort-id-sort*) |
| 630 | (sort= (method-coarity m2) *sort-id-sort*)) | |
| 631 | (equal (method-symbol m1) (method-symbol m2))))) | |
| 632 | ||
| 539 | (sort= (method-coarity m2) *sort-id-sort*)) | |
| 540 | (equal (method-symbol m1) (method-symbol m2))))) | |
| 541 | ||
| 633 | 542 | |
| 634 | 543 | ;;; METHOD-IS-OF-SAME-OPERATOR : Method1 Method2 -> Bool |
| 635 | 544 | ;;; Returns t iff the given two methods are of the same operator. |
| 636 | 545 | ;;; NOTE: they are not neccessarily comparable in terms of their ranks. |
| 637 | 546 | ;;; |
| 638 | (defmacro method-is-of-same-operator (*_*m1 *_*m2) | |
| 639 | `(eq (method-name ,*_*m1) (method-name ,*_*m2))) | |
| 640 | ||
| 641 | (defmacro method-is-of-same-operator-safe (*_*m1 *_*m2) | |
| 642 | `(and (method-p ,*_*m2) (eq (method-name ,*_*m1) (method-name ,*_*m2)))) | |
| 643 | ||
| 644 | ;;; this also checks that coarity is in same connected component | |
| 645 | (defmacro method-is-of-same-operator+ (_m1 _m2) | |
| 646 | `(let ((ma ,_m1) | |
| 647 | (mb ,_m2)) | |
| 648 | (and (method-is-of-same-operator ma mb) | |
| 649 | (is-in-same-connected-component (method-coarity ma) | |
| 650 | (method-coarity mb) | |
| 651 | (module-sort-order *current-module*))))) | |
| 652 | ||
| 547 | (defmacro method-has-same-name (_m1 _m2) | |
| 548 | `(equal (method-name ,_m1) (method-name ,_m2))) | |
| 549 | ||
| 550 | #|| | |
| 551 | (defmacro method-is-of-same-operator (_m1 _m2) | |
| 552 | (once-only (_m1 _m2) | |
| 553 | `(if (or (atom ,_m1) (atom ,_m2)) | |
| 554 | (equal ,_m1 ,_m2) | |
| 555 | (method-has-same-name (the method ,_m1) (the method ,_m2))))) | |
| 556 | ||# | |
| 557 | ||
| 558 | (defun method-is-of-same-operator (_m1 _m2) | |
| 559 | (declare (type (or atom method) _m1 _m2)) | |
| 560 | (if (or (not (method-p _m1)) | |
| 561 | (not (method-p _m2))) | |
| 562 | (equal _m1 _m2) | |
| 563 | (equal (method-name _m1) (method-name _m2)))) | |
| 564 | ||
| 565 | ;;; this also checks that coarity is in same the connected component | |
| 566 | (defmacro method-is-of-same-operator+ (m1 m2) | |
| 567 | (once-only (m1 m2) | |
| 568 | `(and (method-is-of-same-operator ,m1 ,m2) | |
| 569 | (is-in-same-connected-component (method-coarity ,m1) | |
| 570 | (method-coarity ,m2) | |
| 571 | (module-sort-order *current-module*))))) | |
| 572 | ||
| 653 | 573 | ;;; method-is-predicate |
| 654 | 574 | (defun method-is-predicate (method) |
| 655 | 575 | (and (sort= *bool-sort* (method-coarity method)) |
| 656 | 576 | (not (member *bool-sort* (method-arity method))) |
| 657 | 577 | (not (method= method *bool-true-meth*)) |
| 658 | (not (method= method *bool-false-meth*)) | |
| 659 | )) | |
| 578 | (not (method= method *bool-false-meth*)))) | |
| 660 | 579 | |
| 661 | 580 | ;;; METHOD ACCESSORS |
| 662 | 581 | |
| 663 | 582 | (defun find-method-in-method-list (arity coarity method-list) |
| 664 | 583 | (declare (type list arity method-list) |
| 665 | (type sort* coarity) | |
| 666 | (values (or null method))) | |
| 584 | (type sort* coarity) | |
| 585 | (values (or null method))) | |
| 667 | 586 | (let ((methods method-list)) |
| 668 | 587 | (dolist (m methods) |
| 669 | 588 | (if (and (sort-list= arity (method-arity m)) |
| 670 | (sort= coarity (method-coarity m))) | |
| 671 | (return-from find-method-in-method-list m))))) | |
| 589 | (sort= coarity (method-coarity m))) | |
| 590 | (return-from find-method-in-method-list m))))) | |
| 672 | 591 | |
| 673 | 592 | ;;; *********** |
| 674 | 593 | ;;; METHOD-INFO |
| 675 | 594 | ;;; *********** |
| 676 | 595 | ;;; Internal structure constaining module dependent infos of a method. |
| 677 | 596 | ;;; does not appear explicitly in Chaos program. |
| 678 | ||
| 679 | #|| | |
| 680 | (defterm !method-info (int-object) ; (static-int-object) ; internal term. | |
| 681 | :hidden (operator ; pointer to the operator. | |
| 682 | theory ; equational theory. | |
| 683 | lower-methods ; list of lower comparable methods, | |
| 684 | ; sorted lower->higher, exclusive. | |
| 685 | overloaded-methods ; list of overloaded methods, | |
| 686 | ; sortd higher->lower, exclusive. | |
| 687 | rules-with-same-top ; rewrite rules with lhs and rhs have a | |
| 688 | ; common top method. | |
| 689 | rules-with-different-top ; rewrite rules with lhs and rhs have | |
| 690 | ; different top method. | |
| 691 | strictly-overloaded ; t iff the method is strictly | |
| 692 | ; overloaded ,i.e., has no incomparable | |
| 693 | ; overloaded method. | |
| 694 | rew-strategy ; rewrite strategy. | |
| 695 | has-trans ; flag, t iff the method has transitivity | |
| 696 | ; axioms. | |
| 697 | )) | |
| 698 | ||
| 699 | ||# | |
| 700 | ||
| 701 | 597 | (defstruct (!method-info (:include object (-type '!method-info)) |
| 702 | (:copier nil) | |
| 703 | (:constructor make-!method-info) | |
| 704 | (:constructor !method-info* nil) | |
| 705 | (:print-function chaos-pr-object)) | |
| 598 | (:copier nil) | |
| 599 | (:constructor make-!method-info) | |
| 600 | (:constructor !method-info* nil) | |
| 601 | (:print-function chaos-pr-object)) | |
| 706 | 602 | (operator nil :type (or null operator)) |
| 707 | ; pointer to the operator. | |
| 603 | ; pointer to the operator. | |
| 708 | 604 | (theory nil :type (or null op-theory)) ; equational theory. |
| 709 | (lower-methods nil :type list) ; list of lower comparable methods, | |
| 710 | ; sorted lower->higher, exclusive. | |
| 711 | (overloaded-methods nil :type list) ; list of overloaded methods, | |
| 712 | ; sortd higher->lower, exclusive. | |
| 713 | (macros nil :type list) ; macro definitions | |
| 714 | (rules-with-same-top nil) ; rewrite rules with lhs and rhs have a | |
| 715 | ; common top method. | |
| 605 | (lower-methods nil :type list) ; list of lower comparable methods, | |
| 606 | ; sorted lower->higher, exclusive. | |
| 607 | (overloaded-methods nil :type list) ; list of overloaded methods, | |
| 608 | ; sortd higher->lower, exclusive. | |
| 609 | (macros nil :type list) ; macro definitions | |
| 610 | (rules-with-same-top nil) ; rewrite rules with lhs and rhs have a | |
| 611 | ; common top method. | |
| 716 | 612 | (rules-with-different-top nil :type list) |
| 717 | ; rewrite rules with lhs and rhs have | |
| 718 | ; different top method. | |
| 613 | ; rewrite rules with lhs and rhs have | |
| 614 | ; different top method. | |
| 719 | 615 | (strictly-overloaded nil :type (or null t)) |
| 720 | ; t iff the method is strictly | |
| 721 | ; overloaded ,i.e., has no incomparable | |
| 722 | ; overloaded method. | |
| 723 | (rew-strategy nil :type list) ; rewrite strategy. | |
| 724 | (has-trans nil :type (or null t)) ; flag, t iff the method has transitivity | |
| 725 | ; axioms. | |
| 616 | ; t iff the method is strictly | |
| 617 | ; overloaded ,i.e., has no incomparable | |
| 618 | ; overloaded method. | |
| 619 | (rew-strategy nil :type list) ; rewrite strategy. | |
| 620 | (has-trans nil :type (or null t)) ; flag, t iff the method has transitivity | |
| 621 | ; axioms. | |
| 726 | 622 | (theory-info-for-matching nil |
| 727 | :type (or null theory-info)) | |
| 728 | (coherent nil :type (or null t)) ; t iff behaviouraly coherent | |
| 623 | :type (or null theory-info)) | |
| 624 | (coherent nil :type (or null t)) ; t iff behaviouraly coherent | |
| 729 | 625 | ) |
| 730 | 626 | |
| 731 | 627 | (eval-when (:execute :load-toplevel) |
| 732 | 628 | (setf (symbol-function 'is-!method-info) (symbol-function '!method-info-p)) |
| 733 | 629 | (setf (get '!method-info :type-predicate) (symbol-function '!method-info-p)) |
| 734 | 630 | (setf (get '!method-info :print) nil)) |
| 735 | ||
| 631 | ||
| 736 | 632 | ;;; |
| 737 | 633 | ;;; GET-METHOD-INFO |
| 738 | 634 | ;;; |
| 739 | #|| | |
| 740 | (defun get-method-info (method &optional (opinfo-table *current-opinfo-table*)) | |
| 741 | (if (and (eq method .method1.) (eq opinfo-table .method-tab1.)) | |
| 742 | .method-val1. | |
| 743 | (if (and (eq method .method2.) (eq opinfo-table .method-tab2.)) | |
| 744 | .method-val2. | |
| 745 | (let ((res (gethash method opinfo-table))) | |
| 746 | (if res | |
| 747 | (progn | |
| 748 | (setq .method2. .method1. | |
| 749 | .method-tab2. .method-tab1. | |
| 750 | .method-val2. .method-val1.) | |
| 751 | (setq .method1. method | |
| 752 | .method-tab1. opinfo-table | |
| 753 | .method-val1. res) | |
| 754 | res) | |
| 755 | #|| | |
| 756 | (with-output-chaos-error () | |
| 757 | (format t "context is inconsistent, could not get info for operator:") | |
| 758 | (format t "~& ~a" (method-name method)) | |
| 759 | (chaos-to-top)) | |
| 760 | ||# | |
| 761 | nil | |
| 762 | ))))) | |
| 763 | ||# | |
| 764 | ||
| 765 | 635 | (declaim (inline get-method-info)) |
| 766 | 636 | |
| 767 | 637 | (#+GCL si::define-inline-function #-GCL defun |
| 768 | 638 | get-method-info (method opinfo-table) |
| 769 | 639 | (declare (type method method) |
| 770 | (type (or null hash-table) opinfo-table) | |
| 771 | (values (or null !method-info))) | |
| 640 | (type (or null hash-table) opinfo-table) | |
| 641 | (values (or null !method-info))) | |
| 772 | 642 | (unless opinfo-table |
| 773 | (with-output-panic-message () | |
| 774 | (format t "get-method-info: no opinfo-table") | |
| 775 | (chaos-error 'panic))) | |
| 643 | (with-output-panic-message () | |
| 644 | (format t "get-method-info: no opinfo-table") | |
| 645 | (break) | |
| 646 | (chaos-error 'panic))) | |
| 776 | 647 | (gethash method opinfo-table)) |
| 777 | 648 | |
| 778 | 649 | (defsetf get-method-info (_method &optional (_opinfo-table |
| 779 | *current-opinfo-table*)) | |
| 650 | *current-opinfo-table*)) | |
| 780 | 651 | (_val) |
| 781 | 652 | `(setf (gethash ,_method ,_opinfo-table) ,_val)) |
| 782 | 653 | |
| 792 | 663 | (get-method-info ,*_m ,*_info-table))) |
| 793 | 664 | |
| 794 | 665 | (defmacro method-lower-methods (*-_m &optional (*-_info-table |
| 795 | '*current-opinfo-table*)) | |
| 666 | '*current-opinfo-table*)) | |
| 796 | 667 | `(!method-info-lower-methods (get-method-info ,*-_m ,*-_info-table))) |
| 797 | 668 | |
| 798 | 669 | (defmacro method-overloaded-methods (*-_m &optional (*-_info-table |
| 799 | '*current-opinfo-table*)) | |
| 670 | '*current-opinfo-table*)) | |
| 800 | 671 | `(!method-info-overloaded-methods (get-method-info ,*-_m ,*-_info-table))) |
| 801 | 672 | |
| 802 | 673 | (defmacro method-rules-with-same-top (*-_m &optional (*-_info-table |
| 803 | '*current-opinfo-table*)) | |
| 674 | '*current-opinfo-table*)) | |
| 804 | 675 | `(!method-info-rules-with-same-top (get-method-info ,*-_m ,*-_info-table))) |
| 805 | 676 | |
| 806 | 677 | (defmacro method-rules-with-different-top (*-_m &optional (*-_info-table |
| 807 | '*current-opinfo-table*)) | |
| 678 | '*current-opinfo-table*)) | |
| 808 | 679 | `(!method-info-rules-with-different-top (get-method-info ,*-_m ,*-_info-table))) |
| 809 | 680 | |
| 810 | 681 | (defmacro method-macros (*_ms &optional (_info_table '*current-opinfo-table*)) |
| 815 | 686 | `(!method-info-rules-with-different-top (get-method-info ,_m ,_info-table))) |
| 816 | 687 | |
| 817 | 688 | (defmacro method-strictly-overloaded (*-_m &optional (*-_info-table |
| 818 | '*current-opinfo-table*)) | |
| 689 | '*current-opinfo-table*)) | |
| 819 | 690 | `(!method-info-strictly-overloaded (get-method-info ,*-_m ,*-_info-table))) |
| 820 | 691 | |
| 821 | 692 | (defmacro method-rew-strategy (*-_m &optional (*-_info-table '*current-opinfo-table*)) |
| 822 | 693 | `(!method-info-rew-strategy (get-method-info ,*-_m ,*-_info-table))) |
| 823 | 694 | |
| 824 | 695 | (defmacro method-rewrite-strategy (*-_m &optional (*-_info-table |
| 825 | '*current-opinfo-table*)) | |
| 696 | '*current-opinfo-table*)) | |
| 826 | 697 | `(!method-info-rew-strategy (get-method-info ,*-_m ,*-_info-table))) |
| 827 | 698 | |
| 828 | 699 | (defmacro method-has-trans-rule (_m &optional (_info-table |
| 829 | '*current-opinfo-table*)) | |
| 700 | '*current-opinfo-table*)) | |
| 830 | 701 | `(!method-info-has-trans (get-method-info ,_m ,_info-table))) |
| 831 | 702 | |
| 832 | 703 | (defmacro method-is-coherent (_m &optional (_info-table |
| 833 | '*current-opinfo-table*)) | |
| 704 | '*current-opinfo-table*)) | |
| 834 | 705 | `(!method-info-coherent (get-method-info ,_m ,_info-table))) |
| 835 | 706 | |
| 836 | 707 | ;;; synonym.. |
| 837 | 708 | (defmacro method-coherent (_m &optional (_info-table |
| 838 | '*current-opinfo-table*)) | |
| 709 | '*current-opinfo-table*)) | |
| 839 | 710 | `(!method-info-coherent (get-method-info ,_m ,_info-table))) |
| 840 | 711 | |
| 841 | 712 | ;;; CONSTRUCTOR ---------------------------------------------------------------- |
| 842 | ||
| 843 | #|| | |
| 844 | (defvar .method-info-recycler. (make-hash-table :test #'equal)) | |
| 845 | (defun allocate-method-info (method module) | |
| 846 | (let* ((key (list method module)) | |
| 847 | (minfo (gethash key .method-info-recycler.))) | |
| 848 | (if minfo | |
| 849 | minfo | |
| 850 | (progn | |
| 851 | (setq minfo (!method-info*)) | |
| 852 | (when (modexp-is-simple-name (module-name module)) | |
| 853 | (setf (gethash key .method-info-recycler.) minfo)) | |
| 854 | minfo)))) | |
| 855 | ||# | |
| 856 | 713 | |
| 857 | 714 | (defun allocate-method-info (meth mod) |
| 858 | 715 | (declare (ignore meth mod) |
| 859 | (values !method-info)) | |
| 716 | (values !method-info)) | |
| 860 | 717 | (make-!method-info)) |
| 861 | 718 | |
| 862 | 719 | (defun make-method-info (method module operator) |
| 863 | 720 | (declare (type method method) |
| 864 | (type module module) | |
| 865 | (type operator operator) | |
| 866 | (values !method-info)) | |
| 721 | (type module module) | |
| 722 | (type operator operator) | |
| 723 | (values !method-info)) | |
| 867 | 724 | (let ((info (allocate-method-info method module))) |
| 868 | 725 | (setf (!method-info-operator info) operator |
| 869 | (!method-info-theory info) nil | |
| 870 | (!method-info-lower-methods info) nil | |
| 871 | (!method-info-overloaded-methods info) nil) | |
| 726 | (!method-info-theory info) nil | |
| 727 | (!method-info-lower-methods info) nil | |
| 728 | (!method-info-overloaded-methods info) nil) | |
| 872 | 729 | (unless (!method-info-rules-with-same-top info) |
| 873 | 730 | (setf (!method-info-rules-with-same-top info) (create-rule-ring nil))) |
| 874 | 731 | (setf (!method-info-rules-with-different-top info) nil |
| 875 | (!method-info-strictly-overloaded info) nil) | |
| 732 | (!method-info-strictly-overloaded info) nil) | |
| 876 | 733 | info)) |
| 877 | 734 | |
| 878 | 735 | ;;; Little Utils -------------------------------------------------------------- |
| 880 | 737 | ;;; |
| 881 | 738 | ;;; METHOD-THEORY-INFO-FOR-MATCHING |
| 882 | 739 | ;;; |
| 883 | #|| | |
| 884 | (defun method-theory-info-for-matching (method &optional (info-table | |
| 885 | *current-opinfo-table*)) | |
| 740 | (defun compute-method-theory-info-for-matching (method &optional | |
| 741 | (info-table | |
| 742 | *current-opinfo-table*)) | |
| 886 | 743 | (declare (type method method) |
| 887 | (type hash-table info-table) | |
| 888 | (values theory-info)) | |
| 744 | (type hash-table info-table)) | |
| 889 | 745 | (let* ((th (method-theory method info-table)) |
| 890 | (info (theory-info th))) | |
| 746 | (info (theory-info th))) | |
| 891 | 747 | (declare (type op-theory th) |
| 892 | (type theory-info info)) | |
| 893 | (if (zero-rule-only th) | |
| 894 | (%svref *theory-info-array* | |
| 895 | (logandc2 (the fixnum (theory-info-code info)) .Z.)) | |
| 896 | info))) | |
| 897 | ||# | |
| 898 | ||
| 899 | (defun compute-method-theory-info-for-matching (method &optional | |
| 900 | (info-table | |
| 901 | *current-opinfo-table*)) | |
| 748 | (type theory-info info)) | |
| 749 | ;; | |
| 750 | (let((res (if (zero-rule-only th) | |
| 751 | (%svref *theory-info-array* | |
| 752 | (logandc2 (the fixnum (theory-info-code info)) .Z.)) | |
| 753 | info))) | |
| 754 | (setf (method-theory-info-for-matching method info-table) res)))) | |
| 755 | ||
| 756 | ;;; GET-METHOD-PRECEDENCE | |
| 757 | ;;; | |
| 758 | (defun get-method-precedence (method &optional | |
| 759 | (method-info-tab *current-opinfo-table*)) | |
| 902 | 760 | (declare (type method method) |
| 903 | (type hash-table info-table)) | |
| 904 | (let ((res nil)) | |
| 905 | (let* ((th (method-theory method info-table)) | |
| 906 | (info (theory-info th))) | |
| 907 | (declare (type op-theory th) | |
| 908 | (type theory-info info)) | |
| 909 | (setq res | |
| 910 | (if (zero-rule-only th) | |
| 911 | (%svref *theory-info-array* | |
| 912 | (logandc2 (the fixnum (theory-info-code info)) .Z.)) | |
| 913 | info)) | |
| 914 | (setf (method-theory-info-for-matching method info-table) | |
| 915 | res) | |
| 916 | ))) | |
| 917 | ||
| 918 | ;;; GET-METHOD-PRECEDENCE | |
| 919 | ;;; | |
| 920 | (defun get-method-precedence (method &optional | |
| 921 | (method-info-tab *current-opinfo-table*)) | |
| 922 | (declare (type method method) | |
| 923 | (type hash-table method-info-tab)) | |
| 761 | (type hash-table method-info-tab)) | |
| 924 | 762 | (or (the (or null fixnum) (method-precedence method)) |
| 925 | 763 | (the (or null fixnum) (operator-computed-precedence |
| 926 | (method-operator method method-info-tab))) | |
| 764 | (method-operator method method-info-tab))) | |
| 927 | 765 | (the (or null fixnum) (operator-precedence |
| 928 | (method-operator method method-info-tab))) | |
| 766 | (method-operator method method-info-tab))) | |
| 929 | 767 | (compute-operator-precedence (method-operator method method-info-tab)))) |
| 930 | 768 | |
| 931 | 769 | ;;; *** The following default precedence must be determined later again *** |
| 935 | 773 | |
| 936 | 774 | (defun compute-operator-precedence (operator) |
| 937 | 775 | (declare (type operator operator) |
| 938 | (values fixnum)) | |
| 776 | (values fixnum)) | |
| 939 | 777 | (let ((given-prec (operator-precedence operator)) |
| 940 | (token-seq (operator-token-sequence operator)) | |
| 941 | (is-standard (not (operator-is-mixfix operator)))) | |
| 778 | (token-seq (operator-token-sequence operator)) | |
| 779 | (is-standard (not (operator-is-mixfix operator)))) | |
| 942 | 780 | (declare (type (or null fixnum) given-prec) |
| 943 | (type list token-seq) | |
| 944 | (type (or null t) is-standard)) | |
| 781 | (type list token-seq) | |
| 782 | (type (or null t) is-standard)) | |
| 945 | 783 | (if given-prec |
| 946 | given-prec | |
| 947 | (if is-standard | |
| 948 | 0 | |
| 949 | (if (and (not (eq t (car token-seq))) | |
| 950 | (not (eq t (car (last token-seq))))) | |
| 951 | ;; not of the pattern "_ args-or-keyword... _ " | |
| 952 | 0 | |
| 953 | (if (and (eq t (car (last token-seq))) | |
| 954 | (not (memq t (butlast token-seq)))) | |
| 955 | ;; unary operator. | |
| 956 | .default-unary-prec. | |
| 957 | ;; others. | |
| 958 | .default-prec.)))))) | |
| 784 | given-prec | |
| 785 | (if is-standard | |
| 786 | 0 | |
| 787 | (if (and (not (eq t (car token-seq))) | |
| 788 | (not (eq t (car (last token-seq))))) | |
| 789 | ;; not of the pattern "_ args-or-keyword... _ " | |
| 790 | 0 | |
| 791 | (if (and (eq t (car (last token-seq))) | |
| 792 | (not (memq t (butlast token-seq)))) | |
| 793 | ;; unary operator. | |
| 794 | .default-unary-prec. | |
| 795 | ;; others. | |
| 796 | .default-prec.)))))) | |
| 959 | 797 | |
| 960 | 798 | ;;; ********* |
| 961 | 799 | ;;; RULE-RING |
| 970 | 808 | ;; Be careful for printing! (and debugging) |
| 971 | 809 | |
| 972 | 810 | (defstruct (rule-ring (:copier nil)) |
| 973 | (ring nil :type list) ; the circular list of rules | |
| 974 | (current nil :type list) ; current position | |
| 975 | (mark nil :type list)) ; end mark | |
| 811 | (ring nil :type list) ; the circular list of rules | |
| 812 | (current nil :type list) ; current position | |
| 813 | (mark nil :type list)) ; end mark | |
| 976 | 814 | |
| 977 | 815 | ;;; 0 : ring |
| 978 | 816 | ;;; 1 : current |
| 985 | 823 | ;;; (defun make-rule-ring (&key ring current mark) |
| 986 | 824 | ;;; (let ((r (alloc-term 3))) |
| 987 | 825 | ;;; (setf (rule-ring-ring r) ring |
| 988 | ;;; (rule-ring-current r) current | |
| 989 | ;;; (rule-ring-mark r) mark) | |
| 826 | ;;; (rule-ring-current r) current | |
| 827 | ;;; (rule-ring-mark r) mark) | |
| 990 | 828 | ;;; r)) |
| 991 | 829 | |
| 992 | 830 | ;;; CREATE-RULE-RING list-of-rules |
| 995 | 833 | ;;; |
| 996 | 834 | (defun create-rule-ring (list-of-rules) |
| 997 | 835 | (declare (type list list-of-rules) |
| 998 | (values rule-ring)) | |
| 836 | (values rule-ring)) | |
| 999 | 837 | (if list-of-rules |
| 1000 | 838 | (make-rule-ring :ring (rplacd (last list-of-rules) list-of-rules) |
| 1001 | :current list-of-rules | |
| 1002 | :mark list-of-rules) | |
| 839 | :current list-of-rules | |
| 840 | :mark list-of-rules) | |
| 1003 | 841 | (make-rule-ring))) |
| 1004 | 842 | |
| 1005 | 843 | ;;; ADD-RULE-TO-RING rule-ring rule |
| 1007 | 845 | ;;; |
| 1008 | 846 | (defun add-rule-to-ring (rring rule) |
| 1009 | 847 | (declare (type rule-ring rring) |
| 1010 | (type t rule)) | |
| 848 | (type t rule)) | |
| 1011 | 849 | (let ((ring (rule-ring-ring rring))) |
| 1012 | 850 | (if ring |
| 1013 | ;; add the rule to tail. | |
| 1014 | (rplacd ring (push rule (cdr ring))) | |
| 1015 | ;; no ring. | |
| 851 | ;; add the rule to tail. | |
| 852 | (rplacd ring (push rule (cdr ring))) | |
| 853 | ;; no ring. | |
| 1016 | 854 | (let ((new-ring (list rule))) |
| 1017 | (setf (rule-ring-ring rring) (rplacd new-ring new-ring)))))) | |
| 855 | (setf (rule-ring-ring rring) (rplacd new-ring new-ring)))))) | |
| 1018 | 856 | |
| 1019 | 857 | ;;; INITIALIZE-RULE-RING rule-ring |
| 1020 | 858 | ;;; initialize a rule-ring, that is put the current and mark pointers |
| 1030 | 868 | #-GCL |
| 1031 | 869 | (defun initialize-rule-ring (rr) |
| 1032 | 870 | (declare (type rule-ring rr) |
| 1033 | (values t)) | |
| 871 | (values t)) | |
| 1034 | 872 | (setf (rule-ring-current rr) (rule-ring-ring rr)) |
| 1035 | 873 | (setf (rule-ring-mark rr) nil) |
| 1036 | 874 | (car (rule-ring-current rr)) |
| 1047 | 885 | #-GCL |
| 1048 | 886 | (defun rule-ring-set-mark (rr) |
| 1049 | 887 | (declare (type rule-ring rr) |
| 1050 | (values list)) | |
| 888 | (values list)) | |
| 1051 | 889 | (setf (rule-ring-mark rr) (rule-ring-current rr))) |
| 1052 | 890 | |
| 1053 | 891 | ;;; RULE-RING-NEXT rule-ring |
| 1065 | 903 | #-GCL |
| 1066 | 904 | (defun rule-ring-next (rr) |
| 1067 | 905 | (declare (type rule-ring rr) |
| 1068 | (values list)) | |
| 906 | (values list)) | |
| 1069 | 907 | (unless (rule-ring-mark rr) (rule-ring-set-mark rr)) |
| 1070 | 908 | ;; update the current pointer |
| 1071 | 909 | (let ((rules (cdr (rule-ring-current rr)))) |
| 1084 | 922 | #-GCL |
| 1085 | 923 | (defun END-OF-RULE-RING (rr) |
| 1086 | 924 | (declare (type rule-ring rr) |
| 1087 | (values (or null t))) | |
| 925 | (values (or null t))) | |
| 1088 | 926 | (eq (rule-ring-current rr) (rule-ring-mark rr))) |
| 1089 | 927 | |
| 1090 | 928 | ;;; RULE-RING-IS-EMPTY rule-ring |
| 1096 | 934 | #-GCL |
| 1097 | 935 | (defun rule-ring-is-empty (rr) |
| 1098 | 936 | (declare (type rule-ring rr) |
| 1099 | (values (or null t))) | |
| 937 | (values (or null t))) | |
| 1100 | 938 | (null (rule-ring-ring rr))) |
| 1101 | 939 | |
| 1102 | 940 | ;;; RULE-RING-TO-LIST rule-ring |
| 1106 | 944 | (si::define-inline-function rule-ring-to-list (rr) |
| 1107 | 945 | (let ((list nil)) |
| 1108 | 946 | (do ((rule (initialize-rule-ring rr) (rule-ring-next rr))) |
| 1109 | ((end-of-rule-ring rr)) | |
| 1110 | (push rule list)) | |
| 947 | ((end-of-rule-ring rr)) | |
| 948 | (push rule list)) | |
| 1111 | 949 | list)) |
| 1112 | 950 | #-GCL |
| 1113 | 951 | (defun rule-ring-to-list (rr) |
| 1114 | 952 | (declare (type rule-ring rr) |
| 1115 | (values list)) | |
| 953 | (values list)) | |
| 1116 | 954 | (let ((list nil)) |
| 1117 | 955 | (do ((rule (initialize-rule-ring rr) (rule-ring-next rr))) |
| 1118 | ((end-of-rule-ring rr)) | |
| 1119 | (push rule list)) | |
| 956 | ((end-of-rule-ring rr)) | |
| 957 | (push rule list)) | |
| 1120 | 958 | list)) |
| 1121 | 959 | |
| 1122 | 960 | ;;; COPY-RULE-RING rule-ring |
| 1123 | 961 | ;;; |
| 1124 | 962 | (defun copy-rule-ring (rule-ring) |
| 1125 | 963 | (declare (type rule-ring rule-ring) |
| 1126 | (values rule-ring)) | |
| 964 | (values rule-ring)) | |
| 1127 | 965 | (let ((ring (rule-ring-ring rule-ring))) |
| 1128 | 966 | (make-rule-ring :ring ring |
| 1129 | :current ring | |
| 1130 | :mark nil))) | |
| 967 | :current ring | |
| 968 | :mark nil))) | |
| 1131 | 969 | |
| 1132 | 970 | |
| 1133 | 971 | ;;; **************** |
| 1139 | 977 | |
| 1140 | 978 | (defun method-is-error-method (method) |
| 1141 | 979 | (declare (type method method) |
| 1142 | (values (or null t))) | |
| 980 | (values (or null t))) | |
| 1143 | 981 | (let ((coar (method-coarity method))) |
| 1144 | 982 | (or (err-sort-p coar) |
| 1145 | (dolist (a (method-arity method) nil) | |
| 1146 | (if (err-sort-p a) | |
| 1147 | (return-from method-is-error-method t)))))) | |
| 1148 | ||
| 1149 | #|| | |
| 1150 | (defun method-is-universal (method) | |
| 1151 | (and (method-arity method) | |
| 1152 | (every #'(lambda (x) (or (sort= x *universal-sort*) | |
| 1153 | (sort= x *huniversal-sort*) | |
| 1154 | (sort= x *cosmos*))) | |
| 1155 | (method-arity method)))) | |
| 1156 | ||# | |
| 1157 | ||
| 983 | (dolist (a (method-arity method) nil) | |
| 984 | (if (err-sort-p a) | |
| 985 | (return-from method-is-error-method t)))))) | |
| 986 | ||
| 987 | ;;; returns true if all of its arguments are universal sort | |
| 1158 | 988 | (defun method-is-universal (method) |
| 1159 | 989 | (declare (type method method) |
| 1160 | (values (or null t))) | |
| 990 | (values (or null t))) | |
| 1161 | 991 | (let ((arity (method-arity method))) |
| 1162 | 992 | (declare (type list arity)) |
| 1163 | 993 | (and arity |
| 1164 | (dolist (ar arity t) | |
| 1165 | (declare (type sort* ar)) | |
| 1166 | (unless (or (sort= ar *universal-sort*) | |
| 1167 | (sort= ar *huniversal-sort*) | |
| 1168 | (sort= ar *cosmos*)) | |
| 1169 | (return-from method-is-universal nil)))))) | |
| 1170 | ||
| 994 | (dolist (ar arity t) | |
| 995 | (declare (type sort* ar)) | |
| 996 | (unless (or (sort= ar *universal-sort*) | |
| 997 | (sort= ar *huniversal-sort*) | |
| 998 | (sort= ar *cosmos*)) | |
| 999 | (return-from method-is-universal nil)))))) | |
| 1000 | ||
| 1001 | ;;; returns true if one of the argument is an universal sort | |
| 1171 | 1002 | (defun method-is-universal* (method) |
| 1172 | 1003 | (declare (type method method) |
| 1173 | (values (or null t))) | |
| 1004 | (values (or null t))) | |
| 1174 | 1005 | (let ((arity (method-arity method))) |
| 1175 | 1006 | (declare (type list arity)) |
| 1176 | 1007 | (and arity |
| 1177 | (dolist (ar arity nil) | |
| 1178 | (declare (type sort* ar)) | |
| 1179 | (when (or (sort= ar *universal-sort*) | |
| 1180 | (sort= ar *huniversal-sort*) | |
| 1181 | (sort= ar *cosmos*)) | |
| 1182 | (return-from method-is-universal* t)))))) | |
| 1008 | (dolist (ar arity nil) | |
| 1009 | (declare (type sort* ar)) | |
| 1010 | (when (or (sort= ar *universal-sort*) | |
| 1011 | (sort= ar *huniversal-sort*) | |
| 1012 | (sort= ar *cosmos*)) | |
| 1013 | (return-from method-is-universal* t)))))) | |
| 1183 | 1014 | |
| 1184 | 1015 | ;;; METHOD-IS-ASSOCIATIVE : Method -> Bool |
| 1185 | 1016 | ;;; non-nil iff the methods equational theory contains associativity. |
| 1186 | 1017 | ;;; |
| 1187 | 1018 | (defun method-is-associative (meth &optional (info *current-opinfo-table*)) |
| 1188 | 1019 | (declare (type method meth) |
| 1189 | (type hash-table info) | |
| 1190 | (values (or null t))) | |
| 1020 | (type hash-table info) | |
| 1021 | (values (or null t))) | |
| 1191 | 1022 | (theory-contains-associativity (method-theory meth info))) |
| 1192 | 1023 | |
| 1193 | 1024 | ;;; METHOD-IS-IDENTITY |
| 1195 | 1026 | ;;; |
| 1196 | 1027 | (defun method-is-identity (meth &optional (info *current-opinfo-table*)) |
| 1197 | 1028 | (declare (type method meth) |
| 1198 | (type hash-table info) | |
| 1199 | (values (or null t))) | |
| 1029 | (type hash-table info) | |
| 1030 | (values (or null t))) | |
| 1200 | 1031 | (theory-contains-identity (method-theory meth info))) |
| 1201 | 1032 | |
| 1202 | 1033 | ;;; METHOD-IS-COMMUTATIVE |
| 1204 | 1035 | ;;; |
| 1205 | 1036 | (defun method-is-commutative (meth &optional (info *current-opinfo-table*)) |
| 1206 | 1037 | (declare (type method meth) |
| 1207 | (type hash-table info) | |
| 1208 | (values (or null t))) | |
| 1038 | (type hash-table info) | |
| 1039 | (values (or null t))) | |
| 1209 | 1040 | (theory-contains-commutativity (method-theory meth info))) |
| 1210 | 1041 | |
| 1211 | 1042 | ;;; METHOD-IS-IDEMPOTENT |
| 1212 | 1043 | ;;; |
| 1213 | 1044 | (defun method-is-idempotent (meth &optional (info *current-opinfo-table*)) |
| 1214 | 1045 | (declare (type method meth) |
| 1215 | (type hash-table info) | |
| 1216 | (values (or null t))) | |
| 1046 | (type hash-table info) | |
| 1047 | (values (or null t))) | |
| 1217 | 1048 | (theory-contains-idempotency (method-theory meth info))) |
| 1218 | 1049 | |
| 1219 | 1050 | ;;; METHOD-IS-OVERLOADED-WITH : Method Method SORT-ORDER -> Bool |
| 1223 | 1054 | |
| 1224 | 1055 | (defun method-is-overloaded-with (meth1 meth2 &optional (so *current-sort-order*)) |
| 1225 | 1056 | (declare (type method meth1 meth2) |
| 1226 | (type sort-order so) | |
| 1227 | (values (or null t))) | |
| 1057 | (type sort-order so) | |
| 1058 | (values (or null t))) | |
| 1228 | 1059 | (and (method-p meth1) (method-p meth2) |
| 1229 | 1060 | (method-is-of-same-operator meth1 meth2) |
| 1230 | 1061 | (let ((arx (method-arity meth1)) |
| 1231 | (ary (method-arity meth2)) | |
| 1232 | (coarx (method-coarity meth1)) | |
| 1233 | (coary (method-coarity meth2))) | |
| 1234 | (declare (type list arx ary) | |
| 1235 | (type sort* coarx coary)) | |
| 1236 | (or (and (sort<= coarx coary so) | |
| 1237 | (sort-list<= arx ary so)) | |
| 1238 | (and (sort<= coary coarx so) | |
| 1239 | (sort-list<= ary arx so)))))) | |
| 1062 | (ary (method-arity meth2)) | |
| 1063 | (coarx (method-coarity meth1)) | |
| 1064 | (coary (method-coarity meth2))) | |
| 1065 | (declare (type list arx ary) | |
| 1066 | (type sort* coarx coary)) | |
| 1067 | (or (and (sort<= coarx coary so) | |
| 1068 | (sort-list<= arx ary so)) | |
| 1069 | (and (sort<= coary coarx so) | |
| 1070 | (sort-list<= ary arx so)))))) | |
| 1240 | 1071 | |
| 1241 | 1072 | ;;; METHOD-IS-IN-SAME-COMPONENT : Method1 Method2 -> Bool |
| 1242 | 1073 | ;;; Returns t iff two methods are of the same operator, have arities which |
| 1247 | 1078 | ;;; |
| 1248 | 1079 | (defun method-is-in-same-component (meth1 meth2 &optional (so *current-sort-order*)) |
| 1249 | 1080 | (declare (type method meth1 meth2) |
| 1250 | (type sort-order so) | |
| 1251 | (values (or null t))) | |
| 1081 | (type sort-order so) | |
| 1082 | (values (or null t))) | |
| 1252 | 1083 | (or (method= meth1 meth2) |
| 1253 | 1084 | (and (method-p meth1) (method-p meth2) |
| 1254 | (method-is-of-same-operator meth1 meth2) | |
| 1255 | (is-in-same-connected-component | |
| 1256 | (method-coarity meth1) (method-coarity meth2) so) | |
| 1257 | (let ((al1 (method-arity meth1)) | |
| 1258 | (al2 (method-arity meth2))) | |
| 1259 | (loop (if (null al1) (return t)) | |
| 1260 | (unless (is-in-same-connected-component (car al1) (car al2) so) | |
| 1261 | (return nil)) | |
| 1262 | (setf al1 (cdr al1) | |
| 1263 | al2 (cdr al2))))))) | |
| 1085 | (method-is-of-same-operator meth1 meth2) | |
| 1086 | (is-in-same-connected-component | |
| 1087 | (method-coarity meth1) (method-coarity meth2) so) | |
| 1088 | (let ((al1 (method-arity meth1)) | |
| 1089 | (al2 (method-arity meth2))) | |
| 1090 | (loop (if (null al1) (return t)) | |
| 1091 | (unless (is-in-same-connected-component (car al1) (car al2) so) | |
| 1092 | (return nil)) | |
| 1093 | (setf al1 (cdr al1) | |
| 1094 | al2 (cdr al2))))))) | |
| 1264 | 1095 | |
| 1265 | 1096 | ;;; METHOD-IS-INSTANCE-OF method-1 method2 sort-order |
| 1266 | 1097 | ;;; condition: of same operator, larger coarity; smaller arity smaller coarity too. |
| 1267 | 1098 | ;;; |
| 1268 | 1099 | (defun method-is-instance-of (meth1 meth2 sort-order) |
| 1269 | 1100 | (declare (type method meth1 meth2) |
| 1270 | (type sort-order sort-order) | |
| 1271 | (values (or null t))) | |
| 1101 | (type sort-order sort-order) | |
| 1102 | (values (or null t))) | |
| 1272 | 1103 | (and (method-p meth1) |
| 1273 | 1104 | (method-p meth2) |
| 1274 | 1105 | (method-is-of-same-operator meth1 meth2) |
| 1275 | 1106 | (or (method-is-universal* meth2) |
| 1276 | (and (or (not (sort= (method-coarity meth1) (method-coarity meth2))) | |
| 1277 | (not (sort-list= (method-arity meth1) (method-arity meth2)))) | |
| 1278 | (sort<= (method-coarity meth1) (method-coarity meth2) sort-order) | |
| 1279 | (sort-list<= (method-arity meth1) (method-arity meth2) sort-order))))) | |
| 1107 | (and (or (not (sort= (method-coarity meth1) (method-coarity meth2))) | |
| 1108 | (not (sort-list= (method-arity meth1) (method-arity meth2)))) | |
| 1109 | (sort<= (method-coarity meth1) (method-coarity meth2) sort-order) | |
| 1110 | (sort-list<= (method-arity meth1) (method-arity meth2) sort-order))))) | |
| 1280 | 1111 | |
| 1281 | 1112 | ;;; METHOD-IS-SAME-QUAL-METHOD : Method1 Method2 -> Bool |
| 1282 | 1113 | ;;; |
| 1283 | 1114 | (defun method-is-same-qual-method (meth1 meth2) |
| 1284 | 1115 | (declare (type method meth1 meth2) |
| 1285 | (values (or null t))) | |
| 1116 | (values (or null t))) | |
| 1286 | 1117 | (and (method-p meth1) (method-p meth2) |
| 1287 | 1118 | (or (method= meth1 meth2) |
| 1288 | (and (method-is-of-same-operator meth1 meth2) | |
| 1289 | (is-in-same-connected-component* (method-coarity meth1) | |
| 1290 | (method-coarity meth2) | |
| 1291 | *current-sort-order*))))) | |
| 1119 | (and (method-is-of-same-operator meth1 meth2) | |
| 1120 | (is-in-same-connected-component* (method-coarity meth1) | |
| 1121 | (method-coarity meth2) | |
| 1122 | *current-sort-order*))))) | |
| 1292 | 1123 | |
| 1293 | 1124 | ;;; METHOD<= : Method1 Method2 -> Bool |
| 1294 | 1125 | ;;; returns t iff |
| 1298 | 1129 | ;;; |
| 1299 | 1130 | (defun method<= (meth1 meth2 &optional (so *current-sort-order*)) |
| 1300 | 1131 | (declare (type method meth1 meth2) |
| 1301 | (type sort-order so) | |
| 1302 | (values (or null t))) | |
| 1132 | (type sort-order so) | |
| 1133 | (values (or null t))) | |
| 1303 | 1134 | (and (method-p meth1) (method-p meth2) |
| 1304 | 1135 | (method-is-of-same-operator meth1 meth2) |
| 1305 | 1136 | (not (eq meth1 meth2)) |
| 1306 | 1137 | (and (sort<= (method-coarity meth1) (method-coarity meth2) so) |
| 1307 | (sort-list<= (method-arity meth1) (method-arity meth2) so)))) | |
| 1138 | (sort-list<= (method-arity meth1) (method-arity meth2) so)))) | |
| 1308 | 1139 | |
| 1309 | 1140 | ;;; METHOD-IS-RESTRICTION-OF : Method1 Method2 -> Bool |
| 1310 | 1141 | ;;; just the same as method<= |
| 1311 | 1142 | ;;; |
| 1312 | 1143 | (defun method-is-restriction-of (meth1 meth2 &optional (so *current-sort-order*)) |
| 1313 | 1144 | (declare (type method meth1 meth2) |
| 1314 | (type sort-order so) | |
| 1315 | (values (or null t))) | |
| 1145 | (type sort-order so) | |
| 1146 | (values (or null t))) | |
| 1316 | 1147 | (and (method-p meth1) (method-p meth2) |
| 1317 | 1148 | (method-is-of-same-operator meth1 meth2) |
| 1318 | 1149 | (not (eq meth1 meth2)) |
| 1319 | 1150 | (or (method-is-universal* meth2) |
| 1320 | (and (sort<= (method-coarity meth1) (method-coarity meth2) so) | |
| 1321 | (sort-list<= (method-arity meth1) (method-arity meth2) so))))) | |
| 1151 | (and (sort<= (method-coarity meth1) (method-coarity meth2) so) | |
| 1152 | (sort-list<= (method-arity meth1) (method-arity meth2) so))))) | |
| 1322 | 1153 | |
| 1323 | 1154 | ;;; METHOD-IS-ASSOCIATIVE-RESTRICTION-OF : Method1 Method2 -> Bool |
| 1324 | 1155 | ;;; returns t iff |
| 1328 | 1159 | ;;; *NOTE* second method is assumed to be just associative. |
| 1329 | 1160 | ;;; |
| 1330 | 1161 | #-GCL (declaim (inline method-is-associative-restriction-of)) |
| 1331 | #|| | |
| 1332 | (defun method-is-associative-restriction-of (meth1 | |
| 1333 | meth2 | |
| 1334 | &optional | |
| 1335 | (so *current-sort-order*) | |
| 1336 | (info *current-opinfo-table*)) | |
| 1337 | (declare (type method meth1 meth2) | |
| 1338 | (type sort-order so) | |
| 1339 | (type hash-table info) | |
| 1340 | (values (or null t))) | |
| 1341 | (or (method= meth1 meth2) | |
| 1342 | (and (eq (method-name meth1) (method-name meth2)) | |
| 1343 | (sort<= (method-coarity meth1) | |
| 1344 | (method-coarity meth2) | |
| 1345 | so) | |
| 1346 | (sort-list<= (method-arity meth1) | |
| 1347 | (method-arity meth2) | |
| 1348 | so) | |
| 1349 | (theory-contains-associativity (method-theory meth1 info))))) | |
| 1350 | ||# | |
| 1351 | 1162 | #-GCL |
| 1352 | 1163 | (defun method-is-associative-restriction-of (meth1 |
| 1353 | meth2) | |
| 1164 | meth2) | |
| 1354 | 1165 | (declare (type method meth1 meth2) |
| 1355 | (values (or null t))) | |
| 1166 | (values (or null t))) | |
| 1356 | 1167 | (and (method-p meth1) (method-p meth2) |
| 1357 | 1168 | (or (method= meth1 meth2) |
| 1358 | (equal (method-name meth1) (method-name meth2))))) | |
| 1169 | (equal (method-name meth1) (method-name meth2))))) | |
| 1359 | 1170 | |
| 1360 | 1171 | #+GCL |
| 1361 | 1172 | (si:define-inline-function method-is-associative-restriction-of (meth1 |
| 1362 | meth2) | |
| 1173 | meth2) | |
| 1363 | 1174 | (declare (type method meth1 meth2) |
| 1364 | (values (or null t))) | |
| 1175 | (values (or null t))) | |
| 1365 | 1176 | (and (method-p meth1) (method-p meth2) |
| 1366 | 1177 | (or (method= meth1 meth2) |
| 1367 | (eq (method-name meth1) (method-name meth2))))) | |
| 1178 | (eq (method-name meth1) (method-name meth2))))) | |
| 1368 | 1179 | |
| 1369 | 1180 | ;;; METHOD-IS-AC-RESTRICTION-OF : Method1 Method2 -> Bool |
| 1370 | 1181 | ;;; returns t iff |
| 1373 | 1184 | ;;; |
| 1374 | 1185 | ;;; *NOTE* second method is assumed to be associative-commutive. |
| 1375 | 1186 | ;;; |
| 1376 | #|| | |
| 1377 | (defun method-is-AC-restriction-of (meth1 | |
| 1378 | meth2 | |
| 1379 | &optional | |
| 1380 | (so *current-sort-order*) | |
| 1381 | (info *current-opinfo-table*)) | |
| 1382 | (declare (type method meth1 meth2) | |
| 1383 | (type sort-order so) | |
| 1384 | (type hash-table info) | |
| 1385 | (values (or null t))) | |
| 1386 | (or (method= meth1 meth2) | |
| 1387 | (and (eq (method-name meth1) (method-name meth2)) | |
| 1388 | (sort<= (method-coarity meth1) | |
| 1389 | (method-coarity meth2) | |
| 1390 | so) | |
| 1391 | (sort-list<= (method-arity meth1) | |
| 1392 | (method-arity meth2) | |
| 1393 | so) | |
| 1394 | (theory-contains-AC (method-theory meth1 info))))) | |
| 1395 | ||# | |
| 1396 | ||
| 1397 | 1187 | #-GCL (declaim (inline method-is-ac-restriction-of)) |
| 1398 | ||
| 1399 | 1188 | #-GCL |
| 1400 | 1189 | (defun method-is-AC-restriction-of (meth1 |
| 1401 | meth2 | |
| 1402 | &rest ignore) | |
| 1190 | meth2 | |
| 1191 | &rest ignore) | |
| 1403 | 1192 | (declare (type method meth1 meth2) |
| 1404 | (ignore ignore) | |
| 1405 | (values (or null t))) | |
| 1193 | (ignore ignore) | |
| 1194 | (values (or null t))) | |
| 1406 | 1195 | (and (method-p meth1) (method-p meth2) |
| 1407 | 1196 | (or (method= meth1 meth2) |
| 1408 | (eq (method-name meth1) (method-name meth2))))) | |
| 1197 | (eq (method-name meth1) (method-name meth2))))) | |
| 1409 | 1198 | |
| 1410 | 1199 | #+GCL |
| 1411 | 1200 | (si:define-inline-function |
| 1412 | 1201 | method-is-ac-restriction-of (meth1 meth2) |
| 1413 | 1202 | (and (method-p meth1) (method-p meth2) |
| 1414 | 1203 | (or (method= meth1 meth2) |
| 1415 | (eq (method-name meth1) (method-name meth2))))) | |
| 1416 | ||
| 1204 | (eq (method-name meth1) (method-name meth2))))) | |
| 1205 | ||
| 1417 | 1206 | |
| 1418 | 1207 | ;;; METHOD-IS-COMMUTATIVE-RESTRICTION-OF : Method1 Method2 -> Bool |
| 1419 | 1208 | ;;; returns t iff |
| 1422 | 1211 | ;;; |
| 1423 | 1212 | ;;; *NOTE* second method is assumed to be just commutive. |
| 1424 | 1213 | ;;; |
| 1425 | #|| | |
| 1426 | (defun method-is-commutative-restriction-of (meth1 | |
| 1427 | meth2 | |
| 1428 | &optional | |
| 1429 | (so *current-sort-order*) | |
| 1430 | (info *current-opinfo-table*)) | |
| 1431 | (declare (type method meth1 meth2) | |
| 1432 | (type sort-order so) | |
| 1433 | (type hash-table info) | |
| 1434 | (values (or null t))) | |
| 1435 | (or (method= meth1 meth2) | |
| 1436 | (and (eq (method-name meth1) (method-name meth2)) | |
| 1437 | (sort<= (method-coarity meth1) | |
| 1438 | (method-coarity meth2) | |
| 1439 | so) | |
| 1440 | (sort-list<= (method-arity meth1) | |
| 1441 | (method-arity meth2) | |
| 1442 | so) | |
| 1443 | (theory-contains-commutativity (method-theory meth1 info))))) | |
| 1444 | ||# | |
| 1445 | ||
| 1446 | 1214 | #-GCL (declaim (inline method-is-commutative-restriction-of)) |
| 1447 | ||
| 1448 | 1215 | #-GCL |
| 1449 | 1216 | (defun method-is-commutative-restriction-of (meth1 meth2) |
| 1450 | 1217 | (declare (type method meth1 meth2) |
| 1451 | (values (or null t))) | |
| 1218 | (values (or null t))) | |
| 1452 | 1219 | (and (method-p meth2) (method-p meth1) |
| 1453 | 1220 | (or (method= meth1 meth2) |
| 1454 | (eq (method-name meth1) (method-name meth2))))) | |
| 1221 | (eq (method-name meth1) (method-name meth2))))) | |
| 1455 | 1222 | |
| 1456 | 1223 | #+GCL |
| 1457 | 1224 | (si:define-inline-function method-is-commutative-restriction-of (meth1 meth2) |
| 1458 | 1225 | (declare (type method meth1 meth2) |
| 1459 | (values (or null t))) | |
| 1226 | (values (or null t))) | |
| 1460 | 1227 | (and (method-p meth2) |
| 1461 | 1228 | (or (method= meth1 meth2) |
| 1462 | (eq (method-name meth1) (method-name meth2))))) | |
| 1229 | (eq (method-name meth1) (method-name meth2))))) | |
| 1463 | 1230 | |
| 1464 | 1231 | ;;; METHOD-IS-OVERLOADED-WITH-AC-ATTRIBUTE : Method1 Method2 -> Bool |
| 1465 | 1232 | ;;; returns t iff |
| 1467 | 1234 | ;;; (2) exists same name with AC then yes |
| 1468 | 1235 | ;;; |
| 1469 | 1236 | (defun method-is-overloaded-with-AC-attribute (meth |
| 1470 | &optional | |
| 1471 | (opinfo-table | |
| 1472 | *current-opinfo-table*)) | |
| 1237 | &optional | |
| 1238 | (opinfo-table | |
| 1239 | *current-opinfo-table*)) | |
| 1473 | 1240 | (declare (type method meth) |
| 1474 | (type hash-table opinfo-table) | |
| 1475 | (values (or null t))) | |
| 1241 | (type hash-table opinfo-table) | |
| 1242 | (values (or null t))) | |
| 1476 | 1243 | (dolist (meth2 (method-overloaded-methods meth opinfo-table)) |
| 1477 | 1244 | (declare (type method meth2)) |
| 1478 | 1245 | (when (and (not (method= meth meth2)) |
| 1479 | (eq (method-name meth) (method-name meth2)) | |
| 1480 | (theory-contains-AC (method-theory meth2 opinfo-table))) | |
| 1246 | (eq (method-name meth) (method-name meth2)) | |
| 1247 | (theory-contains-AC (method-theory meth2 opinfo-table))) | |
| 1481 | 1248 | (return t)))) |
| 1482 | 1249 | |
| 1483 | 1250 | ;;; GREATEST-AC-METHOD-LESS-THAN : Method -> Method |
| 1484 | 1251 | ;;; Theory is AC and satisfies the above condition. |
| 1485 | 1252 | ;;; |
| 1486 | 1253 | (defun greatest-AC-method-less-than (meth |
| 1487 | &optional | |
| 1488 | (opinfo-table *current-opinfo-table*)) | |
| 1254 | &optional | |
| 1255 | (opinfo-table *current-opinfo-table*)) | |
| 1489 | 1256 | (declare (type method meth) |
| 1490 | (type hash-table opinfo-table) | |
| 1491 | (values list)) | |
| 1257 | (type hash-table opinfo-table) | |
| 1258 | (values list)) | |
| 1492 | 1259 | (let ((res nil)) |
| 1493 | 1260 | (dolist (meth2 (method-overloaded-methods meth opinfo-table)) |
| 1494 | 1261 | (declare (type method meth2)) |
| 1495 | 1262 | (when (and (not (method= meth meth2)) |
| 1496 | (method-is-ac-restriction-of meth2 meth)) | |
| 1497 | (setq res meth2))) | |
| 1263 | (method-is-ac-restriction-of meth2 meth)) | |
| 1264 | (setq res meth2))) | |
| 1498 | 1265 | res)) |
| 1499 | 1266 | |
| 1500 | 1267 | ;;; LIST-ASSOCIATIVE-METHOD-ABOVE : Method -> List[Method] |
| 1502 | 1269 | ;;; to their methods. |
| 1503 | 1270 | ;;; |
| 1504 | 1271 | (defun list-associative-method-above (method &optional |
| 1505 | (so *current-sort-order*) | |
| 1506 | (info-table *current-opinfo-table*)) | |
| 1272 | (so *current-sort-order*) | |
| 1273 | (info-table *current-opinfo-table*)) | |
| 1507 | 1274 | (declare (type method method) |
| 1508 | (type sort-order so) | |
| 1509 | (hash-table info-table) | |
| 1510 | (values list)) | |
| 1275 | (type sort-order so) | |
| 1276 | (hash-table info-table) | |
| 1277 | (values list)) | |
| 1511 | 1278 | (let ((res nil) |
| 1512 | (coar (method-coarity method))) | |
| 1279 | (coar (method-coarity method))) | |
| 1513 | 1280 | (declare (type sort* coar)) |
| 1514 | 1281 | (dolist (m (method-overloaded-methods method info-table)) |
| 1515 | 1282 | (declare (type method m)) |
| 1516 | 1283 | (when (and (not (method= m method)) |
| 1517 | ;; (not (method-is-error-method m)) | |
| 1518 | ;; was (method-is-of-same-operator m method) | |
| 1519 | (eq (method-name m) | |
| 1520 | (method-name method)) | |
| 1521 | (sort<= coar (method-coarity m) so) | |
| 1522 | (theory-contains-associativity (method-theory m info-table))) | |
| 1523 | (push m res))) | |
| 1284 | ;; (not (method-is-error-method m)) | |
| 1285 | ;; was (method-is-of-same-operator m method) | |
| 1286 | (eq (method-name m) | |
| 1287 | (method-name method)) | |
| 1288 | (sort<= coar (method-coarity m) so) | |
| 1289 | (theory-contains-associativity (method-theory m info-table))) | |
| 1290 | (push m res))) | |
| 1524 | 1291 | res)) |
| 1525 | 1292 | |
| 1526 | 1293 | ;;; HIGHEST-METHODS-BELOW : Method Sort -> List[Method] |
| 1529 | 1296 | ;;; (2) has greater or equal coarity to given sort |
| 1530 | 1297 | ;;; |
| 1531 | 1298 | (defun highest-methods-below (method sort |
| 1532 | &optional | |
| 1533 | (so *current-sort-order*) | |
| 1534 | (opinfo-table *current-opinfo-table*)) | |
| 1299 | &optional | |
| 1300 | (so *current-sort-order*) | |
| 1301 | (opinfo-table *current-opinfo-table*)) | |
| 1535 | 1302 | (declare (type method method) |
| 1536 | (type sort* sort) | |
| 1537 | (type sort-order so) | |
| 1538 | (type hash-table opinfo-table) | |
| 1539 | (values list)) | |
| 1303 | (type sort* sort) | |
| 1304 | (type sort-order so) | |
| 1305 | (type hash-table opinfo-table) | |
| 1306 | (values list)) | |
| 1540 | 1307 | (let ((methods (reverse (method-overloaded-methods method opinfo-table))) |
| 1541 | (res nil)) | |
| 1308 | (res nil)) | |
| 1542 | 1309 | (dolist (m methods) |
| 1543 | 1310 | (declare (type method m)) |
| 1544 | 1311 | (when (sort<= (method-coarity m) sort so) |
| 1545 | (unless (dolist (m2 methods nil) | |
| 1546 | (when (and (not (method= m m2)) | |
| 1547 | (sort<= (method-coarity m) | |
| 1548 | (method-coarity m2) so) | |
| 1549 | (sort<= (method-coarity m2) sort so) | |
| 1550 | (method<= m m2 so)) | |
| 1551 | (return t))) | |
| 1552 | (push m res)))) | |
| 1312 | (unless (dolist (m2 methods nil) | |
| 1313 | (when (and (not (method= m m2)) | |
| 1314 | (sort<= (method-coarity m) | |
| 1315 | (method-coarity m2) so) | |
| 1316 | (sort<= (method-coarity m2) sort so) | |
| 1317 | (method<= m m2 so)) | |
| 1318 | (return t))) | |
| 1319 | (push m res)))) | |
| 1553 | 1320 | res)) |
| 1554 | 1321 | |
| 1555 | 1322 | |
| 1561 | 1328 | |
| 1562 | 1329 | (defun get-default-methods (op &optional (module *current-module*)) |
| 1563 | 1330 | (declare (type operator op) |
| 1564 | (type module module) | |
| 1565 | (values list)) | |
| 1331 | (type module module) | |
| 1332 | (values list)) | |
| 1566 | 1333 | (let ((gms nil)) |
| 1567 | 1334 | (dolist (m (operator-methods op (module-all-operators module))) |
| 1568 | 1335 | (if (or (method-is-error-method m) |
| 1569 | (method-is-universal m)) | |
| 1570 | (push m gms))) | |
| 1336 | (method-is-universal m)) | |
| 1337 | (push m gms))) | |
| 1571 | 1338 | gms)) |
| 1572 | 1339 | |
| 1573 | 1340 | ;;; LOWEST-METHOD-DIRECT |
| 1574 | 1341 | |
| 1575 | 1342 | (defun lowest-method-direct (method lower-bounds &optional (mod *current-module*)) |
| 1576 | 1343 | (declare (type method method) |
| 1577 | (type list lower-bounds) | |
| 1578 | (type module mod) | |
| 1579 | (values method)) | |
| 1344 | (type list lower-bounds) | |
| 1345 | (type module mod) | |
| 1346 | (values method)) | |
| 1580 | 1347 | (let ((*current-opinfo-table* (module-opinfo-table mod)) |
| 1581 | (*current-sort-order* (module-sort-order mod)) | |
| 1582 | (cur-arity (method-arity method)) | |
| 1583 | (cur-coarity (method-coarity method)) | |
| 1584 | (res method)) | |
| 1348 | (*current-sort-order* (module-sort-order mod)) | |
| 1349 | (cur-arity (method-arity method)) | |
| 1350 | (cur-coarity (method-coarity method)) | |
| 1351 | (res method)) | |
| 1585 | 1352 | (declare (type hash-table *current-opinfo-table* |
| 1586 | *current-sort-order*) | |
| 1587 | (type list cur-arity) | |
| 1588 | (type sort* cur-coarity)) | |
| 1353 | *current-sort-order*) | |
| 1354 | (type list cur-arity) | |
| 1355 | (type sort* cur-coarity)) | |
| 1589 | 1356 | (dolist (meth (operator-methods (method-operator method) |
| 1590 | (module-all-operators mod))) | |
| 1357 | (module-all-operators mod))) | |
| 1591 | 1358 | (declare (type method meth)) |
| 1592 | 1359 | (let ((new-coarity (method-coarity meth)) |
| 1593 | (new-arity (method-arity meth))) | |
| 1594 | (declare (type sort* new-coarity) | |
| 1595 | (type list new-arity)) | |
| 1596 | (when (and (sort<= new-coarity cur-coarity) | |
| 1597 | (sort-list<= lower-bounds new-arity) | |
| 1598 | (sort-list<= new-arity cur-arity)) | |
| 1599 | (setq res meth | |
| 1600 | cur-coarity new-coarity | |
| 1601 | cur-arity new-arity)))) | |
| 1360 | (new-arity (method-arity meth))) | |
| 1361 | (declare (type sort* new-coarity) | |
| 1362 | (type list new-arity)) | |
| 1363 | (when (and (sort<= new-coarity cur-coarity) | |
| 1364 | (sort-list<= lower-bounds new-arity) | |
| 1365 | (sort-list<= new-arity cur-arity)) | |
| 1366 | (setq res meth | |
| 1367 | cur-coarity new-coarity | |
| 1368 | cur-arity new-arity)))) | |
| 1602 | 1369 | res)) |
| 1603 | 1370 | |
| 1604 | 1371 | |
| 1605 | 1372 | ;;; HIGHEST-METHOD-DIRECT |
| 1606 | 1373 | |
| 1607 | 1374 | (defun highest-method-direct (method upper-bound |
| 1608 | &optional (module *current-module*)) | |
| 1375 | &optional (module *current-module*)) | |
| 1609 | 1376 | (declare (type method method) |
| 1610 | (type sort* upper-bound) | |
| 1611 | (type module module) | |
| 1612 | (values method)) | |
| 1377 | (type sort* upper-bound) | |
| 1378 | (type module module) | |
| 1379 | (values method)) | |
| 1613 | 1380 | (let* ((*current-opinfo-table* (module-opinfo-table module)) |
| 1614 | (*current-sort-order* (module-sort-order module)) | |
| 1615 | (elingible-flag (sort<= (method-coarity method) upper-bound)) | |
| 1616 | (res (if elingible-flag method nil)) | |
| 1617 | (cur-arity (if elingible-flag (method-arity method) nil)) | |
| 1618 | (cur-coarity (if elingible-flag (method-coarity method) nil))) | |
| 1381 | (*current-sort-order* (module-sort-order module)) | |
| 1382 | (elingible-flag (sort<= (method-coarity method) upper-bound)) | |
| 1383 | (res (if elingible-flag method nil)) | |
| 1384 | (cur-arity (if elingible-flag (method-arity method) nil)) | |
| 1385 | (cur-coarity (if elingible-flag (method-coarity method) nil))) | |
| 1619 | 1386 | (declare (type hash-table *current-opinfo-table* |
| 1620 | *current-sort-order*) | |
| 1621 | (type (or null t) elingible-flag) | |
| 1622 | (type list cur-arity) | |
| 1623 | (type (or null sort*) cur-coarity)) | |
| 1387 | *current-sort-order*) | |
| 1388 | (type (or null t) elingible-flag) | |
| 1389 | (type list cur-arity) | |
| 1390 | (type (or null sort*) cur-coarity)) | |
| 1624 | 1391 | (dolist (meth (operator-methods (method-operator method) |
| 1625 | (module-all-operators module))) | |
| 1392 | (module-all-operators module))) | |
| 1626 | 1393 | (declare (type method meth)) |
| 1627 | 1394 | (let ((new-arity (method-arity meth)) |
| 1628 | (new-coarity (method-coarity meth))) | |
| 1629 | (when (and (sort<= new-coarity upper-bound) | |
| 1630 | (or (null res) | |
| 1631 | (and (sort<= cur-coarity new-coarity) | |
| 1632 | (sort-list<= cur-arity new-arity)))) | |
| 1633 | (setf res meth cur-coarity new-coarity cur-arity new-arity)))) | |
| 1395 | (new-coarity (method-coarity meth))) | |
| 1396 | (when (and (sort<= new-coarity upper-bound) | |
| 1397 | (or (null res) | |
| 1398 | (and (sort<= cur-coarity new-coarity) | |
| 1399 | (sort-list<= cur-arity new-arity)))) | |
| 1400 | (setf res meth cur-coarity new-coarity cur-arity new-arity)))) | |
| 1634 | 1401 | res)) |
| 1635 | 1402 | |
| 1636 | 1403 | |
| 1638 | 1405 | |
| 1639 | 1406 | (defun strict-lower-coarities-direct (method &optional (module *current-module*)) |
| 1640 | 1407 | (declare (type method method) |
| 1641 | (type module module) | |
| 1642 | (values list)) | |
| 1408 | (type module module) | |
| 1409 | (values list)) | |
| 1643 | 1410 | (let (;; (arity (method-arity method)) |
| 1644 | (coarity (method-coarity method)) | |
| 1645 | (*current-opinfo-table* (module-opinfo-table module)) | |
| 1646 | (*current-sort-order* (module-sort-order module)) | |
| 1647 | (res nil)) | |
| 1411 | (coarity (method-coarity method)) | |
| 1412 | (*current-opinfo-table* (module-opinfo-table module)) | |
| 1413 | (*current-sort-order* (module-sort-order module)) | |
| 1414 | (res nil)) | |
| 1648 | 1415 | (declare (type sort* coarity) |
| 1649 | (type hash-table *current-opinfo-table* | |
| 1650 | *current-sort-order*)) | |
| 1416 | (type hash-table *current-opinfo-table* | |
| 1417 | *current-sort-order*)) | |
| 1651 | 1418 | (dolist (meth (operator-methods (method-operator method) |
| 1652 | (module-all-operators module))) | |
| 1419 | (module-all-operators module))) | |
| 1653 | 1420 | (declare (type method meth)) |
| 1654 | 1421 | (let ((new-coarity (method-coarity meth))) |
| 1655 | (declare (type sort* new-coarity)) | |
| 1656 | (when (and (not (member new-coarity res :test #'eq)) | |
| 1657 | (sort< (method-coarity meth) coarity) | |
| 1658 | ;; (sort-list (method-arity meth) arity) | |
| 1659 | ;; this test is not needed by co-regularity. | |
| 1660 | ) | |
| 1661 | (push new-coarity res)))) | |
| 1422 | (declare (type sort* new-coarity)) | |
| 1423 | (when (and (not (member new-coarity res :test #'eq)) | |
| 1424 | (sort< (method-coarity meth) coarity) | |
| 1425 | ;; (sort-list (method-arity meth) arity) | |
| 1426 | ;; this test is not needed by co-regularity. | |
| 1427 | ) | |
| 1428 | (push new-coarity res)))) | |
| 1662 | 1429 | res)) |
| 1663 | 1430 | |
| 1664 | 1431 | |
| 1665 | 1432 | ;;; |
| 1666 | 1433 | ;;; LOWEST-METHOD |
| 1667 | 1434 | ;;; |
| 1668 | ||
| 1669 | (defvar *op-debug* nil) | |
| 1670 | 1435 | |
| 1671 | 1436 | ;;; choose-most-general-op: ops -> or null method |
| 1672 | 1437 | ;;; NOTE: assumes *current-sort-order* and *current-opinfo-table* are bound to |
| 1675 | 1440 | (defun choose-most-general-op (list-meth) |
| 1676 | 1441 | (unless (cdr list-meth) |
| 1677 | 1442 | (return-from choose-most-general-op (car list-meth))) |
| 1678 | (let ((res (car list-meth)) | |
| 1679 | (comp? nil)) | |
| 1680 | (dolist (m (cdr list-meth)) | |
| 1681 | (when (method<= res m) | |
| 1682 | (setq res m) | |
| 1683 | (setq comp? t))) | |
| 1684 | (if comp? | |
| 1685 | res | |
| 1686 | nil))) | |
| 1443 | (let ((res (car list-meth))) | |
| 1444 | (dolist (m (cdr list-meth) res) | |
| 1445 | (if (method<= res m) | |
| 1446 | (setq res m) | |
| 1447 | (unless (method-is-in-same-component res m) | |
| 1448 | (return-from choose-most-general-op nil)))))) | |
| 1687 | 1449 | |
| 1688 | 1450 | ;;; choose-lowest-op : ops => or null method |
| 1689 | 1451 | ;;; NOTE: assumes *current-sort-order* and *current-opinfo-table* are bound to |
| 1690 | 1452 | ;;; properly. |
| 1691 | ;;; | |
| 1453 | ;;; This is used for selecting a term from multiple parse result. | |
| 1692 | 1454 | (defun choose-lowest-op (list-meth) |
| 1693 | 1455 | (unless (cdr list-meth) |
| 1694 | 1456 | (return-from choose-lowest-op (car list-meth))) |
| 1457 | (when *on-operator-debug* | |
| 1458 | (format t "~%[choose-lowest-op]:") | |
| 1459 | (dolist (meth list-meth) | |
| 1460 | (terpri) | |
| 1461 | (print-chaos-object meth))) | |
| 1695 | 1462 | (let ((res (car list-meth))) |
| 1696 | (dolist (m (cdr list-meth) res) | |
| 1463 | (dolist (m (cdr list-meth)) | |
| 1697 | 1464 | (if (method<= m res) |
| 1698 | (setq res m) | |
| 1699 | ;; return immediately iff two methods are not comparable | |
| 1700 | (unless (method<= res m) | |
| 1701 | (return-from choose-lowest-op nil)))))) | |
| 1465 | (setq res m) | |
| 1466 | ;; return immediately iff two methods are not comparable | |
| 1467 | (unless (method-is-in-same-component res m) | |
| 1468 | (return-from choose-lowest-op nil)))) | |
| 1469 | (when *on-operator-debug* | |
| 1470 | (format t "~%--> ") | |
| 1471 | (print-chaos-object res)) | |
| 1472 | res)) | |
| 1702 | 1473 | |
| 1703 | 1474 | (defun lowest-method (method lower-bound |
| 1704 | &optional (module *current-module*)) | |
| 1475 | &optional (module *current-module*)) | |
| 1705 | 1476 | (declare (type method method) |
| 1706 | (type list lower-bound) | |
| 1707 | (type module module) | |
| 1708 | (values method)) | |
| 1477 | (type list lower-bound) | |
| 1478 | (type module module) | |
| 1479 | (values method)) | |
| 1709 | 1480 | (let ((*current-sort-order* (module-sort-order module)) |
| 1710 | (*current-opinfo-table* (module-opinfo-table module)) | |
| 1711 | (cand nil)) | |
| 1481 | (*current-opinfo-table* (module-opinfo-table module)) | |
| 1482 | (cand nil)) | |
| 1712 | 1483 | (declare (type hash-table *current-sort-order* *current-opinfo-table*)) |
| 1713 | 1484 | (dolist (meth (method-overloaded-methods method *current-opinfo-table*)) |
| 1714 | 1485 | (declare (type method meth)) |
| 1715 | 1486 | (when (sort-list<= lower-bound (method-arity meth)) |
| 1716 | (push meth cand) )) | |
| 1487 | (push meth cand) )) | |
| 1717 | 1488 | (return-from lowest-method |
| 1718 | 1489 | (or (choose-lowest-op cand) method)))) |
| 1719 | 1490 | |
| 1720 | 1491 | (defun lowest-method! (method lower-bound &optional (module *current-module*)) |
| 1721 | 1492 | (declare (type method method) |
| 1722 | (type list lower-bound) | |
| 1723 | (type module module) | |
| 1724 | (values (or null method))) | |
| 1493 | (type list lower-bound) | |
| 1494 | (type module module) | |
| 1495 | (values (or null method))) | |
| 1725 | 1496 | (flet ((select-one-method (method-list) |
| 1726 | ;; select arbitrary one if every has the same rank | |
| 1727 | (let* ((cand (car method-list)) | |
| 1728 | (coar (method-coarity cand)) | |
| 1729 | (arity (method-arity cand))) | |
| 1730 | (dolist (m (cdr method-list) cand) | |
| 1731 | (unless (sort= coar (method-coarity m)) | |
| 1732 | (return-from select-one-method nil)) | |
| 1733 | (unless (sort-list= arity (method-arity m)) | |
| 1734 | (return-from select-one-method nil)))))) | |
| 1497 | ;; select arbitrary one if every has the same rank | |
| 1498 | (let* ((cand (car method-list)) | |
| 1499 | (coar (method-coarity cand)) | |
| 1500 | (arity (method-arity cand))) | |
| 1501 | (dolist (m (cdr method-list) cand) | |
| 1502 | (unless (sort= coar (method-coarity m)) | |
| 1503 | (return-from select-one-method nil)) | |
| 1504 | (unless (sort-list= arity (method-arity m)) | |
| 1505 | (return-from select-one-method nil)))))) | |
| 1735 | 1506 | (let ((*current-sort-order* (module-sort-order module)) |
| 1736 | (*current-opinfo-table* (module-opinfo-table module)) | |
| 1737 | (res nil)) | |
| 1507 | (*current-opinfo-table* (module-opinfo-table module)) | |
| 1508 | (res nil)) | |
| 1738 | 1509 | (declare (type hash-table *current-sort-order* *current-opinfo-table*)) |
| 1739 | 1510 | (let ((over-methods (method-overloaded-methods |
| 1740 | method | |
| 1741 | (module-opinfo-table module)))) | |
| 1742 | ||
| 1743 | (declare (type list over-methods)) | |
| 1744 | (when *on-debug* | |
| 1745 | (format t "~%* lowest-method! : over-methods =") | |
| 1746 | (dolist (m over-methods) | |
| 1747 | (terpri) | |
| 1748 | (princ " ") | |
| 1749 | (print-chaos-object m))) | |
| 1750 | ;; | |
| 1751 | (if over-methods | |
| 1752 | (progn | |
| 1753 | (dolist (meth over-methods) | |
| 1754 | (declare (type method meth)) | |
| 1755 | (when (and (sort-list<= lower-bound (method-arity meth)) | |
| 1756 | (not (member | |
| 1757 | meth | |
| 1758 | res | |
| 1759 | :test #'(lambda (x y) | |
| 1760 | (method-is-instance-of y | |
| 1761 | x | |
| 1762 | *current-sort-order*))) | |
| 1763 | )) | |
| 1764 | (push meth res))) | |
| 1765 | (when *on-debug* | |
| 1766 | (format t "~%lowest-method! res=") | |
| 1767 | (print-chaos-object res) | |
| 1768 | ) | |
| 1769 | (if (cdr res) | |
| 1770 | ;; was method | |
| 1771 | (or (select-one-method res) | |
| 1772 | method) | |
| 1773 | (car res))) | |
| 1774 | (return-from lowest-method! method)))))) | |
| 1775 | ||
| 1776 | #|| | |
| 1777 | (defun lowest-method! (method lower-bound &optional (module *current-module*)) | |
| 1778 | (declare (type method method) | |
| 1779 | (type list lower-bound) | |
| 1780 | (type module module) | |
| 1781 | (values (or null method))) | |
| 1782 | (let ((*current-sort-order* (module-sort-order module)) | |
| 1783 | (*current-opinfo-table* (module-opinfo-table module)) | |
| 1784 | (res nil)) | |
| 1785 | (declare (type hash-table *current-sort-order* *current-opinfo-table*)) | |
| 1786 | (let ((over-methods (method-overloaded-methods method *current-opinfo-table*))) | |
| 1787 | (declare (type list over-methods)) | |
| 1788 | (when *on-debug* | |
| 1789 | (format t "~%* lowest-method! : over-methods =") | |
| 1790 | (dolist (m over-methods) | |
| 1791 | (terpri) | |
| 1792 | (princ " ") | |
| 1793 | (print-chaos-object m))) | |
| 1794 | ;; | |
| 1795 | (if over-methods | |
| 1796 | (progn | |
| 1797 | (dolist (meth over-methods) | |
| 1798 | (declare (type method meth)) | |
| 1799 | (when (and (sort-list<= lower-bound (method-arity meth)) | |
| 1800 | (not (member | |
| 1801 | meth | |
| 1802 | res | |
| 1803 | :test #'(lambda (x y) | |
| 1804 | (method-is-instance-of y | |
| 1805 | x | |
| 1806 | *current-sort-order*))))) | |
| 1807 | (push meth res))) | |
| 1808 | (or (choose-lowest-op res) | |
| 1809 | method)) | |
| 1810 | (return-from lowest-method! method))))) | |
| 1811 | ||# | |
| 1511 | method | |
| 1512 | (module-opinfo-table module)))) | |
| 1513 | ||
| 1514 | (declare (type list over-methods)) | |
| 1515 | (when *on-operator-debug* | |
| 1516 | (format t "~%* lowest-method! : over-methods =") | |
| 1517 | (dolist (m over-methods) | |
| 1518 | (terpri) | |
| 1519 | (princ " ") | |
| 1520 | (print-chaos-object m))) | |
| 1521 | ;; | |
| 1522 | (if over-methods | |
| 1523 | (progn | |
| 1524 | (dolist (meth over-methods) | |
| 1525 | (declare (type method meth)) | |
| 1526 | (when (and (sort-list<= lower-bound (method-arity meth)) | |
| 1527 | (not (member | |
| 1528 | meth | |
| 1529 | res | |
| 1530 | :test #'(lambda (x y) | |
| 1531 | (method-is-instance-of y | |
| 1532 | x | |
| 1533 | *current-sort-order*))) | |
| 1534 | )) | |
| 1535 | (push meth res))) | |
| 1536 | (when *on-operator-debug* | |
| 1537 | (format t "~%lowest-method! res=") | |
| 1538 | (print-chaos-object res)) | |
| 1539 | (if (cdr res) | |
| 1540 | ;; was method | |
| 1541 | (or (select-one-method res) | |
| 1542 | method) | |
| 1543 | (car res))) | |
| 1544 | (return-from lowest-method! method)))))) | |
| 1812 | 1545 | |
| 1813 | 1546 | (defun lowest-method* (method &optional lower-bound (module *current-module*)) |
| 1814 | 1547 | (declare (type method method) |
| 1815 | (type list lower-bound) | |
| 1816 | (type module module) | |
| 1817 | (values (or null method))) | |
| 1548 | (type list lower-bound) | |
| 1549 | (type module module) | |
| 1550 | (values (or null method))) | |
| 1818 | 1551 | (let* ((*current-sort-order* (module-sort-order module)) |
| 1819 | (*current-opinfo-table* (module-opinfo-table module)) | |
| 1820 | (over-methods (method-overloaded-methods method *current-opinfo-table*))) | |
| 1552 | (*current-opinfo-table* (module-opinfo-table module)) | |
| 1553 | (over-methods (method-overloaded-methods method *current-opinfo-table*))) | |
| 1821 | 1554 | (declare (type hash-table *current-sort-order* *current-opinfo-table*) |
| 1822 | (type list over-methods)) | |
| 1555 | (type list over-methods)) | |
| 1823 | 1556 | (if over-methods |
| 1824 | (let ((cur-coarity (method-coarity method)) | |
| 1825 | (cur-arity (method-arity method))) | |
| 1826 | (declare (type sort* cur-coarity) | |
| 1827 | (type list cur-arity)) | |
| 1828 | (dolist (meth over-methods) | |
| 1829 | (declare (type method meth)) | |
| 1830 | (let ((new-coarity (method-coarity meth)) | |
| 1831 | (new-arity (method-arity meth))) | |
| 1832 | (declare (type sort* new-coarity) | |
| 1833 | (type list new-arity)) | |
| 1834 | (when (and (sort<= new-coarity cur-coarity) | |
| 1835 | (or (and lower-bound | |
| 1836 | (sort-list<= lower-bound new-arity)) | |
| 1837 | t) | |
| 1838 | (sort-list<= new-arity cur-arity)) | |
| 1839 | (return-from lowest-method* meth)))) | |
| 1840 | method) | |
| 1841 | method))) | |
| 1557 | (let ((cur-coarity (method-coarity method)) | |
| 1558 | (cur-arity (method-arity method))) | |
| 1559 | (declare (type sort* cur-coarity) | |
| 1560 | (type list cur-arity)) | |
| 1561 | (dolist (meth over-methods) | |
| 1562 | (declare (type method meth)) | |
| 1563 | (let ((new-coarity (method-coarity meth)) | |
| 1564 | (new-arity (method-arity meth))) | |
| 1565 | (declare (type sort* new-coarity) | |
| 1566 | (type list new-arity)) | |
| 1567 | (when (and (sort<= new-coarity cur-coarity) | |
| 1568 | (or (and lower-bound | |
| 1569 | (sort-list<= lower-bound new-arity)) | |
| 1570 | t) | |
| 1571 | (sort-list<= new-arity cur-arity)) | |
| 1572 | (return-from lowest-method* meth)))) | |
| 1573 | method) | |
| 1574 | method))) | |
| 1842 | 1575 | |
| 1843 | 1576 | ;;; HIGHEST-METHOD |
| 1844 | 1577 | ;;; NOTE assume overloaded-methods is sorted .lower => higher. |
| 1845 | 1578 | ;;; |
| 1846 | 1579 | (defun highest-method (method &optional |
| 1847 | upper-bound | |
| 1848 | (module *current-module*)) | |
| 1580 | upper-bound | |
| 1581 | (module *current-module*)) | |
| 1849 | 1582 | (declare (type method method) |
| 1850 | (type (or null sort*) upper-bound) | |
| 1851 | (type module module) | |
| 1852 | (values method)) | |
| 1583 | (type (or null sort*) upper-bound) | |
| 1584 | (type module module) | |
| 1585 | (values method)) | |
| 1853 | 1586 | ;; (format t "~&highest-method : given method ") |
| 1854 | 1587 | ;; (print-chaos-object method) |
| 1855 | 1588 | (let ((overloaded-methods |
| 1856 | (reverse (method-overloaded-methods method | |
| 1857 | (module-opinfo-table module))))) | |
| 1589 | (reverse (method-overloaded-methods method | |
| 1590 | (module-opinfo-table module))))) | |
| 1858 | 1591 | (declare (type list overloaded-methods)) |
| 1859 | 1592 | (if (null (cdr overloaded-methods)) |
| 1860 | (if overloaded-methods | |
| 1861 | (car overloaded-methods) | |
| 1862 | method) | |
| 1863 | (let* ((*current-sort-order* (module-sort-order module)) | |
| 1864 | (*current-opinfo-table* (module-opinfo-table module)) | |
| 1865 | (eligible-flag (if upper-bound | |
| 1866 | (sort<= (method-coarity method) upper-bound) | |
| 1867 | t)) | |
| 1868 | (method-res (if eligible-flag method nil)) | |
| 1869 | (cur-arity (if eligible-flag (method-arity method) nil)) | |
| 1870 | (cur-coarity (if eligible-flag (method-coarity method) nil))) | |
| 1871 | (declare (type hash-table *current-sort-order* | |
| 1872 | *current-opinfo-table*) | |
| 1873 | (type (or null t) eligible-flag) | |
| 1874 | (type list cur-arity) | |
| 1875 | (type (or null method) method-res) | |
| 1876 | (type (or null sort*) cur-coarity)) | |
| 1877 | (dolist (meth (operator-methods (method-operator method) | |
| 1878 | (module-all-operators module)) | |
| 1879 | method-res) | |
| 1880 | (declare (type method meth)) | |
| 1881 | (let ((new-arity (method-arity meth)) | |
| 1882 | (new-coarity (method-coarity meth))) | |
| 1883 | (declare (type list new-arity) | |
| 1884 | (type sort* new-coarity)) | |
| 1885 | (when (and (if upper-bound | |
| 1886 | (sort<= new-coarity upper-bound) | |
| 1887 | t) | |
| 1888 | (or (null method-res) | |
| 1889 | (and (sort<= cur-coarity new-coarity) | |
| 1890 | (sort-list<= cur-arity new-arity)))) | |
| 1891 | (return meth)))))))) | |
| 1593 | (if overloaded-methods | |
| 1594 | (car overloaded-methods) | |
| 1595 | method) | |
| 1596 | (let* ((*current-sort-order* (module-sort-order module)) | |
| 1597 | (*current-opinfo-table* (module-opinfo-table module)) | |
| 1598 | (eligible-flag (if upper-bound | |
| 1599 | (sort<= (method-coarity method) upper-bound) | |
| 1600 | t)) | |
| 1601 | (method-res (if eligible-flag method nil)) | |
| 1602 | (cur-arity (if eligible-flag (method-arity method) nil)) | |
| 1603 | (cur-coarity (if eligible-flag (method-coarity method) nil))) | |
| 1604 | (declare (type hash-table *current-sort-order* | |
| 1605 | *current-opinfo-table*) | |
| 1606 | (type (or null t) eligible-flag) | |
| 1607 | (type list cur-arity) | |
| 1608 | (type (or null method) method-res) | |
| 1609 | (type (or null sort*) cur-coarity)) | |
| 1610 | (dolist (meth (operator-methods (method-operator method) | |
| 1611 | (module-all-operators module)) | |
| 1612 | method-res) | |
| 1613 | (declare (type method meth)) | |
| 1614 | (let ((new-arity (method-arity meth)) | |
| 1615 | (new-coarity (method-coarity meth))) | |
| 1616 | (declare (type list new-arity) | |
| 1617 | (type sort* new-coarity)) | |
| 1618 | (when (and (if upper-bound | |
| 1619 | (sort<= new-coarity upper-bound) | |
| 1620 | t) | |
| 1621 | (or (null method-res) | |
| 1622 | (and (sort<= cur-coarity new-coarity) | |
| 1623 | (sort-list<= cur-arity new-arity)))) | |
| 1624 | (return meth)))))))) | |
| 1892 | 1625 | |
| 1893 | 1626 | ;;; GET-STRICT-LOWER-COARITIES : method module -> List[Sort] |
| 1894 | 1627 | ;;; |
| 1895 | 1628 | (defun get-strict-lower-coarities (method &optional (module *current-module*)) |
| 1896 | 1629 | (declare (type method method) |
| 1897 | (type module module) | |
| 1898 | (values list)) | |
| 1630 | (type module module) | |
| 1631 | (values list)) | |
| 1899 | 1632 | (let* (;; (arity (method-arity method)) |
| 1900 | (coarity (method-coarity method)) | |
| 1901 | (*current-sort-order* (module-sort-order module)) | |
| 1902 | (*current-opinfo-table* (module-opinfo-table module)) | |
| 1903 | (methods (method-lower-methods method *current-opinfo-table*))) | |
| 1633 | (coarity (method-coarity method)) | |
| 1634 | (*current-sort-order* (module-sort-order module)) | |
| 1635 | (*current-opinfo-table* (module-opinfo-table module)) | |
| 1636 | (methods (method-lower-methods method *current-opinfo-table*))) | |
| 1904 | 1637 | (declare (type sort* coarity) |
| 1905 | (type hash-table *current-sort-order* *current-opinfo-table*) | |
| 1906 | (type list methods)) | |
| 1638 | (type hash-table *current-sort-order* *current-opinfo-table*) | |
| 1639 | (type list methods)) | |
| 1907 | 1640 | (let ((res nil)) |
| 1908 | 1641 | (dolist (meth methods) |
| 1909 | (declare (type method meth)) | |
| 1642 | (declare (type method meth)) | |
| 1910 | 1643 | (let ((new-coarity (method-coarity meth))) |
| 1911 | (declare (type sort* new-coarity)) | |
| 1912 | (when (and (not (member new-coarity res :test #'eq)) | |
| 1913 | (sort<= (method-coarity meth) coarity)) | |
| 1914 | (push (method-coarity meth) res)))) | |
| 1644 | (declare (type sort* new-coarity)) | |
| 1645 | (when (and (not (member new-coarity res :test #'eq)) | |
| 1646 | (sort<= (method-coarity meth) coarity)) | |
| 1647 | (push (method-coarity meth) res)))) | |
| 1915 | 1648 | res ))) |
| 1916 | 1649 | |
| 1917 | 1650 | ;;; *MISC* |
| 1919 | 1652 | |
| 1920 | 1653 | (defun method-all-rules (method &optional (opinfo-table *current-opinfo-table*)) |
| 1921 | 1654 | (declare (type method method) |
| 1922 | (type hash-table opinfo-table) | |
| 1923 | (values list)) | |
| 1655 | (type hash-table opinfo-table) | |
| 1656 | (values list)) | |
| 1924 | 1657 | (let ((dif (method-rules-with-different-top method opinfo-table)) |
| 1925 | (ring (method-rules-with-same-top method opinfo-table)) | |
| 1926 | (res nil)) | |
| 1658 | (ring (method-rules-with-same-top method opinfo-table)) | |
| 1659 | (res nil)) | |
| 1927 | 1660 | (declare (type list dif) |
| 1928 | (type rule-ring ring)) | |
| 1661 | (type rule-ring ring)) | |
| 1929 | 1662 | (do ((rule (initialize-rule-ring ring) (rule-ring-next ring))) |
| 1930 | ((end-of-rule-ring ring)) | |
| 1663 | ((end-of-rule-ring ring)) | |
| 1931 | 1664 | (push rule res)) |
| 1932 | 1665 | (append dif res))) |
| 1933 | 1666 | |
| 1954 | 1687 | |
| 1955 | 1688 | (defun make-operator-internal (name num-args module) |
| 1956 | 1689 | (declare (type list name) |
| 1957 | (type fixnum num-args) | |
| 1958 | (type module module) | |
| 1959 | (values operator)) | |
| 1690 | (type fixnum num-args) | |
| 1691 | (type module module) | |
| 1692 | (values operator)) | |
| 1960 | 1693 | (let ((tseq (explode-operator-name name)) |
| 1961 | (t-cnt 0)) | |
| 1694 | (t-cnt 0)) | |
| 1962 | 1695 | (dolist (s tseq) |
| 1963 | 1696 | (when (eq s t) |
| 1964 | (incf t-cnt))) | |
| 1697 | (incf t-cnt))) | |
| 1965 | 1698 | (when (and (> t-cnt 0) |
| 1966 | (not (eql t-cnt num-args))) | |
| 1699 | (not (eql t-cnt num-args))) | |
| 1967 | 1700 | (with-output-chaos-error () |
| 1968 | (format t "Mismatching number of arguments for op ~a, shold be ~d." | |
| 1969 | name num-args))) | |
| 1701 | (format t "Mismatching number of arguments for op ~a, shold be ~d." | |
| 1702 | name num-args))) | |
| 1970 | 1703 | (let ((op (allocate-operator name num-args module))) |
| 1971 | 1704 | (declare (type operator op)) |
| 1972 | 1705 | ;; reset computable values |
| 1973 | 1706 | (unless (the (or null opsyntax) (operator-syntax op)) |
| 1974 | (setf (operator-syntax op) (make-opsyntax)) | |
| 1975 | (setf (operator-token-sequence op) tseq | |
| 1976 | (operator-is-mixfix op) (if (member t (operator-token-sequence op) | |
| 1977 | :test #'eq) | |
| 1978 | t | |
| 1979 | nil)) | |
| 1980 | (setf (operator-syntactic-type op) (operator-syntactic-type-from-name | |
| 1981 | (operator-token-sequence op)))) | |
| 1707 | (setf (operator-syntax op) (make-opsyntax)) | |
| 1708 | (setf (operator-token-sequence op) tseq | |
| 1709 | (operator-is-mixfix op) (if (member t (operator-token-sequence op) | |
| 1710 | :test #'eq) | |
| 1711 | t | |
| 1712 | nil)) | |
| 1713 | (setf (operator-syntactic-type op) (operator-syntactic-type-from-name | |
| 1714 | (operator-token-sequence op)))) | |
| 1982 | 1715 | (setf (operator-print-name op) |
| 1983 | (cmake-operator-print-name op)) | |
| 1716 | (cmake-operator-print-name op)) | |
| 1984 | 1717 | ;; reset to default values. |
| 1985 | 1718 | (setf (operator-strategy op) nil) |
| 1986 | 1719 | (setf (operator-precedence op) nil) |
| 1987 | 1720 | (setf (operator-associativity op) nil) |
| 1988 | 1721 | (setf (operator-computed-precedence op) nil) |
| 1989 | 1722 | (setf (operator-theory op) *the-empty-theory*) |
| 1990 | (set-context-module op module) | |
| 1723 | (set-object-context-module op module) | |
| 1991 | 1724 | op))) |
| 1992 | 1725 | |
| 1993 | 1726 | ;;; EOF |
| 0 | 0 | ;;;-*- Mode:LISP; Package: Chaos; Base:10; Syntax:Common-lisp -*- |
| 1 | 1 | ;;; |
| 2 | ;;; Copyright (c) 2000-2014, Toshimi Sawada. All rights reserved. | |
| 2 | ;;; Copyright (c) 2000-2015, Toshimi Sawada. All rights reserved. | |
| 3 | 3 | ;;; |
| 4 | 4 | ;;; Redistribution and use in source and binary forms, with or without |
| 5 | 5 | ;;; modification, are permitted provided that the following conditions |
| 27 | 27 | ;;; |
| 28 | 28 | (in-package :chaos) |
| 29 | 29 | #|============================================================================== |
| 30 | System: Chaos | |
| 31 | Module: primitives | |
| 32 | File: bsort.lisp | |
| 30 | System: Chaos | |
| 31 | Module: primitives | |
| 32 | File: bsort.lisp | |
| 33 | 33 | ==============================================================================|# |
| 34 | 34 | #-:chaos-debug |
| 35 | 35 | (declaim (optimize (speed 3) (safety 0) #-GCL (debug 0))) |
| 37 | 37 | (declaim (optimize (speed 1) (safety 3) #-GCL (debug 3))) |
| 38 | 38 | |
| 39 | 39 | ;;;============================================================================= |
| 40 | ;;; SORT | |
| 40 | ;;; SORT | |
| 41 | 41 | ;;;============================================================================= |
| 42 | 42 | |
| 43 | 43 | ;;; **************************************************************************** |
| 57 | 57 | ;;; never be created as a term body (abstract class). |
| 58 | 58 | ;;; |
| 59 | 59 | |
| 60 | #|| | |
| 61 | (defterm sort-struct (object) ; (static-object) | |
| 62 | ;; :name "" | |
| 63 | :visible (id ; sort name, symbol. | |
| 64 | hidden) ; flag, t iff the sort is hidden sort. | |
| 65 | ||
| 66 | :hidden (module ; module in which the sort is declared. | |
| 67 | ; type = module object. | |
| 68 | constructor ; the list of constructor methods of the | |
| 69 | ; sort. not used. | |
| 70 | inhabited ; temporary flag used for regularizing | |
| 71 | ; the signature of a module. | |
| 72 | ) | |
| 73 | :int-printer print-sort-internal | |
| 74 | :print print-sort-internal) | |
| 75 | ||# | |
| 76 | ||
| 77 | 60 | (defstruct (sort-struct (:conc-name "SORT-STRUCT-") |
| 78 | (:include object (-type 'sort-struct)) | |
| 79 | (:copier nil) | |
| 80 | (:print-function print-sort-internal) | |
| 81 | (:constructor make-sort-struct) | |
| 82 | (:constructor sort-struct* (id hidden))) | |
| 61 | (:include object (-type 'sort-struct)) | |
| 62 | (:copier nil) | |
| 63 | (:print-function print-sort-internal) | |
| 64 | (:constructor make-sort-struct) | |
| 65 | (:constructor sort-struct* (id hidden))) | |
| 83 | 66 | (id nil :type symbol) |
| 84 | 67 | (hidden nil :type (or null t)) |
| 85 | (module nil :type (or null module)) | |
| 86 | 68 | (constructor nil :type list) |
| 87 | 69 | (inhabited nil :type (or null t)) |
| 88 | (derived-from nil :type (or null sort-struct)) | |
| 89 | ) | |
| 70 | (derived-from nil :type (or null sort-struct))) | |
| 71 | ||
| 72 | (eval-when (:execute :load-toplevel :compile-toplevel) | |
| 73 | (defmacro sort-module (sort) | |
| 74 | `(object-context-mod ,sort)) | |
| 75 | ) | |
| 90 | 76 | |
| 91 | 77 | (eval-when (:execute :load-toplevel) |
| 92 | 78 | (setf (symbol-function 'sort-sort-struct) (symbol-function 'sort-struct-p)) |
| 102 | 88 | ;;;----------------------------------------------------------------------------- |
| 103 | 89 | |
| 104 | 90 | (defstruct (sort* (:include sort-struct (-type 'sort)) |
| 105 | (:conc-name "SORT-") | |
| 106 | (:copier nil) | |
| 107 | (:constructor make-sort) | |
| 108 | (:constructor sort* (id &optional hidden)) | |
| 109 | (:predicate sort-p) | |
| 110 | (:print-function print-sort-object)) | |
| 91 | (:conc-name "SORT-") | |
| 92 | (:copier nil) | |
| 93 | (:constructor make-sort) | |
| 94 | (:constructor sort* (id &optional hidden)) | |
| 95 | (:predicate sort-p) | |
| 96 | (:print-function print-sort-object)) | |
| 111 | 97 | ) |
| 112 | 98 | |
| 113 | 99 | (eval-when (:execute :load-toplevel) |
| 134 | 120 | (defun sort-is-derived-from (sort) |
| 135 | 121 | (let ((df (sort-derived-from sort))) |
| 136 | 122 | (if df |
| 137 | (or (sort-is-derived-from df) | |
| 138 | df) | |
| 139 | nil))) | |
| 123 | (or (sort-is-derived-from df) | |
| 124 | df) | |
| 125 | nil))) | |
| 140 | 126 | |
| 141 | 127 | (defun get-original-sort (sort) |
| 142 | 128 | (let ((res sort)) |
| 143 | 129 | (loop (if (null (sort-derived-from res)) |
| 144 | (return nil) | |
| 145 | (setq res (sort-derived-from res)))) | |
| 130 | (return nil) | |
| 131 | (setq res (sort-derived-from res)))) | |
| 146 | 132 | res)) |
| 147 | 133 | |
| 148 | 134 | ;;; Type predicates ----------------------------------------------------------- |
| 154 | 140 | |
| 155 | 141 | (defun sort-visible-type-print (sort) |
| 156 | 142 | (declare (type sort-struct sort) |
| 157 | (values symbol)) | |
| 143 | (values symbol)) | |
| 158 | 144 | (if (sort-is-hidden sort) |
| 159 | 145 | :h |
| 160 | 146 | :v)) |
| 163 | 149 | (declare (ignore ignore)) |
| 164 | 150 | (let ((name (concatenate 'string (string (sort-id obj)) "." (module-print-name (sort-module obj))))) |
| 165 | 151 | (if (sort-is-hidden obj) |
| 166 | (format stream ":hsort[~s]" name) | |
| 152 | (format stream ":hsort[~s]" name) | |
| 167 | 153 | (format stream ":sort[~s]" name)))) |
| 168 | 154 | |
| 169 | 155 | ;;; Constructor ---------------------------------------------------------------- |
| 170 | 156 | (defun new-general-sort (id module &optional hidden) |
| 171 | 157 | (declare (type symbol id) |
| 172 | (type module module) | |
| 173 | (type (or null t) hidden)) | |
| 158 | (type module module) | |
| 159 | (type (or null t) hidden)) | |
| 174 | 160 | (let ((sort (sort* id hidden))) |
| 175 | 161 | (setf (sort-module sort) module) |
| 176 | (set-context-module sort module) | |
| 162 | (set-object-context-module sort module) | |
| 177 | 163 | sort)) |
| 178 | 164 | |
| 179 | 165 | ;;; *SORT-TABLE* |
| 180 | #|| | |
| 181 | (defvar *sort-table* (make-hash-table :test #'equal)) | |
| 182 | (defmacro get-sort-named (sort-name_ module_) | |
| 183 | `(gethash (cons ,sort-name_ ,module_) *sort-table*)) | |
| 184 | (defun clear-all-sorts () (clrhash *sort-table*)) | |
| 185 | (defun register-sort (sort) | |
| 186 | (setf (gethash (cons (sort-id sort) (sort-module sort)) *sort-table*) sort)) | |
| 187 | ||
| 188 | ||# | |
| 189 | 166 | |
| 190 | 167 | (defvar *sort-table* nil) |
| 191 | 168 | (defun get-sort-named (sort-name module) |
| 192 | 169 | (declare (type symbol sort-name) |
| 193 | (type module module) | |
| 194 | (values (or null sort-struct))) | |
| 170 | (type module module) | |
| 171 | (values (or null sort-struct))) | |
| 195 | 172 | (find-in-assoc-table *sort-table* (cons sort-name module))) |
| 196 | 173 | |
| 197 | 174 | (defun clear-tmp-sort-cache () (setq *sort-table* nil)) |
| 198 | 175 | (defun register-sort-cache (sort) |
| 199 | 176 | (declare (type sort-struct sort) |
| 200 | (values t)) | |
| 177 | (values t)) | |
| 201 | 178 | (add-to-assoc-table *sort-table* (cons (sort-id sort) |
| 202 | (sort-module sort)) | |
| 203 | sort)) | |
| 179 | (sort-module sort)) | |
| 180 | sort)) | |
| 204 | 181 | |
| 205 | 182 | ;;; ************ |
| 206 | 183 | ;;; RECORD&CLASS________________ |
| 230 | 207 | ;;; |
| 231 | 208 | |
| 232 | 209 | (defstruct (crsort (:include sort* (-type 'crsort)) |
| 233 | (:copier nil) | |
| 234 | (:constructor make-crsort) | |
| 235 | (:constructor crsort* (id &optional hidden)) | |
| 236 | (:print-function print-cr-sort-object)) | |
| 237 | (slots nil :type list) ; slot informations. | |
| 238 | (idconstr nil :type list) ; id constructor info. | |
| 239 | (constr nil :type t) ; term constructor method. | |
| 240 | (maker nil :type list) ; list of methods for `make.Foo' | |
| 241 | ; operations. | |
| 242 | (copy nil :type (or null t)) ; t iff the sort is a copy. | |
| 210 | (:copier nil) | |
| 211 | (:constructor make-crsort) | |
| 212 | (:constructor crsort* (id &optional hidden)) | |
| 213 | (:print-function print-cr-sort-object)) | |
| 214 | (slots nil :type list) ; slot informations. | |
| 215 | (idconstr nil :type list) ; id constructor info. | |
| 216 | (constr nil :type t) ; term constructor method. | |
| 217 | (maker nil :type list) ; list of methods for `make.Foo' | |
| 218 | ; operations. | |
| 219 | (copy nil :type (or null t)) ; t iff the sort is a copy. | |
| 243 | 220 | ) |
| 244 | 221 | |
| 245 | 222 | (eval-when (:execute :load-toplevel) |
| 255 | 232 | ;;; |
| 256 | 233 | |
| 257 | 234 | (defstruct (class-sort (:include crsort (-type 'class-sort)) |
| 258 | (:copier nil) | |
| 259 | (:constructor make-class-sort) | |
| 260 | (:constructor class-sort* (id &optional hidden)) | |
| 261 | (:print-function print-class-sort-object)) | |
| 235 | (:copier nil) | |
| 236 | (:constructor make-class-sort) | |
| 237 | (:constructor class-sort* (id &optional hidden)) | |
| 238 | (:print-function print-class-sort-object)) | |
| 262 | 239 | ) |
| 263 | 240 | |
| 264 | 241 | (eval-when (:execute :load-toplevel) |
| 272 | 249 | ;;; Record sort ________________ |
| 273 | 250 | |
| 274 | 251 | (defstruct (record-sort (:include crsort (-type 'record-sort)) |
| 275 | (:constructor make-record-sort) | |
| 276 | (:constructor record-sort* (id &optional hidden)) | |
| 277 | (:print-function print-record-sort-object) | |
| 278 | (:copier nil)) | |
| 252 | (:constructor make-record-sort) | |
| 253 | (:constructor record-sort* (id &optional hidden)) | |
| 254 | (:print-function print-record-sort-object) | |
| 255 | (:copier nil)) | |
| 279 | 256 | ) |
| 280 | 257 | |
| 281 | 258 | (eval-when (:execute :load-toplevel) |
| 282 | 259 | (setf (get 'record-sort :type-predicate) |
| 283 | (symbol-function 'record-sort-p)) | |
| 260 | (symbol-function 'record-sort-p)) | |
| 284 | 261 | (setf (get 'record-sort :print) 'print-sort-internal) |
| 285 | 262 | (setf (symbol-function 'is-record-sort) |
| 286 | (symbol-function 'record-sort-p))) | |
| 263 | (symbol-function 'record-sort-p))) | |
| 287 | 264 | |
| 288 | 265 | (defun print-record-sort-object (obj stream &rest ignore) |
| 289 | 266 | (print-sort-object obj stream ignore)) |
| 310 | 287 | |
| 311 | 288 | (defun create-cr-sort (p-type id module constructor inhabited slots hidden) |
| 312 | 289 | (declare (type symbol p-type id) |
| 313 | (type module module) | |
| 314 | (type t constructor) | |
| 315 | (type (or null t) inhabited hidden) | |
| 316 | (type list slots) | |
| 317 | (values crsort)) | |
| 290 | (type module module) | |
| 291 | (type t constructor) | |
| 292 | (type (or null t) inhabited hidden) | |
| 293 | (type list slots) | |
| 294 | (values crsort)) | |
| 318 | 295 | (let ((s (if (eq p-type 'class-sort) |
| 319 | (class-sort* id) | |
| 320 | (record-sort* id)))) | |
| 296 | (class-sort* id) | |
| 297 | (record-sort* id)))) | |
| 321 | 298 | (setf (sort-module s) module |
| 322 | (sort-constructor s) constructor | |
| 323 | (sort-inhabited s) inhabited | |
| 324 | (crsort-slots s) slots | |
| 325 | (crsort-hidden s) hidden) | |
| 299 | (sort-constructor s) constructor | |
| 300 | (sort-inhabited s) inhabited | |
| 301 | (crsort-slots s) slots | |
| 302 | (crsort-hidden s) hidden) | |
| 326 | 303 | (setf (crsort-maker s) (if (eq p-type 'class-sort) |
| 327 | (list nil nil nil nil) | |
| 328 | (list nil nil))) | |
| 329 | (set-context-module s module) | |
| 304 | (list nil nil nil nil) | |
| 305 | (list nil nil))) | |
| 306 | (set-object-context-module s module) | |
| 330 | 307 | s)) |
| 331 | 308 | |
| 332 | 309 | (defun new-record-sort (id module &optional hidden) |
| 333 | 310 | (declare (type symbol id) |
| 334 | (type module module) | |
| 335 | (type (or null t) hidden) | |
| 336 | (values crsort)) | |
| 337 | (create-cr-sort 'record-sort ; type | |
| 338 | id ; id | |
| 339 | module ; | |
| 340 | nil ; constructor | |
| 341 | nil ; inhabited | |
| 342 | nil ; slots | |
| 343 | hidden)) | |
| 311 | (type module module) | |
| 312 | (type (or null t) hidden) | |
| 313 | (values crsort)) | |
| 314 | (create-cr-sort 'record-sort ; type | |
| 315 | id ; id | |
| 316 | module ; | |
| 317 | nil ; constructor | |
| 318 | nil ; inhabited | |
| 319 | nil ; slots | |
| 320 | hidden)) | |
| 344 | 321 | |
| 345 | 322 | (defun new-class-sort (id module &optional hidden) |
| 346 | 323 | (declare (type symbol id) |
| 347 | (type module module) | |
| 348 | (type (or null t) hidden) | |
| 349 | (values crsort)) | |
| 324 | (type module module) | |
| 325 | (type (or null t) hidden) | |
| 326 | (values crsort)) | |
| 350 | 327 | (create-cr-sort 'class-sort |
| 351 | id | |
| 352 | module | |
| 353 | nil | |
| 354 | nil | |
| 355 | nil | |
| 356 | hidden)) | |
| 328 | id | |
| 329 | module | |
| 330 | nil | |
| 331 | nil | |
| 332 | nil | |
| 333 | hidden)) | |
| 357 | 334 | |
| 358 | 335 | ;;; Type Predicates ------------------------------------------------------------ |
| 359 | 336 | |
| 360 | 337 | ;;; (defmacro crsort-p (_s) |
| 361 | 338 | ;;; `(and (chaos-object? ,_s) (memq (object-type ,_s) '(record-sort |
| 362 | ;;; class-sort)))) | |
| 339 | ;;; class-sort)))) | |
| 363 | 340 | ;;; (defmacro record-sort-p (_s) `(is-record-sort ,_s)) |
| 364 | 341 | ;;; (defmacro class-sort-p (_s) `(is-class-sort ,_s)) |
| 365 | 342 | |
| 366 | 343 | ;;; Accessors For Slot Informations -------------------------------------------- |
| 367 | 344 | |
| 368 | 345 | (defmacro find-slot-info (slot-name sort) ` (assoc ,slot-name (crsort-slots ,sort) |
| 369 | :test #'equal)) | |
| 346 | :test #'equal)) | |
| 370 | 347 | (defmacro cr-slot-name (_slot-info) `(car ,_slot-info)) |
| 371 | 348 | (defmacro cr-slot-sort (_slot-info) `(cadr ,_slot-info)) |
| 372 | 349 | (defmacro cr-slot-default (_slot-info) `(caddr ,_slot-info)) |
| 402 | 379 | ;;; |
| 403 | 380 | |
| 404 | 381 | (defstruct (bsort (:include sort* (-type 'bsort)) |
| 405 | (:copier nil) | |
| 406 | (:constructor make-bsort) | |
| 407 | (:constructor bsort* (id &optional hidden)) | |
| 408 | (:print-function print-bsort-object)) | |
| 382 | (:copier nil) | |
| 383 | (:constructor make-bsort) | |
| 384 | (:constructor bsort* (id &optional hidden)) | |
| 385 | (:print-function print-bsort-object)) | |
| 409 | 386 | (info nil :type list)) |
| 410 | 387 | |
| 411 | 388 | (eval-when (:execute :load-toplevel) |
| 423 | 400 | |
| 424 | 401 | (defun new-bi-sort (id module &optional info hidden) |
| 425 | 402 | (declare (type symbol id) |
| 426 | (type module module) | |
| 427 | (type list info) | |
| 428 | (type (or null t) hidden) | |
| 429 | (values bsort)) | |
| 403 | (type module module) | |
| 404 | (type list info) | |
| 405 | (type (or null t) hidden) | |
| 406 | (values bsort)) | |
| 430 | 407 | (let ((bs (bsort* id hidden))) |
| 431 | 408 | (setf (sort-module bs) module |
| 432 | (bsort-info bs) info) | |
| 433 | (set-context-module bs module) | |
| 409 | (bsort-info bs) info) | |
| 410 | (set-object-context-module bs module) | |
| 434 | 411 | bs)) |
| 435 | 412 | |
| 436 | 413 | ;;; Predicate ------------------------------------------------------------------ |
| 459 | 436 | |
| 460 | 437 | (defun get-builtin-sort-named (sort-name) |
| 461 | 438 | (declare (type symbol sort-name) |
| 462 | (values (or null bsort))) | |
| 439 | (values (or null bsort))) | |
| 463 | 440 | (find-in-assoc-table *builtin-sort-table* sort-name #'eq)) |
| 464 | 441 | |
| 465 | 442 | (defun register-builtin-sort (sort) |
| 466 | 443 | (declare (type bsort sort) |
| 467 | (values t)) | |
| 444 | (values t)) | |
| 468 | 445 | (add-to-assoc-table *builtin-sort-table* (sort-id sort) sort #'eq)) |
| 469 | 446 | |
| 470 | 447 | (defun clear-builtin-sorts () |
| 481 | 458 | ;;; |
| 482 | 459 | |
| 483 | 460 | (defstruct (and-sort (:include sort* (-type 'and-sort)) |
| 484 | (:copier nil) | |
| 485 | (:constructor make-and-sort) | |
| 486 | (:constructor and-sort* (id &optional hidden)) | |
| 487 | (:print-function print-and-sort-object)) | |
| 461 | (:copier nil) | |
| 462 | (:constructor make-and-sort) | |
| 463 | (:constructor and-sort* (id &optional hidden)) | |
| 464 | (:print-function print-and-sort-object)) | |
| 488 | 465 | (components nil :type list)) |
| 489 | 466 | |
| 490 | 467 | (eval-when (:execute :load-toplevel) |
| 491 | 468 | (setf (get 'and-sort :type-predicate) |
| 492 | (symbol-function 'and-sort-p)) | |
| 469 | (symbol-function 'and-sort-p)) | |
| 493 | 470 | (setf (symbol-function 'is-and-sort) |
| 494 | (symbol-function 'and-sort-p)) | |
| 471 | (symbol-function 'and-sort-p)) | |
| 495 | 472 | (setf (get 'and-sort :print) |
| 496 | 'print-and-sort-internal)) | |
| 473 | 'print-and-sort-internal)) | |
| 497 | 474 | |
| 498 | 475 | (defun print-and-sort-object (obj stream &rest ignore) |
| 499 | 476 | (print-sort-object obj stream ignore)) |
| 506 | 483 | |
| 507 | 484 | (defun new-and-sort (id &optional module and-components hidden) |
| 508 | 485 | (declare (type symbol id) |
| 509 | (type (or null module) module) | |
| 510 | (type list and-components) | |
| 511 | (type (or null t) hidden) | |
| 512 | (values and-sort)) | |
| 486 | (type (or null module) module) | |
| 487 | (type list and-components) | |
| 488 | (type (or null t) hidden) | |
| 489 | (values and-sort)) | |
| 513 | 490 | (let ((as (and-sort* id hidden))) |
| 514 | 491 | (setf (sort-module as) module |
| 515 | (and-sort-components as) and-components) | |
| 516 | (set-context-module as module) | |
| 492 | (and-sort-components as) and-components) | |
| 493 | (set-object-context-module as module) | |
| 517 | 494 | as)) |
| 518 | 495 | |
| 519 | 496 | ;;; Predicates ----------------------------------------------------------------- |
| 536 | 513 | ;;; |
| 537 | 514 | |
| 538 | 515 | (defstruct (or-sort (:include sort* (-type 'or-sort)) |
| 539 | (:copier nil) | |
| 540 | (:constructor make-or-sort) | |
| 541 | (:constructor or-sort* (id &optional hidden)) | |
| 542 | (:print-function print-or-sort-object)) | |
| 516 | (:copier nil) | |
| 517 | (:constructor make-or-sort) | |
| 518 | (:constructor or-sort* (id &optional hidden)) | |
| 519 | (:print-function print-or-sort-object)) | |
| 543 | 520 | (components nil :type list)) |
| 544 | 521 | |
| 545 | 522 | (eval-when (:execute :load-toplevel) |
| 546 | 523 | (setf (get 'or-sort :type-predicate) (symbol-function 'or-sort-p)) |
| 547 | 524 | (setf (get 'or-sort :print) 'print-or-sort-internal) |
| 548 | 525 | (setf (symbol-function 'is-or-sort) |
| 549 | (symbol-function 'or-sort-p))) | |
| 526 | (symbol-function 'or-sort-p))) | |
| 550 | 527 | |
| 551 | 528 | (defun print-or-sort-object (obj stream &rest ignore) |
| 552 | 529 | (print-sort-object obj stream ignore)) |
| 560 | 537 | |
| 561 | 538 | (defun new-or-sort (id &optional module or-components hidden) |
| 562 | 539 | (declare (type symbol id) |
| 563 | (type (or null module) module) | |
| 564 | (type list or-components) | |
| 565 | (type (or null t) hidden) | |
| 566 | (values or-sort)) | |
| 540 | (type (or null module) module) | |
| 541 | (type list or-components) | |
| 542 | (type (or null t) hidden) | |
| 543 | (values or-sort)) | |
| 567 | 544 | (let ((os (or-sort* id hidden))) |
| 568 | 545 | (setf (sort-module os) module |
| 569 | (or-sort-components os) or-components) | |
| 570 | (set-context-module os module) | |
| 546 | (or-sort-components os) or-components) | |
| 547 | (set-object-context-module os module) | |
| 571 | 548 | os)) |
| 572 | 549 | |
| 573 | 550 | ;;; Predicate ------------------------------------------------------------------ |
| 583 | 560 | ;;; |
| 584 | 561 | |
| 585 | 562 | (defstruct (err-sort (:include sort* (-type 'err-sort)) |
| 586 | (:copier nil) | |
| 587 | (:constructor make-err-sort) | |
| 588 | (:constructor err-sort* (id &optional hidden)) | |
| 589 | (:print-function print-err-sort-object)) | |
| 563 | (:copier nil) | |
| 564 | (:constructor make-err-sort) | |
| 565 | (:constructor err-sort* (id &optional hidden)) | |
| 566 | (:print-function print-err-sort-object)) | |
| 590 | 567 | (components nil :type list) |
| 591 | 568 | (lowers nil :type list)) |
| 592 | 569 | |
| 610 | 587 | |
| 611 | 588 | (defun new-err-sort (id &optional module components lowers hidden) |
| 612 | 589 | (declare (type symbol id) |
| 613 | (type (or null module) module) | |
| 614 | (type list components lowers) | |
| 615 | (type (or null t) hidden) | |
| 616 | (values err-sort)) | |
| 590 | (type (or null module) module) | |
| 591 | (type list components lowers) | |
| 592 | (type (or null t) hidden) | |
| 593 | (values err-sort)) | |
| 617 | 594 | (let ((es (err-sort* id hidden))) |
| 618 | 595 | (setf (sort-module es) module |
| 619 | (err-sort-components es) components | |
| 620 | (err-sort-lowers es) lowers) | |
| 621 | (set-context-module es module) | |
| 596 | (err-sort-components es) components | |
| 597 | (err-sort-lowers es) lowers) | |
| 598 | (set-object-context-module es module) | |
| 622 | 599 | es)) |
| 623 | 600 | |
| 624 | 601 | ;;; Predicates ---------------------------------------------------------------- |
| 641 | 618 | (defmacro sort-set-equal (_s1 _s2) |
| 642 | 619 | (once-only (_s1 _s2) |
| 643 | 620 | ` (if (< (length ,_s1) (length ,_s2)) |
| 644 | (null (set-difference ,_s2 ,_s1 :test #'sort=*)) | |
| 645 | (null (set-difference ,_s1 ,_s2 :test #'sort=*))))) | |
| 621 | (null (set-difference ,_s2 ,_s1 :test #'sort=*)) | |
| 622 | (null (set-difference ,_s1 ,_s2 :test #'sort=*))))) | |
| 646 | 623 | |
| 647 | 624 | (defmacro sort-list= (sl1_ sl2_) `(equal ,sl1_ ,sl2_)) |
| 648 | 625 | |
| 649 | 626 | ;;;============================================================================= |
| 650 | ;;; SORT RELATION & SORT ORDER | |
| 627 | ;;; SORT RELATION & SORT ORDER | |
| 651 | 628 | ;;;============================================================================= |
| 652 | 629 | |
| 653 | 630 | ;;; All of the sorts of a signature is gathered and stored in order according |
| 693 | 670 | |
| 694 | 671 | (defun elim-sys-sorts-from-relation (sl) |
| 695 | 672 | (declare (type list sl) |
| 696 | (values list)) | |
| 673 | (values list)) | |
| 697 | 674 | (macrolet ((pure? (_sl) |
| 698 | ` (dolist (_s ,_sl t) | |
| 699 | (when (sort-is-for-regularity? _s) (return nil)))) | |
| 700 | (rem-sys (_sl) | |
| 701 | `(remove-if #'(lambda (x) (sort-is-for-regularity? x)) ,_sl))) | |
| 675 | ` (dolist (_s ,_sl t) | |
| 676 | (when (sort-is-for-regularity? _s) (return nil)))) | |
| 677 | (rem-sys (_sl) | |
| 678 | `(remove-if #'(lambda (x) (sort-is-for-regularity? x)) ,_sl))) | |
| 702 | 679 | (let ((s (sort-relation-sort sl)) |
| 703 | (subs (_subsorts sl)) | |
| 704 | (sups (_supersorts sl))) | |
| 680 | (subs (_subsorts sl)) | |
| 681 | (sups (_supersorts sl))) | |
| 705 | 682 | (when (sort-is-for-regularity? s) |
| 706 | (return-from elim-sys-sorts-from-relation nil)) | |
| 683 | (return-from elim-sys-sorts-from-relation nil)) | |
| 707 | 684 | (make-sort-relation s |
| 708 | (if (pure? subs) subs (rem-sys subs)) | |
| 709 | (if (pure? sups) sups (rem-sys sups)))))) | |
| 685 | (if (pure? subs) subs (rem-sys subs)) | |
| 686 | (if (pure? sups) sups (rem-sys sups)))))) | |
| 710 | 687 | |
| 711 | 688 | ;;; ********** |
| 712 | 689 | ;;; SORT-ORDER__________________ |
| 721 | 698 | |
| 722 | 699 | (defun clear-sort-order (sorder) |
| 723 | 700 | (declare (type sort-order sorder) |
| 724 | (values t)) | |
| 701 | (values t)) | |
| 725 | 702 | (clrhash sorder)) |
| 726 | 703 | |
| 727 | 704 | ;;; GET SORT'S RELATION FROM SORT ORDER. |
| 736 | 713 | |
| 737 | 714 | (defun copy-sort-order (sort-order) |
| 738 | 715 | (declare (type sort-order sort-order) |
| 739 | (values sort-order)) | |
| 716 | (values sort-order)) | |
| 740 | 717 | (let ((new-order (allocate-sort-order))) |
| 741 | 718 | (maphash #'(lambda (s sl) |
| 742 | (setf (gethash s new-order) (copy-list sl))) | |
| 743 | sort-order) | |
| 719 | (setf (gethash s new-order) (copy-list sl))) | |
| 720 | sort-order) | |
| 744 | 721 | new-order)) |
| 745 | 722 | |
| 746 | 723 | (defun get-all-sorts (sort-order) |
| 747 | 724 | (declare (type sort-order sort-order) |
| 748 | (values list)) | |
| 725 | (values list)) | |
| 749 | 726 | (let ((res nil)) |
| 750 | 727 | (maphash #'(lambda (ss sl) |
| 751 | (declare (ignore sl)) | |
| 752 | (push ss res)) | |
| 753 | sort-order) | |
| 728 | (declare (ignore sl)) | |
| 729 | (push ss res)) | |
| 730 | sort-order) | |
| 754 | 731 | res)) |
| 755 | 732 | |
| 756 | 733 | ;;; ACCESSORS via SORT |
| 758 | 735 | (defmacro subsorts (_sort &optional (_sort-order '*current-sort-order*)) |
| 759 | 736 | (once-only (_sort) |
| 760 | 737 | ` (if (err-sort-p ,_sort) |
| 761 | (err-sort-lowers ,_sort) | |
| 762 | (_subsorts (get-sort-relation ,_sort ,_sort-order))))) | |
| 738 | (err-sort-lowers ,_sort) | |
| 739 | (_subsorts (get-sort-relation ,_sort ,_sort-order))))) | |
| 763 | 740 | |
| 764 | 741 | (defmacro sub-or-equal-sorts (_sort &optional (_sort-order '*current-sort-order*)) |
| 765 | 742 | (once-only (_sort) |
| 766 | 743 | ` (if (err-sort-p ,_sort) |
| 767 | (cons ,_sort (err-sort-lowers ,_sort)) | |
| 768 | (let ((.sort-relation. (get-sort-relation ,_sort ,_sort-order))) | |
| 769 | (cons ,_sort | |
| 770 | (_subsorts .sort-relation.)))))) | |
| 744 | (cons ,_sort (err-sort-lowers ,_sort)) | |
| 745 | (let ((.sort-relation. (get-sort-relation ,_sort ,_sort-order))) | |
| 746 | (cons ,_sort | |
| 747 | (_subsorts .sort-relation.)))))) | |
| 771 | 748 | |
| 772 | 749 | (defmacro supersorts (_sort &optional (_sort-order '*current-sort-order*)) |
| 773 | 750 | (once-only (_sort _sort-order) |
| 774 | 751 | ` (if (err-sort-p ,_sort) |
| 775 | nil | |
| 776 | (let (($sl (get-sort-relation ,_sort ,_sort-order))) | |
| 777 | (or (and (_err-sort $sl) | |
| 778 | (cons (_err-sort $sl) (_supersorts $sl))) | |
| 779 | (_supersorts $sl)))))) | |
| 752 | nil | |
| 753 | (let (($sl (get-sort-relation ,_sort ,_sort-order))) | |
| 754 | (or (and (_err-sort $sl) | |
| 755 | (cons (_err-sort $sl) (_supersorts $sl))) | |
| 756 | (_supersorts $sl)))))) | |
| 780 | 757 | |
| 781 | 758 | (defmacro supersorts-no-err (_sort &optional (_sort-order '*current-sort-order*)) |
| 782 | 759 | (once-only (_sort _sort-order) |
| 783 | 760 | ` (if (err-sort-p ,_sort) |
| 784 | nil | |
| 785 | (let (($sl (get-sort-relation ,_sort ,_sort-order))) | |
| 786 | (_supersorts $sl))))) | |
| 761 | nil | |
| 762 | (let (($sl (get-sort-relation ,_sort ,_sort-order))) | |
| 763 | (_supersorts $sl))))) | |
| 787 | 764 | |
| 788 | 765 | (defmacro super-or-equal-sorts (_sort &optional (_sort-order '*current-sort-order*)) |
| 789 | 766 | (once-only (_sort) |
| 790 | 767 | ` (if (err-sort-p ,_sort) |
| 791 | (list ,_sort) | |
| 792 | (let ((.sort-relation. (get-sort-relation ,_sort ,_sort-order))) | |
| 793 | (cons ,_sort | |
| 794 | (or (and (_err-sort .sort-relation.) | |
| 795 | (cons (_err-sort .sort-relation.) | |
| 796 | (_supersorts .sort-relation.))) | |
| 797 | (_supersorts .sort-relation.))))))) | |
| 768 | (list ,_sort) | |
| 769 | (let ((.sort-relation. (get-sort-relation ,_sort ,_sort-order))) | |
| 770 | (cons ,_sort | |
| 771 | (or (and (_err-sort .sort-relation.) | |
| 772 | (cons (_err-sort .sort-relation.) | |
| 773 | (_supersorts .sort-relation.))) | |
| 774 | (_supersorts .sort-relation.))))))) | |
| 798 | 775 | |
| 799 | 776 | (defun the-err-sort (sort &optional (sort-order *current-sort-order*)) |
| 800 | 777 | (declare (type sort* sort) |
| 801 | (type sort-order sort-order)) | |
| 778 | (type sort-order sort-order)) | |
| 802 | 779 | (cond ((sort= sort *universal-sort*) sort) |
| 803 | ((sort= sort *huniversal-sort*) sort) | |
| 804 | ((sort= sort *cosmos*) sort) | |
| 805 | ((sort= sort *bottom-sort*) sort) | |
| 806 | (t (if (err-sort-p sort) | |
| 807 | sort | |
| 808 | (_err-sort (get-sort-relation sort sort-order)))))) | |
| 780 | ((sort= sort *huniversal-sort*) sort) | |
| 781 | ((sort= sort *cosmos*) sort) | |
| 782 | ((sort= sort *bottom-sort*) sort) | |
| 783 | (t (if (err-sort-p sort) | |
| 784 | sort | |
| 785 | (_err-sort (get-sort-relation sort sort-order)))))) | |
| 809 | 786 | |
| 810 | 787 | (defsetf the-err-sort (__sort &optional (__sort-order *current-sort-order*)) |
| 811 | 788 | (__value) |
| 821 | 798 | #-GCL |
| 822 | 799 | (defun sort< (s1 s2 &optional (sort-order *current-sort-order*)) |
| 823 | 800 | (declare (type sort* s1 s2) |
| 824 | (type sort-order sort-order) | |
| 825 | (values (or null t))) | |
| 801 | (type sort-order sort-order) | |
| 802 | (values (or null t))) | |
| 826 | 803 | (and (not (sort= s1 s2)) |
| 827 | 804 | (or (sort= s2 *cosmos*) |
| 828 | (if (sort-is-hidden s1) | |
| 829 | (if (sort= s2 *huniversal-sort*) | |
| 830 | t | |
| 831 | (if (sort= s1 *huniversal-sort*) | |
| 832 | nil | |
| 833 | (memq s2 (supersorts s1 sort-order)))) | |
| 834 | (if (sort= s2 *universal-sort*) | |
| 835 | t | |
| 836 | (if (sort= s1 *universal-sort*) | |
| 837 | nil | |
| 838 | (if (sort= s1 *bottom-sort*) | |
| 839 | t | |
| 840 | (if (sort= s2 *bottom-sort*) | |
| 841 | nil | |
| 842 | (memq s2 (supersorts s1 sort-order)))))))))) | |
| 805 | (if (sort-is-hidden s1) | |
| 806 | (if (sort= s2 *huniversal-sort*) | |
| 807 | t | |
| 808 | (if (sort= s1 *huniversal-sort*) | |
| 809 | nil | |
| 810 | (memq s2 (supersorts s1 sort-order)))) | |
| 811 | (if (sort= s2 *universal-sort*) | |
| 812 | t | |
| 813 | (if (sort= s1 *universal-sort*) | |
| 814 | nil | |
| 815 | (if (sort= s1 *bottom-sort*) | |
| 816 | t | |
| 817 | (if (sort= s2 *bottom-sort*) | |
| 818 | nil | |
| 819 | (memq s2 (supersorts s1 sort-order)))))))))) | |
| 843 | 820 | |
| 844 | 821 | #+GCL |
| 845 | 822 | (defmacro sort< (s1 s2 &optional (sort-order '*current-sort-order*)) |
| 846 | 823 | (once-only (s1 s2) |
| 847 | 824 | ` (and (not (sort= ,s1 ,s2)) |
| 848 | (or (sort= ,s2 *cosmos*) | |
| 849 | (if (sort-is-hidden ,s1) | |
| 850 | (if (sort= ,s2 *huniversal-sort*) | |
| 851 | t | |
| 852 | (if (sort= ,s1 *huniversal-sort*) | |
| 853 | nil | |
| 854 | (memq ,s2 (supersorts ,s1 ,sort-order)))) | |
| 855 | (if (sort= ,s2 *universal-sort*) | |
| 856 | t | |
| 857 | (if (sort= ,s1 *universal-sort*) | |
| 858 | nil | |
| 859 | (if (sort= ,s1 *bottom-sort*) | |
| 860 | t | |
| 861 | (if (sort= ,s2 *bottom-sort*) | |
| 862 | nil | |
| 863 | (memq ,s2 (supersorts ,s1 ,sort-order))))))))))) | |
| 825 | (or (sort= ,s2 *cosmos*) | |
| 826 | (if (sort-is-hidden ,s1) | |
| 827 | (if (sort= ,s2 *huniversal-sort*) | |
| 828 | t | |
| 829 | (if (sort= ,s1 *huniversal-sort*) | |
| 830 | nil | |
| 831 | (memq ,s2 (supersorts ,s1 ,sort-order)))) | |
| 832 | (if (sort= ,s2 *universal-sort*) | |
| 833 | t | |
| 834 | (if (sort= ,s1 *universal-sort*) | |
| 835 | nil | |
| 836 | (if (sort= ,s1 *bottom-sort*) | |
| 837 | t | |
| 838 | (if (sort= ,s2 *bottom-sort*) | |
| 839 | nil | |
| 840 | (memq ,s2 (supersorts ,s1 ,sort-order))))))))))) | |
| 864 | 841 | |
| 865 | 842 | ;;; function version |
| 866 | 843 | (defun sort<* (s1 s2 &optional (sort-order *current-sort-order*)) |
| 867 | 844 | (declare (type sort* s1 s2) |
| 868 | (type sort-order sort-order) | |
| 869 | (values (or null t))) | |
| 845 | (type sort-order sort-order) | |
| 846 | (values (or null t))) | |
| 870 | 847 | (sort< s1 s2 sort-order)) |
| 871 | 848 | |
| 872 | 849 | ;;; SORT<= sort1 sort2 sort-order |
| 875 | 852 | (defmacro sort<= (_s1 _s2 &optional (_sort-order '*current-sort-order*)) |
| 876 | 853 | (once-only (_s1 _s2) |
| 877 | 854 | ` (or (sort= ,_s1 ,_s2) |
| 878 | (sort< ,_s1 ,_s2 ,_sort-order)))) | |
| 855 | (sort< ,_s1 ,_s2 ,_sort-order)))) | |
| 879 | 856 | |
| 880 | 857 | ;;; it's function version. |
| 881 | 858 | (defun sort<=* (s1 s2 &optional (sort-order *current-sort-order*)) |
| 882 | 859 | (declare (type sort* s1 s2) |
| 883 | (type sort-order sort-order) | |
| 884 | (values (or null t))) | |
| 860 | (type sort-order sort-order) | |
| 861 | (values (or null t))) | |
| 885 | 862 | (or (sort= s1 s2) (sort< s1 s2 sort-order))) |
| 886 | 863 | |
| 887 | 864 | ;;; SORT-IS-IN sort sort-set sort-order |
| 892 | 869 | (defmacro sort-is-in (_s _sort-set &optional (_sort-order '*current-sort-order*)) |
| 893 | 870 | (once-only (_s _sort-set _sort-order) |
| 894 | 871 | ` (and ,_sort-set |
| 895 | (dolist (.s1. ,_sort-set nil) | |
| 896 | (if (or (sort= ,_s .s1.) | |
| 897 | (member ,_s (subsorts .s1. ,_sort-order) :test #'eq) | |
| 898 | (member ,_s (supersorts .s1. ,_sort-order) :test #'eq)) | |
| 899 | (return t)))))) | |
| 872 | (dolist (.s1. ,_sort-set nil) | |
| 873 | (if (or (sort= ,_s .s1.) | |
| 874 | (member ,_s (subsorts .s1. ,_sort-order) :test #'eq) | |
| 875 | (member ,_s (supersorts .s1. ,_sort-order) :test #'eq)) | |
| 876 | (return t)))))) | |
| 900 | 877 | |
| 901 | 878 | ;;; SORT-LIST<= sort-list1 sort-list2 sort-order |
| 902 | 879 | ;;; returns t iff each elements of sort-list1 is a subsort of |
| 904 | 881 | ;;; |
| 905 | 882 | (defun sort-list<= (lst1 lst2 &optional (so *current-sort-order*)) |
| 906 | 883 | (declare (type list lst1 lst2) |
| 907 | (type sort-order so) | |
| 908 | (values (or null t))) | |
| 884 | (type sort-order so) | |
| 885 | (values (or null t))) | |
| 909 | 886 | (loop (when (null lst1)(return (null lst2))) |
| 910 | (when (null lst2)(return (null lst1))) | |
| 911 | (unless (sort<= (car lst1) (car lst2) so) | |
| 912 | (return nil)) | |
| 913 | (setq lst1 (cdr lst1)) | |
| 914 | (setq lst2 (cdr lst2)))) | |
| 887 | (when (null lst2)(return (null lst1))) | |
| 888 | (unless (sort<= (car lst1) (car lst2) so) | |
| 889 | (return nil)) | |
| 890 | (setq lst1 (cdr lst1)) | |
| 891 | (setq lst2 (cdr lst2)))) | |
| 915 | 892 | |
| 916 | 893 | (defun sort-list<=-any (lst1 lst2 &optional (so *current-sort-order*)) |
| 917 | 894 | (declare (type list lst1 lst2) |
| 918 | (type sort-order so) | |
| 919 | (values (or null t))) | |
| 895 | (type sort-order so) | |
| 896 | (values (or null t))) | |
| 920 | 897 | (loop (when (null lst1)(return (null lst2))) |
| 921 | (when (null lst2)(return (null lst1))) | |
| 898 | (when (null lst2)(return (null lst1))) | |
| 922 | 899 | (unless (or (sort= *cosmos* (car lst1)) |
| 923 | (sort<= (car lst1) (car lst2) so)) | |
| 924 | (return nil)) | |
| 925 | (setq lst1 (cdr lst1)) | |
| 926 | (setq lst2 (cdr lst2)))) | |
| 900 | (sort<= (car lst1) (car lst2) so)) | |
| 901 | (return nil)) | |
| 902 | (setq lst1 (cdr lst1)) | |
| 903 | (setq lst2 (cdr lst2)))) | |
| 927 | 904 | |
| 928 | 905 | |
| 929 | 906 | ;;; SORT-LIST< sort-list1 sort-list2 sort-order |
| 932 | 909 | ;;; |
| 933 | 910 | (defun sort-list< (lst1 lst2 &optional (so *current-sort-order*)) |
| 934 | 911 | (declare (type list lst1 lst2) |
| 935 | (type sort-order so) | |
| 936 | (values (or null t))) | |
| 912 | (type sort-order so) | |
| 913 | (values (or null t))) | |
| 937 | 914 | (loop (when (null lst1)(return (null lst2))) |
| 938 | (when (null lst2)(return (null lst1))) | |
| 939 | (unless (sort< (car lst1) (car lst2) so) | |
| 940 | (return nil)) | |
| 941 | (setq lst1 (cdr lst1)) | |
| 942 | (setq lst2 (cdr lst2)))) | |
| 915 | (when (null lst2)(return (null lst1))) | |
| 916 | (unless (sort< (car lst1) (car lst2) so) | |
| 917 | (return nil)) | |
| 918 | (setq lst1 (cdr lst1)) | |
| 919 | (setq lst2 (cdr lst2)))) | |
| 943 | 920 | |
| 944 | 921 | ;;; ******************** |
| 945 | 922 | ;;; SORT-ORDER UTILITIES______________ |
| 951 | 928 | ;;; |
| 952 | 929 | (defun add-sort-to-order (sort &optional (sort-order *current-sort-order*)) |
| 953 | 930 | (declare (type sort* sort) |
| 954 | (type sort-order sort-order) | |
| 955 | (values t)) | |
| 931 | (type sort-order sort-order) | |
| 932 | (values t)) | |
| 956 | 933 | (let ((ent (get-sort-relation sort sort-order))) |
| 957 | 934 | (unless ent |
| 958 | 935 | (add-relation-to-order (make-sort-relation sort nil nil) sort-order)))) |
| 961 | 938 | ;;; adds the sort-relation to sort-order. |
| 962 | 939 | ;;; |
| 963 | 940 | (defun gather-connected-relations-from-order (relation |
| 964 | &optional | |
| 965 | (sort-order *current-sort-order*)) | |
| 941 | &optional | |
| 942 | (sort-order *current-sort-order*)) | |
| 966 | 943 | (declare (type list relation) |
| 967 | (type sort-order sort-order) | |
| 968 | (values list)) | |
| 944 | (type sort-order sort-order) | |
| 945 | (values list)) | |
| 969 | 946 | (macrolet ((pushnew-relation (__?rel __?res) |
| 970 | ` (pushnew ,__?rel ,__?res :test #'eq))) | |
| 947 | ` (pushnew ,__?rel ,__?res :test #'eq))) | |
| 971 | 948 | (let ((res nil) |
| 972 | (s (sort-relation-sort relation)) | |
| 973 | (subs (_subsorts relation)) | |
| 974 | (sups (_supersorts relation))) | |
| 949 | (s (sort-relation-sort relation)) | |
| 950 | (subs (_subsorts relation)) | |
| 951 | (sups (_supersorts relation))) | |
| 975 | 952 | (pushnew-relation (get-sort-relation s sort-order) res) |
| 976 | 953 | (dolist (ls subs) |
| 977 | (pushnew-relation (get-sort-relation ls sort-order) res)) | |
| 954 | (pushnew-relation (get-sort-relation ls sort-order) res)) | |
| 978 | 955 | (dolist (gs sups) |
| 979 | (pushnew-relation (get-sort-relation gs sort-order) res)) | |
| 956 | (pushnew-relation (get-sort-relation gs sort-order) res)) | |
| 980 | 957 | res))) |
| 981 | 958 | |
| 982 | 959 | (defun add-relation-to-order (sort-relation |
| 983 | &optional (sort-order *current-sort-order*)) | |
| 960 | &optional (sort-order *current-sort-order*)) | |
| 984 | 961 | (declare (type list sort-relation) |
| 985 | (type sort-order sort-order) | |
| 986 | (values sort-order)) | |
| 962 | (type sort-order sort-order) | |
| 963 | (values sort-order)) | |
| 987 | 964 | (let* ((sort (sort-relation-sort sort-relation)) |
| 988 | (subs (_subsorts sort-relation)) | |
| 989 | (supers (_supersorts sort-relation))) | |
| 965 | (subs (_subsorts sort-relation)) | |
| 966 | (supers (_supersorts sort-relation))) | |
| 990 | 967 | (declare (type sort* sort) |
| 991 | (type list subs supers)) | |
| 968 | (type list subs supers)) | |
| 992 | 969 | (when (or (sort= sort *universal-sort*) (sort= sort *bottom-sort*) |
| 993 | (sort= sort *huniversal-sort*) (sort= sort *hbottom-sort*) | |
| 994 | (sort= sort *cosmos*)) | |
| 970 | (sort= sort *huniversal-sort*) (sort= sort *hbottom-sort*) | |
| 971 | (sort= sort *cosmos*)) | |
| 995 | 972 | (return-from add-relation-to-order sort-order)) |
| 996 | 973 | ;; |
| 997 | 974 | (macrolet ((ls-union (_s _ls) |
| 998 | ` (let ((..sl (get-sort-relation ,_s sort-order))) | |
| 999 | (pushnew ,_ls (_subsorts ..sl) :test #'eq))) | |
| 1000 | (gs-union (_s _gs) | |
| 1001 | ` (let ((..sl (get-sort-relation ,_s sort-order))) | |
| 1002 | (pushnew ,_gs (_supersorts ..sl) :test #'eq)))) | |
| 975 | ` (let ((..sl (get-sort-relation ,_s sort-order))) | |
| 976 | (pushnew ,_ls (_subsorts ..sl) :test #'eq))) | |
| 977 | (gs-union (_s _gs) | |
| 978 | ` (let ((..sl (get-sort-relation ,_s sort-order))) | |
| 979 | (pushnew ,_gs (_supersorts ..sl) :test #'eq)))) | |
| 1003 | 980 | ;; merge new realtion |
| 1004 | 981 | (let ((o-sort-rel (get-sort-relation sort sort-order))) |
| 1005 | (declare (type list o-sort-rel)) | |
| 1006 | (if o-sort-rel | |
| 1007 | (progn | |
| 1008 | (setf (_subsorts o-sort-rel) | |
| 1009 | (union subs (_subsorts o-sort-rel) :test #'eq)) | |
| 1010 | (setf (_supersorts o-sort-rel) | |
| 1011 | (union supers (_supersorts o-sort-rel) :test #'eq))) | |
| 1012 | (progn | |
| 1013 | (setf (get-sort-relation sort sort-order) sort-relation) | |
| 1014 | (setf o-sort-rel sort-relation | |
| 1015 | subs (_subsorts sort-relation) | |
| 1016 | supers (_supersorts sort-relation))))) | |
| 982 | (declare (type list o-sort-rel)) | |
| 983 | (if o-sort-rel | |
| 984 | (progn | |
| 985 | (setf (_subsorts o-sort-rel) | |
| 986 | (union subs (_subsorts o-sort-rel) :test #'eq)) | |
| 987 | (setf (_supersorts o-sort-rel) | |
| 988 | (union supers (_supersorts o-sort-rel) :test #'eq))) | |
| 989 | (progn | |
| 990 | (setf (get-sort-relation sort sort-order) sort-relation) | |
| 991 | (setf o-sort-rel sort-relation | |
| 992 | subs (_subsorts sort-relation) | |
| 993 | supers (_supersorts sort-relation))))) | |
| 1017 | 994 | ;; we must gather relations which can be affected by new relation, |
| 1018 | 995 | ;; then compute transitive relations among them. |
| 1019 | 996 | (let ((rels (gather-connected-relations-from-order sort-relation sort-order))) |
| 1020 | (declare (type list rels)) | |
| 1021 | (dolist (sl rels) | |
| 1022 | (let ((nsubs (_subsorts sl)) | |
| 1023 | (nsups (_supersorts sl))) | |
| 1024 | (declare (type list nsubs nsups)) | |
| 1025 | (dolist (s1 nsubs) | |
| 1026 | (dolist (s2 nsups) | |
| 1027 | (ls-union s2 s1) | |
| 1028 | (gs-union s1 s2)))))) | |
| 997 | (declare (type list rels)) | |
| 998 | (dolist (sl rels) | |
| 999 | (let ((nsubs (_subsorts sl)) | |
| 1000 | (nsups (_supersorts sl))) | |
| 1001 | (declare (type list nsubs nsups)) | |
| 1002 | (dolist (s1 nsubs) | |
| 1003 | (dolist (s2 nsups) | |
| 1004 | (ls-union s2 s1) | |
| 1005 | (gs-union s1 s2)))))) | |
| 1029 | 1006 | sort-order))) |
| 1030 | 1007 | |
| 1031 | 1008 | ;;; MAX-MINORANTS sort-set sort-order |
| 1034 | 1011 | ;;; |
| 1035 | 1012 | (defun max-minorants (sort-set order) |
| 1036 | 1013 | (declare (type sort-order order) |
| 1037 | (type list sort-set) | |
| 1038 | (values list)) | |
| 1014 | (type list sort-set) | |
| 1015 | (values list)) | |
| 1039 | 1016 | (labels ((inter-lower (set) |
| 1040 | (declare (type list set) | |
| 1041 | (values list)) | |
| 1042 | ;; compute the set of lower bounds of a given set of sorts. | |
| 1043 | ;; If this set is empty returns nil. | |
| 1044 | (if (cdr set) | |
| 1045 | (intersection (sub-or-equal-sorts (car set) order) | |
| 1046 | (inter-lower (cdr set)) | |
| 1047 | :test #'sort=*) | |
| 1048 | (if set | |
| 1049 | (sub-or-equal-sorts (car set) order) | |
| 1050 | nil)))) | |
| 1017 | (declare (type list set) | |
| 1018 | (values list)) | |
| 1019 | ;; compute the set of lower bounds of a given set of sorts. | |
| 1020 | ;; If this set is empty returns nil. | |
| 1021 | (if (cdr set) | |
| 1022 | (intersection (sub-or-equal-sorts (car set) order) | |
| 1023 | (inter-lower (cdr set)) | |
| 1024 | :test #'sort=*) | |
| 1025 | (if set | |
| 1026 | (sub-or-equal-sorts (car set) order) | |
| 1027 | nil)))) | |
| 1051 | 1028 | (let ((max-min nil) |
| 1052 | (lower-bounds (inter-lower sort-set))) | |
| 1029 | (lower-bounds (inter-lower sort-set))) | |
| 1053 | 1030 | (declare (type list max-min lower-bounds)) |
| 1054 | 1031 | (dolist (s lower-bounds max-min) |
| 1055 | (unless (intersection (supersorts s order) lower-bounds :test #'eq) | |
| 1056 | (setq max-min (adjoin s max-min :test #'sort=*))))))) | |
| 1032 | (unless (intersection (supersorts s order) lower-bounds :test #'eq) | |
| 1033 | (setq max-min (adjoin s max-min :test #'sort=*))))))) | |
| 1057 | 1034 | |
| 1058 | 1035 | ;;; MAXIMAL-SORTS sorts order |
| 1059 | 1036 | ;;; Finds all the sorts in a list which are greater than all other comparable |
| 1061 | 1038 | ;;; |
| 1062 | 1039 | (defun maximal-sorts (sorts order) |
| 1063 | 1040 | (declare (type list sorts) |
| 1064 | (type sort-order order) | |
| 1065 | (values list)) | |
| 1041 | (type sort-order order) | |
| 1042 | (values list)) | |
| 1066 | 1043 | (let ((maximal nil)) |
| 1067 | 1044 | (dolist (s sorts maximal) |
| 1068 | 1045 | (unless (intersection (supersorts s order) sorts :test #'eq) |
| 1069 | (pushnew s maximal :test #'eq))))) | |
| 1046 | (pushnew s maximal :test #'eq))))) | |
| 1070 | 1047 | |
| 1071 | 1048 | (defun maximal-sorts-no-error (sorts order) ; version avoiding error sorts. |
| 1072 | 1049 | (declare (type list sorts) |
| 1073 | (type sort-order order) | |
| 1074 | (values list)) | |
| 1050 | (type sort-order order) | |
| 1051 | (values list)) | |
| 1075 | 1052 | (let ((maximal nil)) |
| 1076 | 1053 | (dolist (s sorts maximal) |
| 1077 | 1054 | (unless (intersection (supersorts-no-err s order) sorts :test #'eq) |
| 1078 | (pushnew s maximal :test #'eq))))) | |
| 1055 | (pushnew s maximal :test #'eq))))) | |
| 1079 | 1056 | |
| 1080 | 1057 | ;;; MINIMAL-SORTS sorts order |
| 1081 | 1058 | ;;; Finds all the sorts in a list which are lesser than all other comparable |
| 1083 | 1060 | ;;; |
| 1084 | 1061 | (defun minimal-sorts (sorts order) |
| 1085 | 1062 | (declare (type list sorts) |
| 1086 | (type sort-order order) | |
| 1087 | (values list)) | |
| 1063 | (type sort-order order) | |
| 1064 | (values list)) | |
| 1088 | 1065 | (let ((minimal nil)) |
| 1089 | 1066 | (declare (type list minimal)) |
| 1090 | 1067 | (dolist (s sorts minimal) |
| 1091 | 1068 | (unless (intersection (subsorts s order) sorts :test #'eq) |
| 1092 | (pushnew s minimal :test #'eq))))) | |
| 1069 | (pushnew s minimal :test #'eq))))) | |
| 1093 | 1070 | |
| 1094 | 1071 | ;;; MEET-OF-SORTS sort1 sort2 order |
| 1095 | 1072 | ;;; Finds the list of sorts which are maximal but less than or equal to |
| 1099 | 1076 | ;;; |
| 1100 | 1077 | (defun meet-of-sorts (sort1 sort2 &optional (sort-order *current-sort-order*)) |
| 1101 | 1078 | (declare (type sort* sort1 sort2) |
| 1102 | (type sort-order sort-order)) | |
| 1079 | (type sort-order sort-order)) | |
| 1103 | 1080 | (cond ((sort<= sort1 sort2) (list sort1)) |
| 1104 | ((sort< sort2 sort1 sort-order) (list sort2)) | |
| 1105 | (t (maximal-sorts (intersection (subsorts sort1) (subsorts sort2)) | |
| 1106 | sort-order)))) | |
| 1081 | ((sort< sort2 sort1 sort-order) (list sort2)) | |
| 1082 | (t (maximal-sorts (intersection (subsorts sort1) (subsorts sort2)) | |
| 1083 | sort-order)))) | |
| 1107 | 1084 | |
| 1108 | 1085 | ;;; MERGET-SORT-RELATIONS sort-relations1 sort-relations2 |
| 1109 | 1086 | ;;; *NOTE* sort-relations2 is destructively modified. |
| 1110 | 1087 | ;;; |
| 1111 | 1088 | (defun merge-sort-relations (sl1 sl2) |
| 1112 | 1089 | (declare (type list sl1 sl2) |
| 1113 | (values list)) | |
| 1090 | (values list)) | |
| 1114 | 1091 | (unless sl1 (return-from merge-sort-relations sl2)) |
| 1115 | 1092 | (dolist (sort-relation sl1) |
| 1116 | 1093 | (let ((xsort-rel (assq (sort-relation-sort sort-relation) sl2))) |
| 1117 | 1094 | (if xsort-rel |
| 1118 | (progn | |
| 1119 | (setf (_subsorts xsort-rel) | |
| 1120 | (union (_subsorts sort-relation) | |
| 1121 | (_subsorts xsort-rel) :test #'eq)) | |
| 1122 | (setf (_supersorts xsort-rel) | |
| 1123 | (union (_supersorts sort-relation) | |
| 1124 | (_supersorts xsort-rel) :test #'eq))) | |
| 1125 | (push sort-relation sl2)))) | |
| 1095 | (progn | |
| 1096 | (setf (_subsorts xsort-rel) | |
| 1097 | (union (_subsorts sort-relation) | |
| 1098 | (_subsorts xsort-rel) :test #'eq)) | |
| 1099 | (setf (_supersorts xsort-rel) | |
| 1100 | (union (_supersorts sort-relation) | |
| 1101 | (_supersorts xsort-rel) :test #'eq))) | |
| 1102 | (push sort-relation sl2)))) | |
| 1126 | 1103 | sl2) |
| 1127 | 1104 | |
| 1128 | 1105 | ;;; MERGE-SORT-ORDER order1 order2 |
| 1131 | 1108 | ;;; |
| 1132 | 1109 | (defun merge-sort-order (order1 order2) |
| 1133 | 1110 | (declare (type (or null sort-order) order1) |
| 1134 | (type sort-order order2) | |
| 1135 | (values sort-order)) | |
| 1111 | (type sort-order order2) | |
| 1112 | (values sort-order)) | |
| 1136 | 1113 | (unless order1 (return-from merge-sort-order order2)) |
| 1137 | 1114 | (maphash #'(lambda (sort sort-relation) |
| 1138 | (declare (type sort* sort) | |
| 1139 | (type list sort-relation) | |
| 1140 | (values t)) | |
| 1141 | (let ((xsort-rel (get-sort-relation sort order2))) | |
| 1142 | (if xsort-rel | |
| 1143 | (progn | |
| 1144 | (setf (_subsorts xsort-rel) | |
| 1145 | (union (_subsorts sort-relation) | |
| 1146 | (_subsorts xsort-rel) :test #'eq)) | |
| 1147 | (setf (_supersorts xsort-rel) | |
| 1148 | (union (_supersorts sort-relation) | |
| 1149 | (_supersorts xsort-rel) :test #'eq))) | |
| 1150 | (setf (get-sort-relation sort order2) sort-relation)))) | |
| 1151 | order1) | |
| 1115 | (declare (type sort* sort) | |
| 1116 | (type list sort-relation) | |
| 1117 | (values t)) | |
| 1118 | (let ((xsort-rel (get-sort-relation sort order2))) | |
| 1119 | (if xsort-rel | |
| 1120 | (progn | |
| 1121 | (setf (_subsorts xsort-rel) | |
| 1122 | (union (_subsorts sort-relation) | |
| 1123 | (_subsorts xsort-rel) :test #'eq)) | |
| 1124 | (setf (_supersorts xsort-rel) | |
| 1125 | (union (_supersorts sort-relation) | |
| 1126 | (_supersorts xsort-rel) :test #'eq))) | |
| 1127 | (setf (get-sort-relation sort order2) sort-relation)))) | |
| 1128 | order1) | |
| 1152 | 1129 | order2) |
| 1153 | 1130 | |
| 1154 | 1131 | (defun merge-sort-order-no-extra (order1 order2) |
| 1155 | 1132 | (declare (type (or null sort-order) order1) |
| 1156 | (type sort-order order2) | |
| 1157 | (values sort-order)) | |
| 1133 | (type sort-order order2) | |
| 1134 | (values sort-order)) | |
| 1158 | 1135 | (unless order1 (return-from merge-sort-order-no-extra order2)) |
| 1159 | 1136 | (macrolet ((filter-out-ordinal-sorts (___sort-list) |
| 1160 | ` (remove-if #'(lambda (s) (sort-is-for-regularity? s)) | |
| 1161 | ,___sort-list))) | |
| 1137 | ` (remove-if #'(lambda (s) (sort-is-for-regularity? s)) | |
| 1138 | ,___sort-list))) | |
| 1162 | 1139 | (maphash #'(lambda (sort sort-relation) |
| 1163 | (declare (type sort* sort) | |
| 1164 | (type list sort-relation)) | |
| 1165 | (unless (or (and-sort-p sort) (or-sort-p sort)) | |
| 1166 | (let ((xsort-rel (get-sort-relation sort order2))) | |
| 1167 | (declare (type list xsort-rel)) | |
| 1168 | (if xsort-rel | |
| 1169 | (progn | |
| 1170 | (setf (_subsorts xsort-rel) | |
| 1171 | (filter-out-ordinal-sorts | |
| 1172 | (union (_subsorts sort-relation) | |
| 1173 | (_subsorts xsort-rel) :test #'eq))) | |
| 1174 | (setf (_supersorts xsort-rel) | |
| 1175 | (filter-out-ordinal-sorts | |
| 1176 | (union (_supersorts sort-relation) | |
| 1177 | (_supersorts xsort-rel) :test #'eq)))) | |
| 1178 | (setf (get-sort-relation sort order2) sort-relation))))) | |
| 1179 | order1) | |
| 1140 | (declare (type sort* sort) | |
| 1141 | (type list sort-relation)) | |
| 1142 | (unless (or (and-sort-p sort) (or-sort-p sort)) | |
| 1143 | (let ((xsort-rel (get-sort-relation sort order2))) | |
| 1144 | (declare (type list xsort-rel)) | |
| 1145 | (if xsort-rel | |
| 1146 | (progn | |
| 1147 | (setf (_subsorts xsort-rel) | |
| 1148 | (filter-out-ordinal-sorts | |
| 1149 | (union (_subsorts sort-relation) | |
| 1150 | (_subsorts xsort-rel) :test #'eq))) | |
| 1151 | (setf (_supersorts xsort-rel) | |
| 1152 | (filter-out-ordinal-sorts | |
| 1153 | (union (_supersorts sort-relation) | |
| 1154 | (_supersorts xsort-rel) :test #'eq)))) | |
| 1155 | (setf (get-sort-relation sort order2) sort-relation))))) | |
| 1156 | order1) | |
| 1180 | 1157 | order2)) |
| 1181 | 1158 | |
| 1182 | 1159 | ;;; IS-IN-SAME-CONNECTED-COMPONENT : sort1 sort2 sort-order -> Bool |
| 1183 | ;;; check if sort1 and sort2 is in same sort hierarchy | |
| 1160 | ;;; check if sort1 and sort2 is in same sort hierarchy | |
| 1184 | 1161 | ;;; *NOTE* : assume error sorts are already genrated. |
| 1185 | 1162 | ;;; |
| 1186 | 1163 | (defun is-in-same-connected-component (s1 s2 sort-order) |
| 1187 | 1164 | (declare (type sort* s1 s2) |
| 1188 | (type sort-order sort-order) | |
| 1189 | (values (or null t))) | |
| 1165 | (type sort-order sort-order) | |
| 1166 | (values (or null t))) | |
| 1190 | 1167 | (or (sort= s1 s2) |
| 1191 | 1168 | (if (or (sort= s1 *cosmos*) (sort= s2 *cosmos*)) |
| 1192 | t | |
| 1193 | (and (eq (sort-is-hidden s1) (sort-is-hidden s2)) | |
| 1194 | (or (if (sort-is-hidden s1) | |
| 1195 | (or (sort= *huniversal-sort* s1) | |
| 1196 | (sort= *huniversal-sort* s2) | |
| 1197 | (sort= *hbottom-sort* s1) | |
| 1198 | (sort= *hbottom-sort* s2)) | |
| 1199 | (or (sort= *universal-sort* s1) | |
| 1200 | (sort= *universal-sort* s2) | |
| 1201 | (sort= *bottom-sort* s1) | |
| 1202 | (sort= *bottom-sort* s2))) | |
| 1203 | (if (err-sort-p s1) | |
| 1204 | (sort= s1 (the-err-sort s2 sort-order)) | |
| 1205 | (if (err-sort-p s2) | |
| 1206 | (sort= (the-err-sort s1 sort-order) s2) | |
| 1207 | (sort= (the-err-sort s1 sort-order) | |
| 1208 | (the-err-sort s2 sort-order))))))))) | |
| 1169 | t | |
| 1170 | (and (eq (sort-is-hidden s1) (sort-is-hidden s2)) | |
| 1171 | (or (if (sort-is-hidden s1) | |
| 1172 | (or (sort= *huniversal-sort* s1) | |
| 1173 | (sort= *huniversal-sort* s2) | |
| 1174 | (sort= *hbottom-sort* s1) | |
| 1175 | (sort= *hbottom-sort* s2)) | |
| 1176 | (or (sort= *universal-sort* s1) | |
| 1177 | (sort= *universal-sort* s2) | |
| 1178 | (sort= *bottom-sort* s1) | |
| 1179 | (sort= *bottom-sort* s2))) | |
| 1180 | (if (err-sort-p s1) | |
| 1181 | (sort= s1 (the-err-sort s2 sort-order)) | |
| 1182 | (if (err-sort-p s2) | |
| 1183 | (sort= (the-err-sort s1 sort-order) s2) | |
| 1184 | (sort= (the-err-sort s1 sort-order) | |
| 1185 | (the-err-sort s2 sort-order))))))))) | |
| 1209 | 1186 | |
| 1210 | 1187 | ;;; COMPONENT-TOP : sort sort-order -> sort |
| 1211 | 1188 | ;;; returns the greatest sorts of given sort |
| 1212 | 1189 | ;;; |
| 1213 | 1190 | (defun component-top (sort sort-order) |
| 1214 | 1191 | (declare (type sort* sort) |
| 1215 | (type sort-order sort-order) | |
| 1216 | (values list)) | |
| 1192 | (type sort-order sort-order) | |
| 1193 | (values list)) | |
| 1217 | 1194 | (maximal-sorts (supersorts-no-err sort sort-order) sort-order)) |
| 1218 | 1195 | |
| 1219 | 1196 | ;;; IS-IN-SAME-CONNECTED-COMPONENT* : Sort Sort SortOrder -> Bool |
| 1222 | 1199 | ;;; |
| 1223 | 1200 | (defun is-in-same-connected-component* (s1 s2 so) |
| 1224 | 1201 | (declare (type sort* s1 s2) |
| 1225 | (type sort-order so) | |
| 1226 | (values (or null t))) | |
| 1202 | (type sort-order so) | |
| 1203 | (values (or null t))) | |
| 1227 | 1204 | (or (eq s1 s2) |
| 1228 | 1205 | (if (or (eq s1 *cosmos*) (eq s2 *cosmos*)) |
| 1229 | t | |
| 1230 | (and (eq (sort-is-hidden s1) (sort-is-hidden s2)) | |
| 1231 | (cond ((err-sort-p s1) | |
| 1232 | (if (err-sort-p s2) | |
| 1233 | nil | |
| 1234 | (let ((lowers (err-sort-lowers s1))) | |
| 1235 | (intersection lowers | |
| 1236 | (sub-or-equal-sorts s2 so))))) | |
| 1237 | ((err-sort-p s2) | |
| 1238 | (let ((lowers (err-sort-lowers s2))) | |
| 1239 | (intersection lowers | |
| 1240 | (sub-or-equal-sorts s1 so)))) | |
| 1241 | (t (or (if (sort-is-hidden s1) | |
| 1242 | (or (sort= *huniversal-sort* s1) | |
| 1243 | (sort= *huniversal-sort* s2) | |
| 1244 | (sort= *hbottom-sort* s1) | |
| 1245 | (sort= *hbottom-sort* s2)) | |
| 1246 | (or (sort= *universal-sort* s1) | |
| 1247 | (sort= *universal-sort* s2) | |
| 1248 | (sort= *bottom-sort* s1) | |
| 1249 | (sort= *bottom-sort* s2))) | |
| 1250 | (sort<= s1 s2 so) | |
| 1251 | (sort<= s2 s1 so) | |
| 1252 | (have-common-subsort s1 s2 so) | |
| 1253 | (let ((t1 (component-top s1 so))) | |
| 1254 | (and t1 (sort-set-equal t1 | |
| 1255 | (component-top s2 so))))))))))) | |
| 1206 | t | |
| 1207 | (and (eq (sort-is-hidden s1) (sort-is-hidden s2)) | |
| 1208 | (cond ((err-sort-p s1) | |
| 1209 | (if (err-sort-p s2) | |
| 1210 | nil | |
| 1211 | (let ((lowers (err-sort-lowers s1))) | |
| 1212 | (intersection lowers | |
| 1213 | (sub-or-equal-sorts s2 so))))) | |
| 1214 | ((err-sort-p s2) | |
| 1215 | (let ((lowers (err-sort-lowers s2))) | |
| 1216 | (intersection lowers | |
| 1217 | (sub-or-equal-sorts s1 so)))) | |
| 1218 | (t (or (if (sort-is-hidden s1) | |
| 1219 | (or (sort= *huniversal-sort* s1) | |
| 1220 | (sort= *huniversal-sort* s2) | |
| 1221 | (sort= *hbottom-sort* s1) | |
| 1222 | (sort= *hbottom-sort* s2)) | |
| 1223 | (or (sort= *universal-sort* s1) | |
| 1224 | (sort= *universal-sort* s2) | |
| 1225 | (sort= *bottom-sort* s1) | |
| 1226 | (sort= *bottom-sort* s2))) | |
| 1227 | (sort<= s1 s2 so) | |
| 1228 | (sort<= s2 s1 so) | |
| 1229 | (have-common-subsort s1 s2 so) | |
| 1230 | (let ((t1 (component-top s1 so))) | |
| 1231 | (and t1 (sort-set-equal t1 | |
| 1232 | (component-top s2 so))))))))))) | |
| 1256 | 1233 | |
| 1257 | 1234 | ;;; HAVE-COMMON-SUBSORT : Sort Sort SortOrder -> Bool |
| 1258 | 1235 | ;;; |
| 1259 | 1236 | (defun have-common-subsort (s1 s2 so) |
| 1260 | 1237 | (declare (type sort* s1 s2) |
| 1261 | (type sort-order so) | |
| 1262 | (values (or null t))) | |
| 1238 | (type sort-order so) | |
| 1239 | (values (or null t))) | |
| 1263 | 1240 | (let ((ss1 (subsorts s1 so)) |
| 1264 | (ss2 (subsorts s2 so))) | |
| 1241 | (ss2 (subsorts s2 so))) | |
| 1265 | 1242 | (dolist (s ss1 nil) |
| 1266 | 1243 | (declare (type sort* s)) |
| 1267 | 1244 | (when (memq s ss2) (return t))))) |
| 1270 | 1247 | ;;; |
| 1271 | 1248 | (defun all-sorts-in-order (&optional (sort-order *current-sort-order*)) |
| 1272 | 1249 | (declare (type sort-order sort-order) |
| 1273 | (values list)) | |
| 1250 | (values list)) | |
| 1274 | 1251 | (let ((res nil)) |
| 1275 | 1252 | (maphash #'(lambda (sort relation) |
| 1276 | (declare (ignore relation)) | |
| 1277 | (push sort res)) | |
| 1278 | sort-order) | |
| 1253 | (declare (ignore relation)) | |
| 1254 | (push sort res)) | |
| 1255 | sort-order) | |
| 1279 | 1256 | res)) |
| 1280 | 1257 | |
| 1281 | 1258 | ;;; TOP-COMPONENTS sort-order |
| 1282 | 1259 | ;;; |
| 1283 | 1260 | (defun top-components (&optional (sort-order *current-sort-order*)) |
| 1284 | 1261 | (declare (type sort-order sort-order) |
| 1285 | (values list)) | |
| 1262 | (values list)) | |
| 1286 | 1263 | (maximal-sorts (let ((res nil)) |
| 1287 | (maphash #'(lambda (sort relation) | |
| 1288 | (declare (ignore relation)) | |
| 1289 | (push sort res)) | |
| 1290 | sort-order) | |
| 1291 | res) | |
| 1292 | sort-order)) | |
| 1264 | (maphash #'(lambda (sort relation) | |
| 1265 | (declare (ignore relation)) | |
| 1266 | (push sort res)) | |
| 1267 | sort-order) | |
| 1268 | res) | |
| 1269 | sort-order)) | |
| 1293 | 1270 | |
| 1294 | 1271 | ;;; BOTTOM-COMPONENTS sort-order |
| 1295 | 1272 | ;;; |
| 1296 | 1273 | (defun bottom-components (&optional (sort-order *current-sort-order*)) |
| 1297 | 1274 | (declare (type sort-order sort-order) |
| 1298 | (values list)) | |
| 1275 | (values list)) | |
| 1299 | 1276 | (minimal-sorts (let ((res nil)) |
| 1300 | (maphash #'(lambda (sort relation) | |
| 1301 | (declare (ignore relation)) | |
| 1302 | (push sort res)) | |
| 1303 | sort-order) | |
| 1304 | res) | |
| 1305 | sort-order)) | |
| 1277 | (maphash #'(lambda (sort relation) | |
| 1278 | (declare (ignore relation)) | |
| 1279 | (push sort res)) | |
| 1280 | sort-order) | |
| 1281 | res) | |
| 1282 | sort-order)) | |
| 1306 | 1283 | |
| 1307 | 1284 | ;;; DIRECT-SUBSORTS sort sort-order |
| 1308 | 1285 | ;;; returns the list of sorts which are direct subsorts |
| 1309 | 1286 | ;;; |
| 1310 | 1287 | (defun direct-subsorts (sort &optional (sort-order *current-sort-order*)) |
| 1311 | 1288 | (declare (type sort* sort) |
| 1312 | (type sort-order sort-order) | |
| 1313 | (values list)) | |
| 1289 | (type sort-order sort-order) | |
| 1290 | (values list)) | |
| 1314 | 1291 | (maximal-sorts (subsorts sort sort-order) sort-order)) |
| 1315 | 1292 | |
| 1316 | 1293 | ;;; DIRECT-SUPERSORTS sort sort-order |
| 1317 | 1294 | ;;; |
| 1318 | 1295 | (defun direct-supersorts (sort &optional (sort-order *current-sort-order*)) |
| 1319 | 1296 | (declare (type sort*) |
| 1320 | (type sort-order sort-order) | |
| 1321 | (values list)) | |
| 1297 | (type sort-order sort-order) | |
| 1298 | (values list)) | |
| 1322 | 1299 | (minimal-sorts (supersorts sort sort-order) sort-order)) |
| 1323 | 1300 | |
| 1324 | 1301 | ;;; DIRECT-SUPERSORTS-NO-ERR |
| 1325 | 1302 | ;;; |
| 1326 | 1303 | (defun direct-supersorts-no-err (sort &optional (sort-order *current-sort-order*)) |
| 1327 | 1304 | (declare (type sort* sort) |
| 1328 | (type sort-order sort-order) | |
| 1329 | (values list)) | |
| 1305 | (type sort-order sort-order) | |
| 1306 | (values list)) | |
| 1330 | 1307 | (minimal-sorts (supersorts-no-err sort sort-order) sort-order)) |
| 1331 | 1308 | |
| 1332 | 1309 | #|| |
| 1336 | 1313 | (defun delete-sort-from-order (sort sort-order) |
| 1337 | 1314 | (remhash sort sort-order) |
| 1338 | 1315 | (maphash #'(lambda (ss sort-rel) |
| 1339 | (declare (ignore ss)) | |
| 1340 | (setf (_subsorts sort-rel) | |
| 1341 | (delete sort (_subsorts sort-rel) :test #'eq)) | |
| 1342 | (setf (_supersorts sort-rel) | |
| 1343 | (delete sort (_supersorts sort-rel) :test #'eq))) | |
| 1344 | sort-order) | |
| 1316 | (declare (ignore ss)) | |
| 1317 | (setf (_subsorts sort-rel) | |
| 1318 | (delete sort (_subsorts sort-rel) :test #'eq)) | |
| 1319 | (setf (_supersorts sort-rel) | |
| 1320 | (delete sort (_supersorts sort-rel) :test #'eq))) | |
| 1321 | sort-order) | |
| 1345 | 1322 | (update-sort-order sort-order) |
| 1346 | 1323 | sort-order) |
| 1347 | 1324 | ||# |
| 1352 | 1329 | #|| |
| 1353 | 1330 | (defun sort-order-transitive-closure (previous-order new-order) |
| 1354 | 1331 | (flet ((ls-union (order s ls) |
| 1355 | ;; make the union of the sorts lower than "s" with ls. | |
| 1356 | (let ((sl (get-sort-relation s order))) | |
| 1357 | (setf (_subsorts sl) | |
| 1358 | (union (_subsorts sl) ls :test #'eq)))) | |
| 1359 | (gs-union (order s gs) | |
| 1360 | ;; make the union of the sorts greater than "s" with gs. | |
| 1361 | (let ((sl (get-sort-relation s order))) | |
| 1362 | (setf (_supersorts sl) | |
| 1363 | (union (_supersorts sl) gs :test #'eq))))) | |
| 1332 | ;; make the union of the sorts lower than "s" with ls. | |
| 1333 | (let ((sl (get-sort-relation s order))) | |
| 1334 | (setf (_subsorts sl) | |
| 1335 | (union (_subsorts sl) ls :test #'eq)))) | |
| 1336 | (gs-union (order s gs) | |
| 1337 | ;; make the union of the sorts greater than "s" with gs. | |
| 1338 | (let ((sl (get-sort-relation s order))) | |
| 1339 | (setf (_supersorts sl) | |
| 1340 | (union (_supersorts sl) gs :test #'eq))))) | |
| 1364 | 1341 | (let ((closure (merge-sort-order previous-order new-order))) |
| 1365 | 1342 | (declare (type sort-order closure)) |
| 1366 | 1343 | (maphash #'(lambda (sort sort-rel) |
| 1367 | (declare (ignore sort)) | |
| 1368 | (let ((ls (_subsorts sort-rel)) | |
| 1369 | (gs (_supersorts sort-rel))) | |
| 1370 | (dolist (s1 ls) | |
| 1371 | (dolist (s2 gs) | |
| 1372 | (declare (type sort* s2)) | |
| 1373 | (ls-union closure s2 (list s1)) | |
| 1374 | (gs-union closure s1 (list s2)))))) | |
| 1375 | closure) | |
| 1344 | (declare (ignore sort)) | |
| 1345 | (let ((ls (_subsorts sort-rel)) | |
| 1346 | (gs (_supersorts sort-rel))) | |
| 1347 | (dolist (s1 ls) | |
| 1348 | (dolist (s2 gs) | |
| 1349 | (declare (type sort* s2)) | |
| 1350 | (ls-union closure s2 (list s1)) | |
| 1351 | (gs-union closure s1 (list s2)))))) | |
| 1352 | closure) | |
| 1376 | 1353 | ;; generates erro sorts. |
| 1377 | 1354 | (generate-err-sorts closure) |
| 1378 | 1355 | closure))) |
| 1381 | 1358 | |
| 1382 | 1359 | (defun sort-relations-transitive-closure (sl1 sl2) |
| 1383 | 1360 | (declare (type list sl1 sl2) |
| 1384 | (values list)) | |
| 1361 | (values list)) | |
| 1385 | 1362 | (flet ((ls-union (relations s ls) |
| 1386 | (declare (type list relations ls) | |
| 1387 | (type sort* s) | |
| 1388 | (values list)) | |
| 1389 | ;; make the union of the sorts lower than "s" with ls. | |
| 1390 | (let ((sl (assq s relations))) | |
| 1391 | (declare (type list sl)) | |
| 1392 | (unless sl (break "Panic no sort relation(ls)!")) | |
| 1393 | (setf (_subsorts sl) | |
| 1394 | (union (_subsorts sl) ls :test #'eq)))) | |
| 1395 | (gs-union (relations s gs) | |
| 1396 | (declare (type list relations gs) | |
| 1397 | (type sort* s) | |
| 1398 | (values list)) | |
| 1399 | ;; make the union of the sorts greater than "s" with gs. | |
| 1400 | (let ((sl (assq s relations))) | |
| 1401 | (declare (type list sl)) | |
| 1402 | (unless sl (break "Panic no sort relation(gs)!")) | |
| 1403 | (setf (_supersorts sl) | |
| 1404 | (union (_supersorts sl) gs :test #'eq))))) | |
| 1363 | (declare (type list relations ls) | |
| 1364 | (type sort* s) | |
| 1365 | (values list)) | |
| 1366 | ;; make the union of the sorts lower than "s" with ls. | |
| 1367 | (let ((sl (assq s relations))) | |
| 1368 | (declare (type list sl)) | |
| 1369 | (unless sl (break "Panic no sort relation(ls)!")) | |
| 1370 | (setf (_subsorts sl) | |
| 1371 | (union (_subsorts sl) ls :test #'eq)))) | |
| 1372 | (gs-union (relations s gs) | |
| 1373 | (declare (type list relations gs) | |
| 1374 | (type sort* s) | |
| 1375 | (values list)) | |
| 1376 | ;; make the union of the sorts greater than "s" with gs. | |
| 1377 | (let ((sl (assq s relations))) | |
| 1378 | (declare (type list sl)) | |
| 1379 | (unless sl (break "Panic no sort relation(gs)!")) | |
| 1380 | (setf (_supersorts sl) | |
| 1381 | (union (_supersorts sl) gs :test #'eq))))) | |
| 1405 | 1382 | (let ((p-closure (merge-sort-relations sl1 sl2))) |
| 1406 | 1383 | (declare (type list p-closure)) |
| 1407 | 1384 | (dolist (sort-rel p-closure) |
| 1408 | (let ((ls (_subsorts sort-rel)) | |
| 1409 | (gs (_supersorts sort-rel))) | |
| 1410 | (declare (type list ls gs)) | |
| 1411 | (dolist (s1 ls) | |
| 1412 | (declare (type sort* s1)) | |
| 1413 | (dolist (s2 gs) | |
| 1414 | (declare (type sort* s2)) | |
| 1415 | (ls-union p-closure s2 (list s1)) | |
| 1416 | (gs-union p-closure s1 (list s2)))))) | |
| 1385 | (let ((ls (_subsorts sort-rel)) | |
| 1386 | (gs (_supersorts sort-rel))) | |
| 1387 | (declare (type list ls gs)) | |
| 1388 | (dolist (s1 ls) | |
| 1389 | (declare (type sort* s1)) | |
| 1390 | (dolist (s2 gs) | |
| 1391 | (declare (type sort* s2)) | |
| 1392 | (ls-union p-closure s2 (list s1)) | |
| 1393 | (gs-union p-closure s1 (list s2)))))) | |
| 1417 | 1394 | p-closure))) |
| 1418 | 1395 | |
| 1419 | 1396 | (defun sort-relations-transitive-closure1 (sl) |
| 1420 | 1397 | (declare (type list sl) |
| 1421 | (values list)) | |
| 1398 | (values list)) | |
| 1422 | 1399 | (sort-relations-transitive-closure nil sl)) |
| 1423 | 1400 | |
| 1424 | 1401 | ;;; CHECK-CYCLIC-SORT-ORDER sort-order |
| 1425 | 1402 | ;;; |
| 1426 | 1403 | (defun check-cyclic-sort-order (sort-order) |
| 1427 | 1404 | (declare (type sort-order sort-order) |
| 1428 | (values t)) | |
| 1405 | (values t)) | |
| 1429 | 1406 | (maphash #'(lambda (ss sort-relation) |
| 1430 | (when (member ss (_subsorts sort-relation) :test #'eq) | |
| 1431 | (with-output-chaos-warning () | |
| 1432 | (princ "cycle in sort order structure : ") | |
| 1433 | (princ (string (sort-id ss))) | |
| 1434 | (princ " appears in its lowers.")))) | |
| 1435 | sort-order)) | |
| 1407 | (when (member ss (_subsorts sort-relation) :test #'eq) | |
| 1408 | (with-output-chaos-warning () | |
| 1409 | (princ "cycle in sort order structure : ") | |
| 1410 | (princ (string (sort-id ss))) | |
| 1411 | (princ " appears in its lowers.")))) | |
| 1412 | sort-order)) | |
| 1436 | 1413 | |
| 1437 | 1414 | ;;; ERROR SORT UTILS |
| 1438 | 1415 | |
| 1440 | 1417 | ;;; |
| 1441 | 1418 | (defun clear-err-sorts (sort-order) |
| 1442 | 1419 | (declare (type sort-order sort-order) |
| 1443 | (values t)) | |
| 1420 | (values t)) | |
| 1444 | 1421 | (maphash #'(lambda (s sl) |
| 1445 | (declare (ignore s)) | |
| 1446 | (setf (_err-sort sl) nil)) | |
| 1447 | sort-order) | |
| 1422 | (declare (ignore s)) | |
| 1423 | (setf (_err-sort sl) nil)) | |
| 1424 | sort-order) | |
| 1448 | 1425 | sort-order) |
| 1449 | 1426 | |
| 1450 | 1427 | ;;; GET-KINDS : SortOrder -> LIST[(err-sort subsort-list)] |
| 1451 | 1428 | ;;; |
| 1452 | 1429 | (defun get-kinds (sort-order) |
| 1453 | 1430 | (declare (type sort-order sort-order) |
| 1454 | (values list)) | |
| 1431 | (values list)) | |
| 1455 | 1432 | (let ((res nil)) |
| 1456 | 1433 | (maphash #'(lambda (s sl) |
| 1457 | (declare (type sort* s) | |
| 1458 | (type list sl)) | |
| 1459 | (let ((es (_err-sort sl))) | |
| 1460 | (declare (type (or null err-sort) es)) | |
| 1461 | (when (and es (not (or (eq s *universal-sort*) | |
| 1462 | (eq s *bottom-sort*) | |
| 1463 | (eq s *huniversal-sort*) | |
| 1464 | (eq s *hbottom-sort*) | |
| 1465 | (eq s *cosmos*)))) | |
| 1466 | (let ((pre (assoc es res :test #'eq))) | |
| 1467 | (declare (type list pre)) | |
| 1468 | (if pre | |
| 1469 | (pushnew s (cdr pre) :test #'eq) | |
| 1470 | (push (cons es (list s)) res)))))) | |
| 1471 | sort-order) | |
| 1434 | (declare (type sort* s) | |
| 1435 | (type list sl)) | |
| 1436 | (let ((es (_err-sort sl))) | |
| 1437 | (declare (type (or null err-sort) es)) | |
| 1438 | (when (and es (not (or (eq s *universal-sort*) | |
| 1439 | (eq s *bottom-sort*) | |
| 1440 | (eq s *huniversal-sort*) | |
| 1441 | (eq s *hbottom-sort*) | |
| 1442 | (eq s *cosmos*)))) | |
| 1443 | (let ((pre (assoc es res :test #'eq))) | |
| 1444 | (declare (type list pre)) | |
| 1445 | (if pre | |
| 1446 | (pushnew s (cdr pre) :test #'eq) | |
| 1447 | (push (cons es (list s)) res)))))) | |
| 1448 | sort-order) | |
| 1472 | 1449 | res)) |
| 1473 | 1450 | |
| 1474 | 1451 | ;;; GET-ERR-SORTS |
| 1475 | 1452 | ;;; |
| 1476 | 1453 | (defun get-err-sorts (sort-order) |
| 1477 | 1454 | (declare (type sort-order sort-order) |
| 1478 | (values list)) | |
| 1455 | (values list)) | |
| 1479 | 1456 | (let ((res nil)) |
| 1480 | 1457 | (maphash #'(lambda (s sl) |
| 1481 | (declare (ignore s)) | |
| 1482 | (let ((es (_err-sort sl))) | |
| 1483 | (when es (pushnew es res :test #'eq)))) | |
| 1484 | sort-order) | |
| 1458 | (declare (ignore s)) | |
| 1459 | (let ((es (_err-sort sl))) | |
| 1460 | (when es (pushnew es res :test #'eq)))) | |
| 1461 | sort-order) | |
| 1485 | 1462 | res)) |
| 1486 | 1463 | |
| 1487 | 1464 | ;;; GET-FAMILY : ErroSort SortOrder -> List[Sort] |
| 1488 | 1465 | ;;; |
| 1489 | 1466 | (defun get-family (err-sort so) |
| 1490 | 1467 | (declare (type err-sort err-sort) |
| 1491 | (type sort-order so) | |
| 1492 | (values list)) | |
| 1468 | (type sort-order so) | |
| 1469 | (values list)) | |
| 1493 | 1470 | (let ((res nil)) |
| 1494 | 1471 | (maphash #'(lambda (s sl) |
| 1495 | (declare (type sort* s) | |
| 1496 | (type list sl) | |
| 1497 | (values list)) | |
| 1498 | (when (sort= err-sort (_err-sort sl)) | |
| 1499 | (pushnew s res :test #'eq))) | |
| 1500 | so) | |
| 1472 | (declare (type sort* s) | |
| 1473 | (type list sl) | |
| 1474 | (values list)) | |
| 1475 | (when (sort= err-sort (_err-sort sl)) | |
| 1476 | (pushnew s res :test #'eq))) | |
| 1477 | so) | |
| 1501 | 1478 | res)) |
| 1502 | 1479 | |
| 1503 | 1480 | |
| 0 | 0 | ;;;-*- Mode:LISP; Package: Chaos; Base:10; Syntax:Common-lisp -*- |
| 1 | 1 | ;;; |
| 2 | ;;; Copyright (c) 2000-2014, Toshimi Sawada. All rights reserved. | |
| 2 | ;;; Copyright (c) 2000-2015, Toshimi Sawada. All rights reserved. | |
| 3 | 3 | ;;; |
| 4 | 4 | ;;; Redistribution and use in source and binary forms, with or without |
| 5 | 5 | ;;; modification, are permitted provided that the following conditions |
| 27 | 27 | ;;; |
| 28 | 28 | (in-package :chaos) |
| 29 | 29 | #|============================================================================== |
| 30 | System: Chaos | |
| 31 | Module: primitives | |
| 32 | File: bview.lisp | |
| 30 | System: Chaos | |
| 31 | Module: primitives | |
| 32 | File: bview.lisp | |
| 33 | 33 | ==============================================================================|# |
| 34 | 34 | #-:chaos-debug |
| 35 | 35 | (declaim (optimize (speed 3) (safety 0) #-GCL (debug 0))) |
| 50 | 50 | ;;;----------------------------------------------------------------------------- |
| 51 | 51 | #|| |
| 52 | 52 | (defterm view-struct (top-object) |
| 53 | :visible (name) ; view name (string). | |
| 54 | :hidden (src ; source module | |
| 55 | target ; target module | |
| 56 | sort-maps ; mapping of sorts | |
| 57 | op-maps ; mapping of operators | |
| 58 | ) | |
| 53 | :visible (name) ; view name (string). | |
| 54 | :hidden (src ; source module | |
| 55 | target ; target module | |
| 56 | sort-maps ; mapping of sorts | |
| 57 | op-maps ; mapping of operators | |
| 58 | ) | |
| 59 | 59 | :print print-view-internal |
| 60 | 60 | :int-printer print-view-struct-object) |
| 61 | 61 | ||# |
| 62 | 62 | |
| 63 | 63 | #|| |
| 64 | 64 | (defstruct (view-struct (:include top-object (-type 'view-struct)) |
| 65 | (:conc-name "VIEW-STRUCT-") | |
| 66 | (:constructor make-view-struct) | |
| 67 | (:constructor view-struct* (name)) | |
| 68 | (:copier nil) | |
| 69 | (:print-function print-view-struct-object)) | |
| 65 | (:conc-name "VIEW-STRUCT-") | |
| 66 | (:constructor make-view-struct) | |
| 67 | (:constructor view-struct* (name)) | |
| 68 | (:copier nil) | |
| 69 | (:print-function print-view-struct-object)) | |
| 70 | 70 | (src nil :type (or null module)) |
| 71 | 71 | (target nil :type (or null module)) |
| 72 | 72 | (sort-maps nil :type list) |
| 100 | 100 | |
| 101 | 101 | (defun view-p (object) |
| 102 | 102 | (declare (type t object) |
| 103 | (values (or null t))) | |
| 103 | (values (or null t))) | |
| 104 | 104 | (view-struct-p object)) |
| 105 | 105 | |
| 106 | 106 | ;;; MODEXP-IS-VIEW : object -> Bool |
| 107 | 107 | ;;; |
| 108 | 108 | (defun modexp-is-view (object) |
| 109 | 109 | (declare (type t object) |
| 110 | (values (or null t))) | |
| 110 | (values (or null t))) | |
| 111 | 111 | (or (view-p object) (%is-view object))) |
| 112 | 112 | |
| 113 | 113 | |
| 114 | 114 | (defun view-is-inconsistent (view) |
| 115 | 115 | (declare (type view-struct view) |
| 116 | (values (or null t))) | |
| 116 | (values (or null t))) | |
| 117 | 117 | (object-is-inconsistent view)) |
| 118 | 118 | |
| 119 | 119 | ;;; view status |
| 120 | 120 | (defun mark-view-as-consistent (view) |
| 121 | 121 | (declare (type view-struct view) |
| 122 | (values fixnum)) | |
| 122 | (values fixnum)) | |
| 123 | 123 | (setf (object-status view) 1)) |
| 124 | 124 | |
| 125 | 125 | ;;; change propagation |
| 126 | 126 | ;;; NOTE: this is not enough, now defined in module.lisp |
| 127 | 127 | ;;; (defun propagate-view-change (view) |
| 128 | 128 | ;;; (declare (type view-struct view) |
| 129 | ;;; (values t)) | |
| 129 | ;;; (values t)) | |
| 130 | 130 | ;;; (propagate-object-change (view-exporting-objects view))) |
| 131 | 131 | |
| 132 | 132 | ;;; copy |
| 133 | 133 | (defun copy-view (from to) |
| 134 | 134 | (declare (type view-struct from to) |
| 135 | (values t)) | |
| 135 | (values t)) | |
| 136 | 136 | (setf (view-name to) (view-name from) |
| 137 | (view-decl-form to) (view-decl-form from) | |
| 138 | (view-src to) (view-src from) | |
| 139 | (view-target to) (view-target from) | |
| 140 | (view-sort-maps to) (view-sort-maps from) | |
| 141 | (view-op-maps to) (view-op-maps from) | |
| 142 | (view-interface to) (view-interface from))) | |
| 137 | (view-decl-form to) (view-decl-form from) | |
| 138 | (view-src to) (view-src from) | |
| 139 | (view-target to) (view-target from) | |
| 140 | (view-sort-maps to) (view-sort-maps from) | |
| 141 | (view-op-maps to) (view-op-maps from) | |
| 142 | (view-interface to) (view-interface from))) | |
| 143 | 143 | |
| 144 | 144 | ;;; initialization |
| 145 | 145 | (defun initialize-view (view) |
| 146 | 146 | (declare (type view-struct view) |
| 147 | (values t)) | |
| 147 | (values t)) | |
| 148 | 148 | (setf (view-status view) -1) |
| 149 | 149 | (if (the (or null ex-interface) (view-interface view)) |
| 150 | 150 | (initialize-object-interface (view-interface view)) |
| 151 | 151 | (setf (view-interface view) (make-ex-interface))) |
| 152 | 152 | (setf (view-src view) nil |
| 153 | (view-target view) nil | |
| 154 | (view-sort-maps view) nil | |
| 155 | (view-op-maps view) nil | |
| 156 | (view-decl-form view) nil | |
| 157 | )) | |
| 153 | (view-target view) nil | |
| 154 | (view-sort-maps view) nil | |
| 155 | (view-op-maps view) nil | |
| 156 | (view-decl-form view) nil | |
| 157 | )) | |
| 158 | 158 | |
| 159 | 159 | (defun clean-up-view (view) |
| 160 | 160 | (declare (type view-struct view) |
| 161 | (values t)) | |
| 161 | (values t)) | |
| 162 | 162 | (setf (view-name view) nil) |
| 163 | 163 | (setf (view-status view) 0) |
| 164 | 164 | (if (view-interface view) |
| 165 | 165 | (clean-up-ex-interface (view-interface view))) |
| 166 | 166 | (setf (view-interface view) nil) |
| 167 | 167 | (setf (view-src view) nil |
| 168 | (view-target view) nil | |
| 169 | (view-sort-maps view) nil | |
| 170 | (view-op-maps view) nil | |
| 171 | (view-decl-form view) nil | |
| 172 | )) | |
| 168 | (view-target view) nil | |
| 169 | (view-sort-maps view) nil | |
| 170 | (view-op-maps view) nil | |
| 171 | (view-decl-form view) nil | |
| 172 | )) | |
| 173 | 173 | |
| 174 | 174 | |
| 175 | 175 | ;;; ADDITIONAL MODULE EXPRESSIONS ______________________________________ |
| 214 | 214 | ;;; |
| 215 | 215 | (defun module-eq (x y) |
| 216 | 216 | (declare (type t x y) |
| 217 | (values (or null t))) | |
| 217 | (values (or null t))) | |
| 218 | 218 | (or (equal x y) |
| 219 | 219 | (and (module-p x) (module-eq (module-name x) y)) |
| 220 | 220 | (and (module-p y) (module-eq x (module-name y))))) |
| 225 | 225 | |
| 226 | 226 | (defun outer-equal (x y) |
| 227 | 227 | (declare (type t x y) |
| 228 | (values (or null t))) | |
| 228 | (values (or null t))) | |
| 229 | 229 | (cond ((stringp x) (equal x y)) |
| 230 | ((atom x) (eq x y)) ;note this includes structures and vectors | |
| 231 | ((consp x) | |
| 232 | (cond ((term? x) (eq x y)) | |
| 233 | (t | |
| 234 | (and (consp y) | |
| 235 | (do ((xl x (cdr xl)) | |
| 236 | (yl y (cdr yl)) | |
| 237 | (flag t)) | |
| 238 | ((or (when (or (atom xl) (atom yl)) | |
| 239 | (setq flag (eq xl yl)) | |
| 240 | t) | |
| 241 | (when (not (outer-equal (car xl) (car yl))) | |
| 242 | (setq flag nil) | |
| 243 | t)) | |
| 244 | flag)))))) | |
| 230 | ((atom x) (eq x y)) ;note this includes structures and vectors | |
| 231 | ((consp x) | |
| 232 | (cond ((term? x) (eq x y)) | |
| 233 | (t | |
| 234 | (and (consp y) | |
| 235 | (do ((xl x (cdr xl)) | |
| 236 | (yl y (cdr yl)) | |
| 237 | (flag t)) | |
| 238 | ((or (when (or (atom xl) (atom yl)) | |
| 239 | (setq flag (eq xl yl)) | |
| 240 | t) | |
| 241 | (when (not (outer-equal (car xl) (car yl))) | |
| 242 | (setq flag nil) | |
| 243 | t)) | |
| 244 | flag)))))) | |
| 245 | 245 | (t nil))) |
| 246 | 246 | |
| 247 | 247 | (defun same-top-level (me1 me2) |
| 248 | 248 | (declare (type t me1 me2) |
| 249 | (values (or null t))) | |
| 249 | (values (or null t))) | |
| 250 | 250 | (or (module-eq me1 me2) |
| 251 | 251 | (if (and (chaos-ast? me1) (chaos-ast? me2)) |
| 252 | (cond | |
| 253 | (;; me1 is renaming | |
| 254 | (%is-rename me1) | |
| 255 | (and (%is-rename me2) | |
| 256 | (module-eq (%rename-module me1) (%rename-module me2)) | |
| 257 | (same-renamed-module (%rename-map me1) (%rename-map me2)))) | |
| 258 | ||
| 259 | (;; me1 is instantiation | |
| 260 | (%is-instantiation me1) | |
| 261 | (and (%is-instantiation me2) | |
| 262 | (module-eq (%instantiation-module me1) | |
| 263 | (%instantiation-module me2)) | |
| 264 | (let ((args1 (%instantiation-args me1)) | |
| 265 | (args2 (%instantiation-args me2))) | |
| 266 | (declare (type list args1 args2)) | |
| 267 | (and (= (length args1) (length args2)) | |
| 268 | (every #'eq args1 args2))))) | |
| 269 | ||
| 270 | (;; me1 is module sum | |
| 271 | (%is-plus me1) | |
| 272 | (and (%is-plus me2) | |
| 273 | (equal (%plus-args me1) (%plus-args me2)))) | |
| 274 | ;; | |
| 275 | ;; view | |
| 276 | ((or (%is-view me1) | |
| 277 | (%is-view me2)) | |
| 278 | (and (module-eq (%view-module me1) (%view-module me2)) | |
| 279 | (module-eq (%view-target me1) (%view-target me2)) | |
| 280 | (same-view-mapping (%view-map me1) | |
| 281 | (%view-map me2)))) | |
| 282 | ||
| 283 | (t nil)) | |
| 284 | (if (and (view-p me1) (view-p me2)) | |
| 285 | (and (module-eq (view-src me1) | |
| 286 | (view-src me2)) | |
| 287 | (module-eq (view-target me1) | |
| 288 | (view-target me2)) | |
| 289 | (same-view-mapping (view-sort-maps me1) | |
| 290 | (view-sort-maps me2)) | |
| 291 | (same-view-mapping (view-op-maps me1) (view-op-maps me2))) | |
| 292 | ;; | |
| 293 | ;; non pure chaos-object | |
| 294 | ;; | |
| 295 | (cond ((and (consp me1) (consp me2)) | |
| 296 | (= (length (the cons me1)) | |
| 297 | (length (the cons me2))) | |
| 298 | (every #'eql me1 me2)) | |
| 299 | ((equal me1 me2) t) | |
| 300 | ((or (and (atom me2) (not (chaos-ast? me2))) | |
| 301 | (not (listp me1)) | |
| 302 | (not (listp me2)) | |
| 303 | (not (= (length me1) (length me2)))) | |
| 304 | nil) | |
| 305 | (t nil) | |
| 306 | ))))) | |
| 252 | (cond | |
| 253 | (;; me1 is renaming | |
| 254 | (%is-rename me1) | |
| 255 | (and (%is-rename me2) | |
| 256 | (module-eq (%rename-module me1) (%rename-module me2)) | |
| 257 | (same-renamed-module (%rename-map me1) (%rename-map me2)))) | |
| 258 | ||
| 259 | (;; me1 is instantiation | |
| 260 | (%is-instantiation me1) | |
| 261 | (and (%is-instantiation me2) | |
| 262 | (module-eq (%instantiation-module me1) | |
| 263 | (%instantiation-module me2)) | |
| 264 | (let ((args1 (%instantiation-args me1)) | |
| 265 | (args2 (%instantiation-args me2))) | |
| 266 | (declare (type list args1 args2)) | |
| 267 | (and (= (length args1) (length args2)) | |
| 268 | (every #'eq args1 args2))))) | |
| 269 | ||
| 270 | (;; me1 is module sum | |
| 271 | (%is-plus me1) | |
| 272 | (and (%is-plus me2) | |
| 273 | (equal (%plus-args me1) (%plus-args me2)))) | |
| 274 | ;; | |
| 275 | ;; view | |
| 276 | ((or (%is-view me1) | |
| 277 | (%is-view me2)) | |
| 278 | (and (module-eq (%view-module me1) (%view-module me2)) | |
| 279 | (module-eq (%view-target me1) (%view-target me2)) | |
| 280 | (same-view-mapping (%view-map me1) | |
| 281 | (%view-map me2)))) | |
| 282 | ||
| 283 | (t nil)) | |
| 284 | (if (and (view-p me1) (view-p me2)) | |
| 285 | (and (module-eq (view-src me1) | |
| 286 | (view-src me2)) | |
| 287 | (module-eq (view-target me1) | |
| 288 | (view-target me2)) | |
| 289 | (same-view-mapping (view-sort-maps me1) | |
| 290 | (view-sort-maps me2)) | |
| 291 | (same-view-mapping (view-op-maps me1) (view-op-maps me2))) | |
| 292 | ;; | |
| 293 | ;; non pure chaos-object | |
| 294 | ;; | |
| 295 | (cond ((and (consp me1) (consp me2)) | |
| 296 | (= (length (the cons me1)) | |
| 297 | (length (the cons me2))) | |
| 298 | (every #'eql me1 me2)) | |
| 299 | ((equal me1 me2) t) | |
| 300 | ((or (and (atom me2) (not (chaos-ast? me2))) | |
| 301 | (not (listp me1)) | |
| 302 | (not (listp me2)) | |
| 303 | (not (= (length me1) (length me2)))) | |
| 304 | nil) | |
| 305 | (t nil) | |
| 306 | ))))) | |
| 307 | 307 | |
| 308 | 308 | ;;; ************ |
| 309 | 309 | ;;; DUMMY MODULE________________________________________________________________ |
| 316 | 316 | |
| 317 | 317 | (defun create-dummy-module (map mod info) |
| 318 | 318 | (declare (type modmorph map) |
| 319 | (type module mod) | |
| 320 | (type t info) | |
| 321 | (values module)) | |
| 319 | (type module mod) | |
| 320 | (type t info) | |
| 321 | (values module)) | |
| 322 | 322 | (let ((val (assq mod (modmorph-module map)))) |
| 323 | 323 | (if val |
| 324 | (cdr val) | |
| 325 | (let ((newmod (make-module :name "DUMMY"))) | |
| 326 | (initialize-module newmod) | |
| 327 | (setf (get-rename-info newmod) (cons mod info)) | |
| 328 | newmod)))) | |
| 324 | (cdr val) | |
| 325 | (let ((newmod (make-module :name "DUMMY"))) | |
| 326 | (initialize-module newmod) | |
| 327 | (setf (get-rename-info newmod) (cons mod info)) | |
| 328 | newmod)))) | |
| 329 | 329 | |
| 330 | 330 | (defun create-dummy-module-then-map (map mod info) |
| 331 | 331 | (declare (type modmorph map) |
| 332 | (type module mod) | |
| 333 | (type t info) | |
| 334 | (values module)) | |
| 332 | (type module mod) | |
| 333 | (type t info) | |
| 334 | (values module)) | |
| 335 | 335 | (let ((dmod (create-dummy-module map mod info))) |
| 336 | 336 | (pushnew (cons mod dmod) (modmorph-module map) |
| 337 | :key #'car :test #'eq) | |
| 337 | :key #'car :test #'eq) | |
| 338 | 338 | dmod)) |
| 339 | 339 | |
| 340 | 340 | (defun module-is-rename-dummy-for (mod1 mod) |
| 341 | 341 | (declare (type module mod1 mod) |
| 342 | (values (or null t))) | |
| 342 | (values (or null t))) | |
| 343 | 343 | (if (equal "DUMMY" (module-name mod1)) |
| 344 | 344 | (let* ((info (get-rename-info mod)) |
| 345 | (oldmod (car info))) | |
| 346 | (eq oldmod mod)) | |
| 345 | (oldmod (car info))) | |
| 346 | (eq oldmod mod)) | |
| 347 | 347 | )) |
| 348 | 348 | |
| 349 | 349 | (defun is-dummy-module (mod) |
| 350 | 350 | (declare (type t mod) |
| 351 | (values (or null t))) | |
| 351 | (values (or null t))) | |
| 352 | 352 | (and (module-p mod) |
| 353 | 353 | (equal "DUMMY" (module-name mod)))) |
| 354 | 354 | |
| 0 | 0 | ;;;-*- Mode:LISP; Package:CHAOS; Base:10; Syntax:Common-lisp -*- |
| 1 | 1 | ;;; |
| 2 | ;;; Copyright (c) 2000-2014, Toshimi Sawada. All rights reserved. | |
| 2 | ;;; Copyright (c) 2000-2015, Toshimi Sawada. All rights reserved. | |
| 3 | 3 | ;;; |
| 4 | 4 | ;;; Redistribution and use in source and binary forms, with or without |
| 5 | 5 | ;;; modification, are permitted provided that the following conditions |
| 27 | 27 | ;;; |
| 28 | 28 | (in-package :chaos) |
| 29 | 29 | #|============================================================================== |
| 30 | System: Chaos | |
| 31 | Module: primitives | |
| 32 | File: context.lisp | |
| 30 | System: Chaos | |
| 31 | Module: primitives | |
| 32 | File: context.lisp | |
| 33 | 33 | ==============================================================================|# |
| 34 | 34 | #-:chaos-debug |
| 35 | 35 | (declaim (optimize (speed 3) (safety 0) #-GCL (debug 0))) |
| 40 | 40 | ;;; all the functions which handle module's context. |
| 41 | 41 | ;;; |
| 42 | 42 | |
| 43 | ;;; INSTANCE DB **************************************************************** | |
| 44 | ;;; instance db stores all the instances of class sort. | |
| 45 | ;;; made for persistent object | |
| 46 | ;;; we store term-body of an instance in the instance db. | |
| 47 | ;;; retrieving the instance always creates new term. | |
| 48 | ;;; this is for avoiding destructive replacement of term body. | |
| 49 | ;;; | |
| 50 | ||
| 51 | ;;; (defvar *instance-db* (make-hash-table :test #'equal)) | |
| 52 | ;;; (defun clear-instance-db () (clrhash *instance-db*)) | |
| 53 | ||
| 54 | (defmacro make-id-key (___id) | |
| 55 | (once-only (___id) | |
| 56 | ` (cond ((term-is-builtin-constant? ,___id) | |
| 57 | (term-builtin-value ,___id)) | |
| 58 | (t (method-symbol (term-method ,___id)))))) | |
| 59 | ||
| 60 | (defun find-instance (id &optional class (module *current-module*)) | |
| 61 | (or (find-instance-aux id module class) | |
| 62 | (dolist (sub (module-all-submodules module) nil) | |
| 63 | (when (not (eq (cdr sub) :using)) | |
| 64 | (let ((inst (find-instance-aux id (car sub) class))) | |
| 65 | (if inst (return-from find-instance inst))))))) | |
| 66 | ||
| 67 | (defun find-instance-aux (id module &optional class) | |
| 68 | (let ((db (module-instance-db module))) | |
| 69 | (unless db (return-from find-instance-aux nil)) | |
| 70 | (let ((body (gethash (make-id-key id) db))) | |
| 71 | (if body | |
| 72 | (progn | |
| 73 | (term$unset-reduced-flag body) | |
| 74 | (when class | |
| 75 | (unless (sort<= (term$sort body) class (module-sort-order module)) | |
| 76 | (return-from find-instance-aux nil))) | |
| 77 | (list body)) | |
| 78 | nil)))) | |
| 79 | ||
| 80 | (defun register-instance (object) | |
| 81 | (unless (term-eq *void-object* object) | |
| 82 | (let ((module (sort-module (term-sort object))) | |
| 83 | (id (term-arg-1 object))) | |
| 84 | (let ((db (module-instance-db module))) | |
| 85 | (unless db | |
| 86 | (initialize-module-instance-db module) | |
| 87 | (setq db (module-instance-db module))) | |
| 88 | (setf (gethash (make-id-key id) db) (term-body object)))))) | |
| 89 | ||
| 90 | (defun delete-instance (object) | |
| 91 | (unless (term-eq *void-object* object) | |
| 92 | (let ((module (sort-module (term-sort object)))) | |
| 93 | (let ((db (module-instance-db module))) | |
| 94 | (unless db | |
| 95 | (return-from delete-instance nil)) | |
| 96 | (remhash (make-id-key (term-arg-1 object)) db))))) | |
| 43 | ;;; GET-CONTEXT : null | module | |
| 44 | (defun get-context () | |
| 45 | (if *current-module* | |
| 46 | (module-context *current-module*) | |
| 47 | nil)) | |
| 48 | ||
| 49 | ;;; GET-CONTEXT-MODULE | |
| 50 | (defun get-context-module (&optional no-error) | |
| 51 | (or *current-module* | |
| 52 | (if no-error | |
| 53 | nil | |
| 54 | (with-output-chaos-error ('no-context) | |
| 55 | (format t "No context module is set."))))) | |
| 56 | ||
| 57 | ;;; RESET-CONTEXT-MODULE | |
| 58 | (defun reset-context-module (&optional (mod nil)) | |
| 59 | (setf *current-module* mod)) | |
| 60 | ||
| 61 | ;;; GET-OBJECT-CONTEXT object -> null | module | |
| 62 | ;;; | |
| 63 | (defun get-object-context (obj) | |
| 64 | (or (get-context-module t) (object-context-mod obj))) | |
| 97 | 65 | |
| 98 | 66 | ;;; BINDINGS ******************************************************************* |
| 99 | 67 | |
| 100 | ;;; GET BOUND VALUES | |
| 68 | ;;; GET-BOUND-VALUE : let-symbol -> value (a term) | null | |
| 69 | ||
| 101 | 70 | (defun is-special-let-variable? (name) |
| 102 | 71 | (declare (values (or null t))) |
| 103 | 72 | (and (>= (length (the simple-string name)) 3) |
| 106 | 75 | (defun check-$$term-context (mod) |
| 107 | 76 | (or (eq $$term-context mod) |
| 108 | 77 | (member $$term-context |
| 109 | (module-all-submodules mod) | |
| 110 | :test #'(lambda (x y) | |
| 111 | (eq x (car y)))))) | |
| 112 | ||
| 113 | (defun get-bound-value (let-sym &optional (mod *current-module*)) | |
| 78 | (module-all-submodules mod) | |
| 79 | :test #'(lambda (x y) | |
| 80 | (eq x (car y)))))) | |
| 81 | ||
| 82 | (defun get-bound-value (let-sym &optional (mod (get-context-module))) | |
| 114 | 83 | (or (cdr (assoc let-sym (module-bindings mod) :test #'equal)) |
| 115 | 84 | (when *allow-$$term* |
| 116 | (cond ((equal let-sym "$$term") | |
| 117 | (when (or (null $$term) (eq 'void $$term)) | |
| 118 | (with-output-simple-msg () | |
| 119 | (princ "[Error] $$term has no proper value.") | |
| 120 | (throw 'term-context-error nil))) | |
| 121 | (unless (check-$$term-context mod) | |
| 122 | (with-output-simple-msg () | |
| 123 | (princ "[Error] $$term is not proper in the current module.") | |
| 124 | (throw 'term-context-error nil))) | |
| 125 | $$term) | |
| 126 | ((equal let-sym "$$subterm") | |
| 127 | (unless $$subterm | |
| 128 | (with-output-simple-msg () | |
| 129 | (princ "[Error] $$subterm has no proper vlaue.") | |
| 130 | (throw 'term-context-error nil))) | |
| 131 | (unless (check-$$term-context mod) | |
| 132 | (with-output-simple-msg () | |
| 133 | (princ "[Error] $$subterm is not proper in the current module.") | |
| 134 | (throw 'term-context-error nil))) | |
| 135 | $$subterm) | |
| 136 | ((is-special-let-variable? let-sym) | |
| 137 | (cdr (assoc let-sym (module-bindings mod) :test #'equal))) | |
| 138 | (t nil))))) | |
| 139 | ||
| 140 | (defun set-bound-value (let-sym value &optional (mod *current-module*)) | |
| 85 | (cond ((equal let-sym "$$term") | |
| 86 | (when (or (null $$term) (eq 'void $$term)) | |
| 87 | (with-output-simple-msg () | |
| 88 | (princ "[Error] $$term has no proper value.") | |
| 89 | (throw 'term-context-error nil))) | |
| 90 | (unless (check-$$term-context mod) | |
| 91 | (with-output-simple-msg () | |
| 92 | (princ "[Error] $$term is not proper in the current module.") | |
| 93 | (throw 'term-context-error nil))) | |
| 94 | $$term) | |
| 95 | ((equal let-sym "$$subterm") | |
| 96 | (unless $$subterm | |
| 97 | (with-output-simple-msg () | |
| 98 | (princ "[Error] $$subterm has no proper vlaue.") | |
| 99 | (throw 'term-context-error nil))) | |
| 100 | (unless (check-$$term-context mod) | |
| 101 | (with-output-simple-msg () | |
| 102 | (princ "[Error] $$subterm is not proper in the current module.") | |
| 103 | (throw 'term-context-error nil))) | |
| 104 | $$subterm) | |
| 105 | ((is-special-let-variable? let-sym) | |
| 106 | (cdr (assoc let-sym (module-bindings mod) :test #'equal))) | |
| 107 | (t nil))))) | |
| 108 | ||
| 109 | (defun set-bound-value (let-sym value &optional (mod (get-context-module))) | |
| 141 | 110 | (when (or (equal let-sym "$$term") |
| 142 | (equal let-sym "$$subterm")) | |
| 111 | (equal let-sym "$$subterm")) | |
| 143 | 112 | (with-output-chaos-error ('misc-error) |
| 144 | (princ "sorry, but you cannot use \"$$term\" or \"$$subterm\" as let variable.") | |
| 145 | )) | |
| 113 | (princ "sorry, but you cannot use \"$$term\" or \"$$subterm\" as let variable."))) | |
| 146 | 114 | ;; |
| 147 | 115 | (let* ((special nil) |
| 148 | (bindings (if (is-special-let-variable? let-sym) | |
| 149 | (progn (setq special t) (module-special-bindings mod)) | |
| 150 | (module-bindings mod)))) | |
| 116 | (bindings (if (is-special-let-variable? let-sym) | |
| 117 | (progn (setq special t) (module-special-bindings mod)) | |
| 118 | (module-bindings mod)))) | |
| 151 | 119 | (let ((binding (assoc let-sym bindings :test #'equal))) |
| 152 | 120 | (if binding |
| 153 | (progn | |
| 154 | (with-output-chaos-warning () | |
| 155 | (format t "resetting bound value of ~a to " let-sym) | |
| 156 | (print-chaos-object value)) | |
| 157 | (setf (cdr binding) value)) | |
| 158 | (if special | |
| 159 | (setf (module-special-bindings mod) | |
| 160 | (acons let-sym value (module-special-bindings mod))) | |
| 161 | (setf (module-bindings mod) | |
| 162 | (acons let-sym value (module-bindings mod)))))))) | |
| 121 | (progn | |
| 122 | (with-output-chaos-warning () | |
| 123 | (format t "resetting bound value of ~a to " let-sym) | |
| 124 | (print-chaos-object value)) | |
| 125 | (setf (cdr binding) value)) | |
| 126 | (if special | |
| 127 | (setf (module-special-bindings mod) | |
| 128 | (acons let-sym value (module-special-bindings mod))) | |
| 129 | (setf (module-bindings mod) | |
| 130 | (acons let-sym value (module-bindings mod)))))))) | |
| 163 | 131 | |
| 164 | 132 | ;;; CHANGING CONTEXT |
| 165 | 133 | ;;;----------------------------------------------------------------------------- |
| 172 | 140 | (when (and mod (module-name mod)) |
| 173 | 141 | (let ((context (module-context mod))) |
| 174 | 142 | (setf (module-context-$$term context) $$term |
| 175 | (module-context-$$subterm context) $$subterm | |
| 176 | (module-context-$$action-stack context) $$action-stack | |
| 177 | (module-context-$$selection-stack context) $$selection-stack | |
| 178 | (module-context-$$stop-pattern context) *rewrite-stop-pattern* | |
| 179 | ;; (module-context-$$ptree context) *proof-tree* | |
| 180 | )))) | |
| 143 | (module-context-$$subterm context) $$subterm | |
| 144 | (module-context-$$action-stack context) $$action-stack | |
| 145 | (module-context-$$selection-stack context) $$selection-stack | |
| 146 | (module-context-$$stop-pattern context) *rewrite-stop-pattern*)))) | |
| 181 | 147 | |
| 182 | 148 | (defun new-context (mod) |
| 183 | 149 | (unless mod |
| 184 | 150 | (setf $$term nil |
| 185 | $$subterm nil | |
| 186 | $$action-stack nil | |
| 187 | $$selection-stack nil | |
| 188 | $$term-context nil | |
| 189 | *last-module* nil | |
| 190 | ;; !!! | |
| 191 | *current-module* nil | |
| 192 | *rewrite-stop-pattern* nil | |
| 193 | ;; *proof-tree* nil | |
| 194 | ) | |
| 151 | $$subterm nil | |
| 152 | $$action-stack nil | |
| 153 | $$selection-stack nil | |
| 154 | *current-module* nil | |
| 155 | *rewrite-stop-pattern* nil) | |
| 195 | 156 | (return-from new-context nil)) |
| 196 | ;; | |
| 197 | 157 | (let ((context (module-context mod))) |
| 198 | 158 | (setf $$term (module-context-$$term context) |
| 199 | $$subterm (module-context-$$subterm context) | |
| 200 | $$action-stack (module-context-$$action-stack context) | |
| 201 | $$selection-stack (module-context-$$selection-stack context) | |
| 202 | *rewrite-stop-pattern* (module-context-$$stop-pattern context) | |
| 203 | ;;*proof-tree* (module-context-$$ptree context) | |
| 204 | ) | |
| 159 | $$subterm (module-context-$$subterm context) | |
| 160 | $$action-stack (module-context-$$action-stack context) | |
| 161 | $$selection-stack (module-context-$$selection-stack context) | |
| 162 | *rewrite-stop-pattern* (module-context-$$stop-pattern context)) | |
| 205 | 163 | (setf $$term-context mod) |
| 206 | (setq *last-module* mod) | |
| 207 | ;; !!!!! | |
| 208 | (setq *current-module* mod) | |
| 209 | ;; !!!!! | |
| 164 | (reset-context-module mod) | |
| 210 | 165 | (clear-method-info-hash) |
| 211 | 166 | t)) |
| 212 | 167 | |
| 222 | 177 | ;; save current context |
| 223 | 178 | (save-context from) |
| 224 | 179 | ;; restore new context |
| 225 | (new-context to) | |
| 226 | ) | |
| 180 | (new-context to)) | |
| 227 | 181 | |
| 228 | 182 | (defun reset-target-term (term old-mod mod) |
| 229 | 183 | (if (eq mod old-mod) |
| 230 | 184 | (progn |
| 231 | (setq $$term term | |
| 232 | $$subterm term | |
| 233 | $$selection-stack nil) | |
| 234 | (save-context mod) | |
| 235 | (new-context mod)) | |
| 236 | ;; we do not change globals, instead set in context of mod. | |
| 237 | (save-context mod))) | |
| 185 | (setq $$term term | |
| 186 | $$term-context mod | |
| 187 | $$subterm term | |
| 188 | $$selection-stack nil) | |
| 189 | (save-context mod) | |
| 190 | (new-context mod)) | |
| 191 | ;; we do not change globals, instead set in context of mod. | |
| 192 | (progn | |
| 193 | (setq $$term-context mod) | |
| 194 | (save-context mod)))) | |
| 238 | 195 | ;;; |
| 239 | 196 | (defun context-push (mod) |
| 240 | 197 | (push mod *old-context*)) |
| 247 | 204 | (change-context old new)) |
| 248 | 205 | |
| 249 | 206 | (defun context-pop-and-recover () |
| 250 | (when (or *last-module* *current-module*) | |
| 251 | (let ((old (context-pop))) | |
| 252 | (unless (member old (list *last-module* *current-module*)) | |
| 253 | ;; eval-mod may change the current context implicitly. | |
| 254 | ;; in this case we do not recover context. | |
| 255 | (change-context *last-module* old))))) | |
| 207 | (let ((old (context-pop))) | |
| 208 | (unless (eq old (get-context-module t)) | |
| 209 | ;; eval-mod may change the current context implicitly. | |
| 210 | ;; in this case we do not recover context. | |
| 211 | (change-context (get-context-module t) old)))) | |
| 256 | 212 | |
| 257 | 213 | ;;; EOF |
| 214 | ||
| 0 | 0 | ;;;-*-Mode:LISP; Package: Chaos; Base:10; Syntax:Common-lisp -*- |
| 1 | 1 | ;;; |
| 2 | ;;; Copyright (c) 2000-2014, Toshimi Sawada. All rights reserved. | |
| 2 | ;;; Copyright (c) 2000-2015, Toshimi Sawada. All rights reserved. | |
| 3 | 3 | ;;; |
| 4 | 4 | ;;; Redistribution and use in source and binary forms, with or without |
| 5 | 5 | ;;; modification, are permitted provided that the following conditions |
| 27 | 27 | ;;; |
| 28 | 28 | (in-package :chaos) |
| 29 | 29 | #|============================================================================== |
| 30 | System: Chaos | |
| 31 | Module: primitives | |
| 32 | File: defterm.lisp | |
| 30 | System: Chaos | |
| 31 | Module: primitives | |
| 32 | File: defterm.lisp | |
| 33 | 33 | ==============================================================================|# |
| 34 | 34 | #-:chaos-debug |
| 35 | 35 | (declaim (optimize (speed 3) (safety 0) #-GCL (debug 0))) |
| 71 | 71 | (defun chaos-pr-object (obj stream &rest ignore) |
| 72 | 72 | (declare (ignore ignore)) |
| 73 | 73 | (format stream "#<~a : ~x>" (%chaos-object--type obj) |
| 74 | (addr-of obj))) | |
| 74 | (addr-of obj))) | |
| 75 | 75 | |
| 76 | 76 | (defstruct (%chaos-static-object #+gcl (:static t) |
| 77 | ) | |
| 77 | ) | |
| 78 | 78 | (-type nil :type symbol)) |
| 79 | 79 | |
| 80 | 80 | (defmacro object-type (_object_) `(%chaos-object--type ,_object_)) |
| 88 | 88 | (defmacro type-p-chaos (_object _type) |
| 89 | 89 | (once-only (_object) |
| 90 | 90 | ` (and (structure-p ,_object) |
| 91 | (eq (object-type ,_object) ,_type)))) | |
| 91 | (eq (object-type ,_object) ,_type)))) | |
| 92 | 92 | |
| 93 | 93 | (defmacro object-category (_object) `(get (object-type ,_object) ':category)) |
| 94 | 94 | |
| 102 | 102 | (defmacro object-constructor (_object) |
| 103 | 103 | ` (let ((key (object-type ,_object))) |
| 104 | 104 | (and (fboundp key) |
| 105 | (symbol-function key)))) | |
| 105 | (symbol-function key)))) | |
| 106 | 106 | |
| 107 | 107 | ;;; |
| 108 | 108 | ;;; AST basic structure |
| 112 | 112 | (defmacro chaos-ast? (*object) |
| 113 | 113 | (once-only (*object) |
| 114 | 114 | ` (and (listp ,*object) |
| 115 | (symbolp (car ,*object)) | |
| 116 | (get (car ,*object) ':category)))) | |
| 115 | (symbolp (car ,*object)) | |
| 116 | (get (car ,*object) ':category)))) | |
| 117 | 117 | |
| 118 | 118 | (defmacro ast-type (_ast_) `(car ,_ast_)) |
| 119 | 119 | |
| 147 | 147 | (when (memq rest-slot visible-slots) |
| 148 | 148 | (setf visible-slots (firstn visible-slots (- (length visible-slots) 2)))) |
| 149 | 149 | (let* ((res nil) |
| 150 | (optional? (position '&optional visible-slots)) | |
| 151 | (args (if optional? | |
| 152 | (subseq visible-slots 0 optional?) | |
| 153 | visible-slots)) | |
| 154 | (optionals (when optional? | |
| 155 | (nthcdr (1+ optional?) visible-slots)))) | |
| 150 | (optional? (position '&optional visible-slots)) | |
| 151 | (args (if optional? | |
| 152 | (subseq visible-slots 0 optional?) | |
| 153 | visible-slots)) | |
| 154 | (optionals (when optional? | |
| 155 | (nthcdr (1+ optional?) visible-slots)))) | |
| 156 | 156 | (if rest-slot |
| 157 | (push (append args (list rest-slot)) res) | |
| 158 | (push args res)) | |
| 157 | (push (append args (list rest-slot)) res) | |
| 158 | (push args res)) | |
| 159 | 159 | (dolist (opt optionals) |
| 160 | 160 | (push (append (car res) (if rest-slot |
| 161 | (nconc (list opt) (list rest-slot)) | |
| 162 | (list opt))) | |
| 163 | res)) | |
| 161 | (nconc (list opt) (list rest-slot)) | |
| 162 | (list opt))) | |
| 163 | res)) | |
| 164 | 164 | (nreverse res))) |
| 165 | 165 | |
| 166 | 166 | ;;; * NOTE * symbol .universal. will be replaced by rel *universal-sort* at |
| 167 | 167 | ;;; boot time. |
| 168 | 168 | (defun make-ast-forms (name visible-slots &optional rest-slot) |
| 169 | 169 | (let ((forms nil) |
| 170 | (form nil)) | |
| 170 | (form nil)) | |
| 171 | 171 | (dolist (sl (make-ast-argpatterns visible-slots rest-slot)) |
| 172 | 172 | (setf form nil) |
| 173 | 173 | (push `(token . ,name) form) |
| 174 | 174 | (when sl |
| 175 | (push '(token . "(") form)) | |
| 175 | (push '(token . "(") form)) | |
| 176 | 176 | (dolist (x (cdr sl)) |
| 177 | x | |
| 178 | (push `(argument ,parser-max-precedence . .universal.) form) | |
| 179 | (push '(token . ",") form)) | |
| 177 | x | |
| 178 | (push `(argument ,parser-max-precedence . .universal.) form) | |
| 179 | (push '(token . ",") form)) | |
| 180 | 180 | (when sl |
| 181 | (if rest-slot | |
| 182 | (push `(argument* ,parser-max-precedence . .universal.) form) | |
| 183 | (push `(argument ,parser-max-precedence . .universal.) form)) | |
| 184 | (push '(token . ")") form)) | |
| 181 | (if rest-slot | |
| 182 | (push `(argument* ,parser-max-precedence . .universal.) form) | |
| 183 | (push `(argument ,parser-max-precedence . .universal.) form)) | |
| 184 | (push '(token . ")") form)) | |
| 185 | 185 | (push (nreverse form) forms)) |
| 186 | 186 | (nreverse forms))) |
| 187 | 187 | ) |
| 190 | 190 | (defun %make-keyword (symbol-or-string &optional (cat '%object)) |
| 191 | 191 | (let ((nam nil)) |
| 192 | 192 | (if (member cat '(:ast :script :chaos-script)) |
| 193 | (setq nam (concatenate 'string "%" | |
| 194 | (the simple-string (string symbol-or-string)))) | |
| 195 | (setq nam (string symbol-or-string))) | |
| 193 | (setq nam (concatenate 'string "%" | |
| 194 | (the simple-string (string symbol-or-string)))) | |
| 195 | (setq nam (string symbol-or-string))) | |
| 196 | 196 | (intern nam))) |
| 197 | 197 | |
| 198 | 198 | (defmacro defterm (type (&optional super) |
| 199 | &key | |
| 200 | (conc-name "") ; conc-name | |
| 201 | name ; name of the structure | |
| 202 | visible ; list of visible slots | |
| 203 | hidden ; list of invisible slots | |
| 204 | eval ; evaluator | |
| 205 | print ; printer | |
| 206 | category ; internal group name | |
| 207 | keyword ; t if defining keyword | |
| 208 | int-printer | |
| 209 | ) | |
| 199 | &key | |
| 200 | (conc-name "") ; conc-name | |
| 201 | name ; name of the structure | |
| 202 | visible ; list of visible slots | |
| 203 | hidden ; list of invisible slots | |
| 204 | eval ; evaluator | |
| 205 | print ; printer | |
| 206 | category ; internal group name | |
| 207 | keyword ; t if defining keyword | |
| 208 | int-printer | |
| 209 | ) | |
| 210 | 210 | (let ((optional? (memq '&optional visible)) |
| 211 | (rest? (memq '&rest visible)) | |
| 212 | ;; (rest-slot nil) | |
| 213 | ) | |
| 211 | (rest? (memq '&rest visible)) | |
| 212 | ;; (rest-slot nil) | |
| 213 | ) | |
| 214 | 214 | (when (and optional? rest?) |
| 215 | 215 | (error "you cannot specify &optional and &rest both at a time, sorry.")) |
| 216 | 216 | (when rest? |
| 217 | 217 | (let ((len (length visible))) |
| 218 | (declare (type fixnum len)) | |
| 219 | (unless (eq '&rest (car (nthcdr (- len 2) visible))) | |
| 220 | (error "&rest must be the last slot specifier!")) | |
| 221 | ;; (setf rest-slot (car (last visible))) | |
| 222 | (setf visible (nconc (firstn visible (- len 2)) (cons '&optional | |
| 223 | (last visible)))))) | |
| 218 | (declare (type fixnum len)) | |
| 219 | (unless (eq '&rest (car (nthcdr (- len 2) visible))) | |
| 220 | (error "&rest must be the last slot specifier!")) | |
| 221 | ;; (setf rest-slot (car (last visible))) | |
| 222 | (setf visible (nconc (firstn visible (- len 2)) (cons '&optional | |
| 223 | (last visible)))))) | |
| 224 | 224 | (when super |
| 225 | 225 | ;; NOTE:*********** |
| 226 | 226 | ;; (1) now does not check slot name confliction, use carefully if you use |
| 228 | 228 | ;; (2) &rest in super is not manpulated properly -> you cannot inherit |
| 229 | 229 | ;; super with &rest slot specifier. |
| 230 | 230 | (unless (get super ':category) |
| 231 | (error "No such super ~s" super))) | |
| 231 | (error "No such super ~s" super))) | |
| 232 | 232 | (let* ((cat (if category category |
| 233 | (get super ':category))) | |
| 234 | (type-name (%make-keyword type cat)) | |
| 235 | (name (if name name type)) | |
| 236 | (slots (if super | |
| 237 | (let ((osl (append visible hidden)) | |
| 238 | (ssl (get super ':chaos-slots)) | |
| 239 | (res nil)) | |
| 240 | (dolist (s osl) | |
| 241 | (unless (memq s ssl) | |
| 242 | (if (not (eq s '&optional)) | |
| 243 | (push s res)))) | |
| 244 | (append ssl (nreverse res))) | |
| 245 | (nconc (remove '&optional visible) hidden))) | |
| 246 | (own-slots (if super | |
| 247 | (let ((sss (get super :chaos-slots)) | |
| 248 | (os nil)) | |
| 249 | (dolist (s slots (nreverse os)) | |
| 250 | (unless (memq s sss) | |
| 251 | (push s os)))) | |
| 252 | slots)) | |
| 253 | (structure-conc-name (%make-keyword | |
| 254 | (concatenate 'string | |
| 255 | (the simple-string (string conc-name)) | |
| 256 | (the simple-string (string name)) | |
| 257 | "-") | |
| 258 | cat)) | |
| 259 | #|| | |
| 260 | (real-constructor (%make-keyword (concatenate 'string | |
| 261 | (string conc-name) | |
| 262 | "CREATE-" | |
| 263 | (string name)) | |
| 264 | cat)) | |
| 265 | (boa-constructor (if rest? | |
| 266 | (%make-keyword (concatenate 'string | |
| 267 | (subseq | |
| 268 | (string real-constructor) | |
| 269 | 1) | |
| 270 | "*") | |
| 271 | cat) | |
| 272 | real-constructor)) | |
| 273 | ||# | |
| 274 | (structure-constructor (%make-keyword | |
| 275 | (concatenate 'string | |
| 276 | (the simple-string | |
| 277 | (string conc-name)) | |
| 278 | "MAKE-" | |
| 279 | (the simple-string | |
| 280 | (string name))) | |
| 281 | cat)) | |
| 282 | (boa-constructor (%make-keyword (concatenate | |
| 283 | 'string | |
| 284 | (the simple-string (string conc-name)) | |
| 285 | (the simple-string (string name)) | |
| 286 | "*") | |
| 287 | cat)) | |
| 288 | ;; | |
| 289 | (predicate-name (%make-keyword (concatenate 'string | |
| 290 | (the simple-string | |
| 291 | (string conc-name)) | |
| 292 | "IS-" | |
| 293 | (the simple-string | |
| 294 | (string name))) | |
| 295 | cat)) | |
| 296 | (int-predicate-name (%make-keyword (concatenate 'string | |
| 297 | (the simple-string | |
| 298 | (string type-name)) | |
| 299 | "-P"))) | |
| 300 | ) | |
| 233 | (get super ':category))) | |
| 234 | (type-name (%make-keyword type cat)) | |
| 235 | (name (if name name type)) | |
| 236 | (slots (if super | |
| 237 | (let ((osl (append visible hidden)) | |
| 238 | (ssl (get super ':chaos-slots)) | |
| 239 | (res nil)) | |
| 240 | (dolist (s osl) | |
| 241 | (unless (memq s ssl) | |
| 242 | (if (not (eq s '&optional)) | |
| 243 | (push s res)))) | |
| 244 | (append ssl (nreverse res))) | |
| 245 | (nconc (remove '&optional visible) hidden))) | |
| 246 | (own-slots (if super | |
| 247 | (let ((sss (get super :chaos-slots)) | |
| 248 | (os nil)) | |
| 249 | (dolist (s slots (nreverse os)) | |
| 250 | (unless (memq s sss) | |
| 251 | (push s os)))) | |
| 252 | slots)) | |
| 253 | (structure-conc-name (%make-keyword | |
| 254 | (concatenate 'string | |
| 255 | (the simple-string (string conc-name)) | |
| 256 | (the simple-string (string name)) | |
| 257 | "-") | |
| 258 | cat)) | |
| 259 | #|| | |
| 260 | (real-constructor (%make-keyword (concatenate 'string | |
| 261 | (string conc-name) | |
| 262 | "CREATE-" | |
| 263 | (string name)) | |
| 264 | cat)) | |
| 265 | (boa-constructor (if rest? | |
| 266 | (%make-keyword (concatenate 'string | |
| 267 | (subseq | |
| 268 | (string real-constructor) | |
| 269 | 1) | |
| 270 | "*") | |
| 271 | cat) | |
| 272 | real-constructor)) | |
| 273 | ||# | |
| 274 | (structure-constructor (%make-keyword | |
| 275 | (concatenate 'string | |
| 276 | (the simple-string | |
| 277 | (string conc-name)) | |
| 278 | "MAKE-" | |
| 279 | (the simple-string | |
| 280 | (string name))) | |
| 281 | cat)) | |
| 282 | (boa-constructor (%make-keyword (concatenate | |
| 283 | 'string | |
| 284 | (the simple-string (string conc-name)) | |
| 285 | (the simple-string (string name)) | |
| 286 | "*") | |
| 287 | cat)) | |
| 288 | ;; | |
| 289 | (predicate-name (%make-keyword (concatenate 'string | |
| 290 | (the simple-string | |
| 291 | (string conc-name)) | |
| 292 | "IS-" | |
| 293 | (the simple-string | |
| 294 | (string name))) | |
| 295 | cat)) | |
| 296 | (int-predicate-name (%make-keyword (concatenate 'string | |
| 297 | (the simple-string | |
| 298 | (string type-name)) | |
| 299 | "-P"))) | |
| 300 | ) | |
| 301 | 301 | ;; (format t "~&--- category -- ~s" cat) |
| 302 | 302 | (if keyword |
| 303 | ` (eval-when (:execute :compile-toplevel :load-toplevel) | |
| 304 | (let ((*package *keyword-package*)) | |
| 305 | (setf (get ',type-name ':category) ,cat) | |
| 306 | (defun ,type-name () ,type-name) | |
| 307 | #|| | |
| 308 | ;; register to builtin parse dictionary | |
| 309 | (let ((opname ,(string-downcase (format nil "~s" type-name)))) | |
| 310 | (setf (gethash opname *builtin-ast-dict*) | |
| 311 | (mapcar #'(lambda (x) | |
| 312 | (cons ,type-name x)) | |
| 313 | (make-ast-forms opname nil)))) | |
| 314 | ||# | |
| 315 | )) | |
| 316 | ;; | |
| 317 | ` (eval-when (:execute :compile-toplevel :load-toplevel) | |
| 318 | (defparameter,type-name ',type-name) | |
| 319 | (setf (get ',type-name ':chaos-slots) ',slots) | |
| 320 | (setf (get ',type-name ':visible-slots) ',visible) | |
| 321 | (setf (get ',type-name ':category) ,cat) | |
| 322 | ;; the sutructure | |
| 323 | (defstruct (,type-name | |
| 324 | (:conc-name ,structure-conc-name) | |
| 325 | (:constructor ,structure-constructor) | |
| 326 | (:constructor ,boa-constructor ,visible) | |
| 327 | (:copier nil) | |
| 328 | ,@(if (or (eq cat ':ast) | |
| 329 | (eq cat ':chaos-script)) | |
| 330 | (list '(:type list) | |
| 331 | `(:include %chaos-ast (-type ',type-name))) | |
| 332 | (if (memq cat '(:static-object | |
| 333 | :static-int-object)) | |
| 334 | (list ` (:include %chaos-static-object | |
| 335 | (-type ',type-name)) | |
| 336 | #+gcl '(:static t) | |
| 337 | ) | |
| 338 | (list ` (:include ,(if super | |
| 339 | super | |
| 340 | '%chaos-object) | |
| 341 | (-type ',type-name)) | |
| 342 | (if int-printer | |
| 343 | `(:print-function ,int-printer) | |
| 344 | '(:print-function | |
| 345 | chaos-pr-object)) | |
| 346 | ) | |
| 347 | ))) | |
| 348 | ,@own-slots) | |
| 349 | ||
| 350 | ;; predicate | |
| 351 | , (case cat | |
| 352 | ((:ast :chaos-script) | |
| 353 | `(defun ,predicate-name (obj) | |
| 354 | (and (chaos-ast? obj) (eq (ast-type obj) ',type-name)))) | |
| 355 | (otherwise | |
| 356 | ` (setf (symbol-function ',predicate-name) | |
| 357 | (symbol-function ',int-predicate-name)) | |
| 358 | )) | |
| 359 | (setf (get ,type-name ':type-predicate) | |
| 360 | (symbol-function ',predicate-name)) | |
| 361 | ||
| 362 | ;; constructor | |
| 363 | #|| | |
| 364 | ,(when rest-slot | |
| 365 | (let ((arg-list (subst '&rest '&optional visible))) | |
| 366 | ` (defun ,real-constructor ,arg-list | |
| 367 | (,boa-constructor ,@(firstn arg-list (- (length | |
| 368 | arg-list) 2)) | |
| 369 | ,(car (last arg-list)))))) | |
| 370 | ,(if real-constructor | |
| 371 | ` (progn (setf (symbol-function ',type-name) | |
| 372 | (symbol-function ',real-constructor)) | |
| 373 | (setf (symbol-function ',(%make-keyword | |
| 374 | (concatenate 'string | |
| 375 | (string type) | |
| 376 | "*") | |
| 377 | cat)) | |
| 378 | (symbol-function ',boa-constructor))) | |
| 379 | ` (setf (symbol-function ',type-name) | |
| 380 | (symbol-function ',boa-constructor))) | |
| 381 | ||# | |
| 382 | ||
| 383 | ;; evaluator | |
| 384 | (setf (get ',type-name ':eval) ',eval) | |
| 385 | ||
| 386 | , (when (and eval (or (eq cat ':ast) | |
| 387 | (eq cat ':chaos-script))) | |
| 388 | (let ((eval-mac (intern (concatenate | |
| 389 | 'string | |
| 390 | "!" | |
| 391 | (the simple-string | |
| 392 | (string type-name)))))) | |
| 393 | ` (defmacro ,eval-mac (*__ast &optional *__context) | |
| 394 | `(let ((*chaos-eval-context* ,*__context)) | |
| 395 | (eval-ast ,*__ast))))) | |
| 396 | ;; printer | |
| 397 | (setf (get ',type-name ':print) ',print) | |
| 398 | ;; type | |
| 399 | ;; (deftype ,type-name () '(satisfies ,predicate-name)) | |
| 400 | ))))) | |
| 303 | ` (eval-when (:execute :compile-toplevel :load-toplevel) | |
| 304 | (let ((*package *keyword-package*)) | |
| 305 | (setf (get ',type-name ':category) ,cat) | |
| 306 | (defun ,type-name () ,type-name) | |
| 307 | #|| | |
| 308 | ;; register to builtin parse dictionary | |
| 309 | (let ((opname ,(string-downcase (format nil "~s" type-name)))) | |
| 310 | (setf (gethash opname *builtin-ast-dict*) | |
| 311 | (mapcar #'(lambda (x) | |
| 312 | (cons ,type-name x)) | |
| 313 | (make-ast-forms opname nil)))) | |
| 314 | ||# | |
| 315 | )) | |
| 316 | ;; | |
| 317 | ` (eval-when (:execute :compile-toplevel :load-toplevel) | |
| 318 | (defparameter,type-name ',type-name) | |
| 319 | (setf (get ',type-name ':chaos-slots) ',slots) | |
| 320 | (setf (get ',type-name ':visible-slots) ',visible) | |
| 321 | (setf (get ',type-name ':category) ,cat) | |
| 322 | ;; the sutructure | |
| 323 | (defstruct (,type-name | |
| 324 | (:conc-name ,structure-conc-name) | |
| 325 | (:constructor ,structure-constructor) | |
| 326 | (:constructor ,boa-constructor ,visible) | |
| 327 | (:copier nil) | |
| 328 | ,@(if (or (eq cat ':ast) | |
| 329 | (eq cat ':chaos-script)) | |
| 330 | (list '(:type list) | |
| 331 | `(:include %chaos-ast (-type ',type-name))) | |
| 332 | (if (memq cat '(:static-object | |
| 333 | :static-int-object)) | |
| 334 | (list ` (:include %chaos-static-object | |
| 335 | (-type ',type-name)) | |
| 336 | #+gcl '(:static t) | |
| 337 | ) | |
| 338 | (list ` (:include ,(if super | |
| 339 | super | |
| 340 | '%chaos-object) | |
| 341 | (-type ',type-name)) | |
| 342 | (if int-printer | |
| 343 | `(:print-function ,int-printer) | |
| 344 | '(:print-function | |
| 345 | chaos-pr-object)) | |
| 346 | ) | |
| 347 | ))) | |
| 348 | ,@own-slots) | |
| 349 | ||
| 350 | ;; predicate | |
| 351 | , (case cat | |
| 352 | ((:ast :chaos-script) | |
| 353 | `(defun ,predicate-name (obj) | |
| 354 | (and (chaos-ast? obj) (eq (ast-type obj) ',type-name)))) | |
| 355 | (otherwise | |
| 356 | ` (setf (symbol-function ',predicate-name) | |
| 357 | (symbol-function ',int-predicate-name)) | |
| 358 | )) | |
| 359 | (setf (get ,type-name ':type-predicate) | |
| 360 | (symbol-function ',predicate-name)) | |
| 361 | ||
| 362 | ;; constructor | |
| 363 | #|| | |
| 364 | ,(when rest-slot | |
| 365 | (let ((arg-list (subst '&rest '&optional visible))) | |
| 366 | ` (defun ,real-constructor ,arg-list | |
| 367 | (,boa-constructor ,@(firstn arg-list (- (length | |
| 368 | arg-list) 2)) | |
| 369 | ,(car (last arg-list)))))) | |
| 370 | ,(if real-constructor | |
| 371 | ` (progn (setf (symbol-function ',type-name) | |
| 372 | (symbol-function ',real-constructor)) | |
| 373 | (setf (symbol-function ',(%make-keyword | |
| 374 | (concatenate 'string | |
| 375 | (string type) | |
| 376 | "*") | |
| 377 | cat)) | |
| 378 | (symbol-function ',boa-constructor))) | |
| 379 | ` (setf (symbol-function ',type-name) | |
| 380 | (symbol-function ',boa-constructor))) | |
| 381 | ||# | |
| 382 | ||
| 383 | ;; evaluator | |
| 384 | (setf (get ',type-name ':eval) ',eval) | |
| 385 | ||
| 386 | , (when (and eval (or (eq cat ':ast) | |
| 387 | (eq cat ':chaos-script))) | |
| 388 | (let ((eval-mac (intern (concatenate | |
| 389 | 'string | |
| 390 | "!" | |
| 391 | (the simple-string | |
| 392 | (string type-name)))))) | |
| 393 | ` (defmacro ,eval-mac (*__ast &optional *__context) | |
| 394 | `(let ((*chaos-eval-context* ,*__context)) | |
| 395 | (eval-ast ,*__ast))))) | |
| 396 | ;; printer | |
| 397 | (setf (get ',type-name ':print) ',print) | |
| 398 | ;; type | |
| 399 | ;; (deftype ,type-name () '(satisfies ,predicate-name)) | |
| 400 | ))))) | |
| 401 | 401 | |
| 402 | 402 | (defmacro defkey (name &key (category ':ast)) |
| 403 | 403 | `(defterm ,name () :keyword t :category ,category)) |
| 409 | 409 | ;;; (cadr (cadr seq))) |
| 410 | 410 | |
| 411 | 411 | #-GCL (defun %is-chaos-term? (ast) |
| 412 | (and (chaos-object? ast) (get (object-type ast) ':category))) | |
| 412 | (and (chaos-object? ast) (get (object-type ast) ':category))) | |
| 413 | 413 | #+GCL |
| 414 | 414 | (si::define-inline-function %is-chaos-term? (ast) |
| 415 | 415 | (and (not (stringp ast)) (chaos-object? ast) (get (object-type ast) ':category))) |
| 0 | 0 | ;;;-*- Mode:LISP; Package: Chaos; Base:10; Syntax:Common-lisp -*- |
| 1 | 1 | ;;; |
| 2 | ;;; Copyright (c) 2000-2014, Toshimi Sawada. All rights reserved. | |
| 2 | ;;; Copyright (c) 2000-2015, Toshimi Sawada. All rights reserved. | |
| 3 | 3 | ;;; |
| 4 | 4 | ;;; Redistribution and use in source and binary forms, with or without |
| 5 | 5 | ;;; modification, are permitted provided that the following conditions |
| 27 | 27 | ;;; |
| 28 | 28 | (in-package :chaos) |
| 29 | 29 | #|============================================================================== |
| 30 | System: Chaos | |
| 31 | Module: primitives | |
| 32 | File: depend.lisp | |
| 30 | System: Chaos | |
| 31 | Module: primitives | |
| 32 | File: depend.lisp | |
| 33 | 33 | ==============================================================================|# |
| 34 | 34 | #-:chaos-debug |
| 35 | 35 | (declaim (optimize (speed 3) (safety 0) #-GCL (debug 0))) |
| 53 | 53 | ;;; ddnode = a ddnode |
| 54 | 54 | ;;; |
| 55 | 55 | (defstruct (ddlink (:print-function (lambda (ddl stream depth) |
| 56 | (declare (ignore depth)) | |
| 57 | (format stream "< ~s : ~s <- ~s >" | |
| 58 | (ddlink-label ddl) | |
| 59 | (ddlink-mode ddl) | |
| 60 | (ddlink-ddnode ddl))))) | |
| 56 | (declare (ignore depth)) | |
| 57 | (format stream "< ~s : ~s <- ~s >" | |
| 58 | (ddlink-label ddl) | |
| 59 | (ddlink-mode ddl) | |
| 60 | (ddlink-ddnode ddl))))) | |
| 61 | 61 | (label nil :type (or null t)) |
| 62 | 62 | (mode nil :type symbol) |
| 63 | 63 | (ddnode nil :type ddnode) |
| 70 | 70 | ;;; ddlinks = a list of ddlinks |
| 71 | 71 | ;;; |
| 72 | 72 | (defstruct (ddclause (:print-function (lambda (ddc stream depth) |
| 73 | (declare (ignore depth)) | |
| 74 | (format stream "~s" (ddclause-id ddc))))) | |
| 73 | (declare (ignore depth)) | |
| 74 | (format stream "~s" (ddclause-id ddc))))) | |
| 75 | 75 | (id nil :type symbol) |
| 76 | 76 | (ddlinks nil :type list) |
| 77 | 77 | ) |
| 83 | 83 | ;;; ddclauses = list of the ddclauses pointing to this node. |
| 84 | 84 | ;;; |
| 85 | 85 | (defstruct (ddnode (:print-function (lambda (ddn stream depth) |
| 86 | (declare (ignore depth)) | |
| 87 | (format stream "( ~s: ~s)" | |
| 88 | (ddnode-id ddn) | |
| 89 | (ddnode-label ddn))))) | |
| 86 | (declare (ignore depth)) | |
| 87 | (format stream "( ~s: ~s)" | |
| 88 | (ddnode-id ddn) | |
| 89 | (ddnode-label ddn))))) | |
| 90 | 90 | (id nil :type top-object) |
| 91 | 91 | (label 'out :type symbol) |
| 92 | 92 | (ddclauses nil :type list) |
| 94 | 94 | |
| 95 | 95 | (defun new-module-node (mod) |
| 96 | 96 | (declare (type top-object mod) |
| 97 | (values ddnode)) | |
| 97 | (values ddnode)) | |
| 98 | 98 | (make-ddnode :id mod)) |
| 99 | 99 | |
| 100 | 100 | (defun get-ddlink (label ddn) |
| 101 | 101 | (declare (type symbol label) |
| 102 | (type ddnode ddn) | |
| 103 | (values ddlink)) | |
| 102 | (type ddnode ddn) | |
| 103 | (values ddlink)) | |
| 104 | 104 | (make-ddlink :label label :ddnode ddn)) |
| 105 | 105 | |
| 106 | 106 | #|| |
| 118 | 118 | ;;; |
| 119 | 119 | (defun label-ddnode (ddn new-label) |
| 120 | 120 | (declare (type ddnode ddn) |
| 121 | (type symbol new-abel) | |
| 122 | (values t)) | |
| 121 | (type symbol new-abel) | |
| 122 | (values t)) | |
| 123 | 123 | (let ((old-label (ddnode-label ddn))) |
| 124 | 124 | (cond ((not (eq old-label new-label)) |
| 125 | (show-ddnode-change ddn | |
| 126 | old-label | |
| 127 | new-label) | |
| 128 | (setf (ddnode-label ddn) new-label))))) | |
| 125 | (show-ddnode-change ddn | |
| 126 | old-label | |
| 127 | new-label) | |
| 128 | (setf (ddnode-label ddn) new-label))))) | |
| 129 | 129 | |
| 130 | 130 | ;;; ATTACH-DDCLAUSE : ddclause -> 'void |
| 131 | 131 | ;;; make all the ddnodes in ddclause point back to ddcualse. |
| 140 | 140 | (defun detach-ddclause (ddc) |
| 141 | 141 | (dolist (ddl (ddclause-ddlinks ddc)) |
| 142 | 142 | (setf (ddnode-ddclauses (ddlink-ddnode ddl)) |
| 143 | (delete ddc (ddnode-ddclauses (ddlink-ddnode ddl)))))) | |
| 143 | (delete ddc (ddnode-ddclauses (ddlink-ddnode ddl)))))) | |
| 144 | 144 | |
| 145 | 145 | ;;; CONTRADICT |
| 146 | 146 | ;;; enter contradicting ddclause into *contradictions* |
| 160 | 160 | ;;; |
| 161 | 161 | (defun prune-contradictions () |
| 162 | 162 | (setq *contradictions* |
| 163 | (delete-if-not #'contradicted-p *contradictions*))) | |
| 163 | (delete-if-not #'contradicted-p *contradictions*))) | |
| 164 | 164 | |
| 165 | 165 | (defun init-module-depg (&optional debug-flag) |
| 166 | 166 | (setq *contradictions* nil) |
| 197 | 197 | ;;; |
| 198 | 198 | (defun contradicted-p (ddc) |
| 199 | 199 | (every #'ddlink-misaligned-p |
| 200 | (ddclause-ddlinks ddc))) | |
| 200 | (ddclause-ddlinks ddc))) | |
| 201 | 201 | |
| 202 | 202 | ;;; MISALIGNED-DDLINKS : ddclause if-all if-all-but-one -> { NIL |
| 203 | 203 | ;;; | value returned by if-all or |
| 209 | 209 | ;;; |
| 210 | 210 | (defun misaligned-ddlinks (ddc if-all if-all-but-noe) |
| 211 | 211 | (let ((non-misaligned-links (remove-if $'ddlink-misaligned-p |
| 212 | (ddclause-ddlinks ddc)))) | |
| 212 | (ddclause-ddlinks ddc)))) | |
| 213 | 213 | (cond ((null non-misaligned-links) |
| 214 | (funcall if-all ddc)) | |
| 215 | ((null (cdr non-misaligend-links)) | |
| 216 | (funcall if-all-but-one ddc | |
| 217 | (car non-misaligned-links))) | |
| 218 | (t nil)))) | |
| 214 | (funcall if-all ddc)) | |
| 215 | ((null (cdr non-misaligend-links)) | |
| 216 | (funcall if-all-but-one ddc | |
| 217 | (car non-misaligned-links))) | |
| 218 | (t nil)))) | |
| 219 | 219 | |
| 220 | 220 | (defun return-t (x &optional y) |
| 221 | 221 | (declare (ignore x y)) |
| 230 | 230 | ;;; |
| 231 | 231 | (defun ddclause-active-ddnode (ddc) |
| 232 | 232 | (misaligned-ddlinks ddc |
| 233 | #'return-nil | |
| 234 | #'(lambda (ddc dl) (declare (ignore ddc)) | |
| 235 | (ddlink-ddnode ddl)))) | |
| 233 | #'return-nil | |
| 234 | #'(lambda (ddc dl) (declare (ignore ddc)) | |
| 235 | (ddlink-ddnode ddl)))) | |
| 236 | 236 | |
| 237 | 237 | ;;; ASSERT-PREMISE ddclause-id label ddnode -> ddclause |
| 238 | 238 | ;;; assert that ddnode has the given label. |
| 245 | 245 | ;;; |
| 246 | 246 | (defun assert-at-least-one (id ddnodes) |
| 247 | 247 | (assert-ddlinks id (mapcan #'(lambda (ddn) (list (get-ddlinks t ddn))) |
| 248 | ddnodes))) | |
| 248 | ddnodes))) | |
| 249 | 249 | |
| 250 | 250 | ;;; ASSERT-AT-MOST-ONE : ddclause-id ddnode-list -> ddclause |
| 251 | 251 | ;;; assert that at most one ddnode is true, i.e., at least one of |
| 253 | 253 | ;;; |
| 254 | 254 | (defun assert-at-most-one (id ddnodes) |
| 255 | 255 | (mapc #'(lambda (ddn1) |
| 256 | (mapc #'(lambda (ddn2) | |
| 257 | (assert-ddlinks id | |
| 258 | (list (get-ddlink nil ddn1) | |
| 259 | (get-ddlink nil ddn2)))) | |
| 260 | (cdr (member ddn1 ddnodes)))) | |
| 261 | ddnodes)) | |
| 256 | (mapc #'(lambda (ddn2) | |
| 257 | (assert-ddlinks id | |
| 258 | (list (get-ddlink nil ddn1) | |
| 259 | (get-ddlink nil ddn2)))) | |
| 260 | (cdr (member ddn1 ddnodes)))) | |
| 261 | ddnodes)) | |
| 262 | 262 | |
| 263 | 263 | ;;; ASSERT-DDLINKS : ddclause-id ddlink-list -> ddclause |
| 264 | 264 | ;;; make a clause of the links and assert it. |
| 287 | 287 | (defun show-ddnode-change (ddn old-label new-label) |
| 288 | 288 | (if *module-dep-debug* |
| 289 | 289 | (format t "~%~s ~s -> ~s" |
| 290 | (ddnode-id ddn) old-label new-label))) | |
| 290 | (ddnode-id ddn) old-label new-label))) | |
| 291 | 291 | |
| 292 | 292 | (defun show-ddnetwork-change (message ddc) |
| 293 | 293 | (if *module-dep-debug* |
| 294 | 294 | (let ((ddlinks (ddclause-ddlinks ddc))) |
| 295 | (format t "~%~a" message) | |
| 296 | (cond (ddlinks | |
| 297 | (show-ddlink (car ddlinks)) | |
| 298 | (mapc #'(lambda (ddl) | |
| 299 | (princ " or ") | |
| 300 | (show-ddlink ddl)) | |
| 301 | (cdr ddlinks))))))) | |
| 295 | (format t "~%~a" message) | |
| 296 | (cond (ddlinks | |
| 297 | (show-ddlink (car ddlinks)) | |
| 298 | (mapc #'(lambda (ddl) | |
| 299 | (princ " or ") | |
| 300 | (show-ddlink ddl)) | |
| 301 | (cdr ddlinks))))))) | |
| 302 | 302 | |
| 303 | 303 | (defun show-ddlink (ddl) |
| 304 | 304 | (format t "~s~s" |
| 305 | (case (ddlink-label ddl) | |
| 306 | ((t) '+) | |
| 307 | ((nil) '-) | |
| 308 | (otherwise '?)) | |
| 309 | (ddnode-id (ddlink-ddnode ddl)))) | |
| 305 | (case (ddlink-label ddl) | |
| 306 | ((t) '+) | |
| 307 | ((nil) '-) | |
| 308 | (otherwise '?)) | |
| 309 | (ddnode-id (ddlink-ddnode ddl)))) | |
| 310 | 310 | |
| 311 | 311 | (defun show-contracitions () |
| 312 | 312 | (cond (*contracictions* |
| 313 | (format t "~% Thre are contradictions.~%~S" *contradictions*) | |
| 314 | (mapc #'(lambda (ddc) | |
| 315 | (format t "~%~S caused by ~S~%" ddc (contradiction-causes ddc))) | |
| 316 | *contradictions*)))) | |
| 313 | (format t "~% Thre are contradictions.~%~S" *contradictions*) | |
| 314 | (mapc #'(lambda (ddc) | |
| 315 | (format t "~%~S caused by ~S~%" ddc (contradiction-causes ddc))) | |
| 316 | *contradictions*)))) | |
| 317 | 317 | |
| 318 | 318 | ;;; PROPAGATE-LABELS : ddclause -> void |
| 319 | 319 | ;;; propagate T and NIL labels to ddclauses's ddnode. |
| 320 | 320 | ;;; |
| 321 | 321 | (defun propagate-labels (ddc) |
| 322 | 322 | (misaligend-ddlinks ddc |
| 323 | #'contradict | |
| 324 | #'align-ddlink)) | |
| 323 | #'contradict | |
| 324 | #'align-ddlink)) | |
| 325 | 325 | |
| 326 | 326 | ;;; ALIGN-DDLINK ddclause ddlink -> void |
| 327 | 327 | ;;; mark the label of ddlink's ddnode agree with ddlink's label, |
| 330 | 330 | (defun align-ddlink (ddc1 ddl) |
| 331 | 331 | (let ((ddn (ddlink-ddnode ddl))) |
| 332 | 332 | (cond ((ddnode-in-p ddn) nil) |
| 333 | (t (label-ddnode ddn (ddlink-label ddl)) | |
| 334 | (dolist (ddc2 (ddnode-ddclauses ddn)) | |
| 335 | (unless (eq ddc1 ddc2) | |
| 336 | (propagate-labels ddc2))))))) | |
| 333 | (t (label-ddnode ddn (ddlink-label ddl)) | |
| 334 | (dolist (ddc2 (ddnode-ddclauses ddn)) | |
| 335 | (unless (eq ddc1 ddc2) | |
| 336 | (propagate-labels ddc2))))))) | |
| 337 | 337 | |
| 338 | 338 | ;;; PROPAGATE-OUT-LABLES : ddclause -> void |
| 339 | 339 | ;;; mark 'OUT those ddnodes that may have been forced to a label by ddclause. |
| 342 | 342 | ;;; |
| 343 | 343 | (defun propagate-out-labels (ddc) |
| 344 | 344 | (misaligned-ddlinks ddc |
| 345 | #'uncontradict | |
| 346 | #'(lambda (ddc1 ddl) | |
| 347 | (dolist (ddc2 (delabel-ddnode (ddlink-ddnode ddl))) | |
| 348 | (propagate-labels ddc2)) | |
| 349 | (prune-contradictions)))) | |
| 345 | #'uncontradict | |
| 346 | #'(lambda (ddc1 ddl) | |
| 347 | (dolist (ddc2 (delabel-ddnode (ddlink-ddnode ddl))) | |
| 348 | (propagate-labels ddc2)) | |
| 349 | (prune-contradictions)))) | |
| 350 | 350 | |
| 351 | 351 | ;;; DELABEL-DDNODE : ddnode -> List[ddclause] |
| 352 | 352 | ;;; delabel all ddnodes that were justfied by this ddnode, and return all ddclauses |
| 356 | 356 | ;;; |
| 357 | 357 | (defun delabel-ddnode (ddn) |
| 358 | 358 | (cond ((ddnode-out-p ddn) nil) |
| 359 | (t (let ((going-out (ddnode-jistificands ddn))) | |
| 360 | (label-ddnode ddn 'out) | |
| 361 | (nconc (mapcan #'(lambda (ddn) | |
| 362 | (delabel-ddnode ddn)) | |
| 363 | going-out) | |
| 364 | (ddnode-justifications ddn)))))) | |
| 359 | (t (let ((going-out (ddnode-jistificands ddn))) | |
| 360 | (label-ddnode ddn 'out) | |
| 361 | (nconc (mapcan #'(lambda (ddn) | |
| 362 | (delabel-ddnode ddn)) | |
| 363 | going-out) | |
| 364 | (ddnode-justifications ddn)))))) | |
| 365 | 365 | |
| 366 | 366 | ;;; DDNODE-JISTIFICATIONS : ddnode -> List[ddclause] |
| 367 | 367 | ;;; return the ddclauses that five ddnode its label. |
| 368 | 368 | ;;; |
| 369 | 369 | (defun ddnode-justifications (ddn) |
| 370 | 370 | (mapcan #'(lambda (ddc) |
| 371 | (if (eq (ddclause-active-ddnode ddc) ddc) | |
| 372 | (list ddc) | |
| 373 | nil)) | |
| 374 | (ddnode-ddclauses ddn))) | |
| 371 | (if (eq (ddclause-active-ddnode ddc) ddc) | |
| 372 | (list ddc) | |
| 373 | nil)) | |
| 374 | (ddnode-ddclauses ddn))) | |
| 375 | 375 | |
| 376 | 376 | ;;; DDNODE-JUSTIFICANTS : ddnode -> List[ddnode] |
| 377 | 377 | ;;; return the ddnodes that were propagated by labels from ddnode. |
| 378 | 378 | ;;; |
| 379 | 379 | (defun ddnode-justificants (ddn1) |
| 380 | 380 | (remove-if-not #'(lambda (ddc) |
| 381 | (let ((ddn2 (ddclause-active-ddnode ddc))) | |
| 382 | (and (not (eq ddn1 ddn2)) ddn2))) | |
| 383 | (ddnode-ddclauses ddn1))) | |
| 381 | (let ((ddn2 (ddclause-active-ddnode ddc))) | |
| 382 | (and (not (eq ddn1 ddn2)) ddn2))) | |
| 383 | (ddnode-ddclauses ddn1))) | |
| 384 | 384 | |
| 385 | 385 | ;;; EOF |
| 0 | 0 | ;;;-*- Mode:LISP; Package: Chaos; Base:10; Syntax:Common-lisp -*- |
| 1 | 1 | ;;; |
| 2 | ;;; Copyright (c) 2000-2014, Toshimi Sawada. All rights reserved. | |
| 2 | ;;; Copyright (c) 2000-2015, Toshimi Sawada. All rights reserved. | |
| 3 | 3 | ;;; |
| 4 | 4 | ;;; Redistribution and use in source and binary forms, with or without |
| 5 | 5 | ;;; modification, are permitted provided that the following conditions |
| 27 | 27 | ;;; |
| 28 | 28 | (in-package :chaos) |
| 29 | 29 | #|============================================================================== |
| 30 | System: Chaos | |
| 31 | Module: primitives | |
| 32 | File: find.lisp | |
| 30 | System: Chaos | |
| 31 | Module: primitives | |
| 32 | File: find.lisp | |
| 33 | 33 | ==============================================================================|# |
| 34 | 34 | #-:chaos-debug |
| 35 | 35 | (declaim (optimize (speed 3) (safety 0) #-GCL (debug 0))) |
| 47 | 47 | (when (and (consp modexp) (null (cdr modexp)) (stringp (car modexp))) |
| 48 | 48 | (setq modexp (car modexp))) |
| 49 | 49 | (when (and (equal modexp "*the-current-module*") |
| 50 | *current-module*) | |
| 50 | *current-module*) | |
| 51 | 51 | (setq modexp *current-module*)) |
| 52 | 52 | (if (module-p modexp) |
| 53 | 53 | modexp |
| 54 | (let ((canon-name (canonicalize-simple-module-name modexp)) | |
| 55 | (mod nil)) | |
| 56 | (declare (type (or simple-string list) canon-name)) | |
| 57 | (if (stringp canon-name) | |
| 58 | (let ((pos (position #\. (the simple-string canon-name) :from-end t))) | |
| 59 | (if pos | |
| 60 | (let ((name (subseq canon-name 0 pos)) | |
| 61 | (qual (subseq canon-name (1+ pos))) | |
| 62 | (context nil)) | |
| 63 | (setf context (find-module-or-error qual)) | |
| 64 | (if (or (null context) (modexp-is-error context)) | |
| 65 | (with-output-chaos-error ('no-such-module) | |
| 66 | (format t "Could not evaluate modexpr ~a, " canon-name) | |
| 67 | (format t " no such module ~a" qual) | |
| 68 | ) | |
| 69 | (setf mod (find-module-in-env name context)))) | |
| 70 | (setq mod (find-module-in-env canon-name)) | |
| 71 | ) | |
| 72 | (if mod | |
| 73 | mod | |
| 74 | (cons :error canon-name))) | |
| 75 | (cons :error canon-name))))) | |
| 54 | (let ((canon-name (canonicalize-simple-module-name modexp)) | |
| 55 | (mod nil)) | |
| 56 | (declare (type (or simple-string list) canon-name)) | |
| 57 | (if (stringp canon-name) | |
| 58 | (let ((pos (position #\. (the simple-string canon-name) :from-end t))) | |
| 59 | (if pos | |
| 60 | (let ((name (subseq canon-name 0 pos)) | |
| 61 | (qual (subseq canon-name (1+ pos))) | |
| 62 | (context nil)) | |
| 63 | (setf context (find-module-or-error qual)) | |
| 64 | (if (or (null context) (modexp-is-error context)) | |
| 65 | (with-output-chaos-error ('no-such-module) | |
| 66 | (format t "Could not evaluate modexpr ~s: " canon-name) | |
| 67 | (when (and qual (not (equal qual ""))) | |
| 68 | (format t "~% no such module ~s" qual))) | |
| 69 | (setf mod (find-module-in-env name context)))) | |
| 70 | (setq mod (find-module-in-env canon-name))) | |
| 71 | (if mod | |
| 72 | mod | |
| 73 | (cons :error canon-name))) | |
| 74 | (cons :error canon-name))))) | |
| 76 | 75 | |
| 77 | 76 | ;;; ************************* |
| 78 | 77 | ;;; GETTING MODULE CONSTRUCTS___________________________________________________ |
| 85 | 84 | (defun sort-name-is-ambiguous (name module) |
| 86 | 85 | (let ((flg nil)) |
| 87 | 86 | (dolist (s (append (module-error-sorts module) |
| 88 | (module-all-sorts module))) | |
| 87 | (module-all-sorts module))) | |
| 89 | 88 | (if (eq name (sort-id s)) |
| 90 | (if flg | |
| 91 | (return-from sort-name-is-ambiguous t) | |
| 92 | (setq flg t)))))) | |
| 89 | (if flg | |
| 90 | (return-from sort-name-is-ambiguous t) | |
| 91 | (setq flg t)))))) | |
| 93 | 92 | |
| 94 | 93 | (defun sort-is-ambiguous (sort module) |
| 95 | 94 | (sort-name-is-ambiguous (sort-id sort) module)) |
| 96 | 95 | |
| 97 | 96 | ;;; FIND-SORTS-IN-MODULE |
| 98 | 97 | |
| 99 | (defun find-sorts-in-module (sort-name &optional (module (or *current-module* | |
| 100 | *last-module*))) | |
| 98 | (defun find-sorts-in-module (sort-name &optional (module (get-context-module))) | |
| 101 | 99 | (declare (type symbol sort-name) |
| 102 | (type module module)) | |
| 100 | (type module module)) | |
| 103 | 101 | (let ((res nil)) |
| 104 | 102 | (dolist (s (module-all-sorts module) res) |
| 105 | 103 | (if (eq sort-name (sort-id s)) |
| 106 | (push s res))))) | |
| 104 | (push s res))))) | |
| 107 | 105 | |
| 108 | 106 | ;;; FIND-SORT |
| 109 | 107 | ;;; |
| 110 | #|| | |
| 111 | (defun find-sort (sort-name-or-name-ref &optional (module (or *current-module* | |
| 112 | *last-module*))) | |
| 113 | (unless module | |
| 114 | (error "Internal error,module is not specified: find-sort")) | |
| 115 | (unless (module-p module) | |
| 116 | (error "Internal error, find-sort: invalid module ~A" module)) | |
| 117 | (let ((sort (get-sort-named sort-name-or-name-ref module))) | |
| 118 | (if sort sort | |
| 119 | (let ((ambig-sorts (find-sorts-in-module sort-name-or-name-ref module))) | |
| 120 | (cond ((= (length ambig-sorts) 1) (car ambig-sorts)) | |
| 121 | ((> (length ambig-sorts) 1) | |
| 122 | (with-output-chaos-warning () | |
| 123 | (princ "sort name ") | |
| 124 | (princ sort-name-or-name-ref) | |
| 125 | (princ " is ambiguous, arbitrary take ") | |
| 126 | (print-chaos-object (setf sort (car (nreverse ambig-sorts)))) | |
| 127 | (princ " as the resolved name.") | |
| 128 | ) | |
| 129 | sort) | |
| 130 | (t (or (get-sort-named sort-name-or-name-ref '*chaos-module*) | |
| 131 | (with-output-chaos-warning () | |
| 132 | (princ "no such sort ") | |
| 133 | (princ sort-name-or-name-ref) | |
| 134 | nil)))))))) | |
| 135 | ||
| 136 | ||# | |
| 137 | 108 | |
| 138 | 109 | ;;; FIND-SORT-IN : Module Sort-Name -> Sort |
| 139 | 110 | ;;; |
| 145 | 116 | (defun check-qualified-sort-name (sn) |
| 146 | 117 | (declare (type t sn)) |
| 147 | 118 | (cond ((%is-sort-ref sn) |
| 148 | (let ((sort-name (%sort-ref-name sn)) | |
| 149 | (context (%sort-ref-qualifier sn))) | |
| 150 | (if context | |
| 151 | (values sort-name context) | |
| 152 | (check-qualified-sort-name sort-name)))) | |
| 153 | ((symbolp sn) (check-qualified-sort-name (string sn))) | |
| 154 | ((stringp sn) | |
| 155 | (let ((pos (position #\. (the simple-string sn)))) | |
| 156 | (declare (type (or null fixnum) pos)) | |
| 157 | (if pos | |
| 158 | (values (subseq (the simple-string sn) 0 pos) | |
| 159 | (subseq (the simple-string sn) (1+ pos))) | |
| 160 | (values sn nil)))) | |
| 161 | ((sort-struct-p sn) | |
| 162 | (check-qualified-sort-name (sort-id sn))) | |
| 163 | ((and (consp sn) (null (cdr sn))) | |
| 164 | (check-qualified-sort-name (car sn))) | |
| 165 | ((and (consp sn) (cdr sn)) | |
| 166 | (values (car sn) (cadr sn))) | |
| 167 | (t nil))) | |
| 119 | (let ((sort-name (%sort-ref-name sn)) | |
| 120 | (context (%sort-ref-qualifier sn))) | |
| 121 | (if context | |
| 122 | (values sort-name context) | |
| 123 | (check-qualified-sort-name sort-name)))) | |
| 124 | ((symbolp sn) (check-qualified-sort-name (string sn))) | |
| 125 | ((stringp sn) | |
| 126 | (let ((pos (position #\. (the simple-string sn)))) | |
| 127 | (declare (type (or null fixnum) pos)) | |
| 128 | (if pos | |
| 129 | (values (subseq (the simple-string sn) 0 pos) | |
| 130 | (subseq (the simple-string sn) (1+ pos))) | |
| 131 | (values sn nil)))) | |
| 132 | ((sort-struct-p sn) | |
| 133 | (check-qualified-sort-name (sort-id sn))) | |
| 134 | ((and (consp sn) (null (cdr sn))) | |
| 135 | (check-qualified-sort-name (car sn))) | |
| 136 | ((and (consp sn) (cdr sn)) | |
| 137 | (values (car sn) (cadr sn))) | |
| 138 | (t nil))) | |
| 168 | 139 | |
| 169 | 140 | (defun find-qual-sort (sort-name &optional (module *current-module*)) |
| 170 | 141 | (find-sort-in module sort-name)) |
| 173 | 144 | |
| 174 | 145 | (defun find-sort-in (module sort-name &optional search-in-mod) |
| 175 | 146 | (declare (type module module) |
| 176 | (type (or sort* symbol string list) sort-name)) | |
| 147 | (type (or sort* symbol string list) sort-name)) | |
| 177 | 148 | (cond ((sort-struct-p sort-name) |
| 178 | (if search-in-mod | |
| 179 | (if (or (memq sort-name (module-all-sorts module)) | |
| 180 | (memq sort-name (module-error-sorts module))) | |
| 181 | (return-from find-sort-in sort-name) | |
| 182 | (return-from find-sort-in nil)) | |
| 183 | ;; else | |
| 184 | (return-from find-sort-in sort-name))) | |
| 185 | (t (multiple-value-bind (sort-id mod-qual) | |
| 186 | (check-qualified-sort-name sort-name) | |
| 187 | (declare (type (or simple-string symbol) sort-id) | |
| 188 | (type (or null modexp) mod-qual)) | |
| 189 | (let ((ss-name (string sort-id))) | |
| 190 | (when (and mod-qual (eql #\? (schar ss-name 0))) | |
| 191 | (let ((ssort (if (equal mod-qual (module-name module)) | |
| 192 | (find-sort-in module (subseq ss-name 1)) | |
| 193 | (let ((cmod (find-module-in-env-ext | |
| 194 | mod-qual module))) | |
| 195 | (if cmod | |
| 196 | (find-sort-in cmod (subseq ss-name 1)) | |
| 197 | nil))))) | |
| 198 | (when ssort | |
| 199 | (return-from find-sort-in | |
| 200 | (the-err-sort ssort (module-sort-order module)))) | |
| 201 | ))) | |
| 202 | (when (stringp sort-id) | |
| 203 | (setf sort-id (intern sort-id))) | |
| 204 | (when (and (not mod-qual) | |
| 205 | t) ; *allow-universal-sort* | |
| 206 | (case sort-id | |
| 207 | ($name-universal | |
| 208 | (return-from find-sort-in *universal-sort*)) | |
| 209 | ($name-huniversal | |
| 210 | (return-from find-sort-in *huniversal-sort*)) | |
| 211 | ($name-cosmos | |
| 212 | (return-from find-sort-in *cosmos*)) | |
| 213 | (otherwise ; do nothing | |
| 214 | nil))) | |
| 215 | ;; | |
| 216 | (if mod-qual | |
| 217 | ;; qualified sort name | |
| 218 | (if (equal mod-qual (module-name module)) | |
| 219 | (find-sort-in module sort-id) | |
| 220 | (let ((cmod (find-module-in-env-ext mod-qual module))) | |
| 221 | (if cmod | |
| 222 | (find-sort-in cmod sort-id) | |
| 223 | nil))) | |
| 224 | ;; else | |
| 225 | (let ((am nil)) | |
| 226 | (dolist (s (module-all-sorts module)) | |
| 227 | (when (eq sort-id (sort-id s)) | |
| 228 | (push s am))) | |
| 229 | (if (cdr am) | |
| 230 | (progn | |
| 231 | (with-output-chaos-error ('ambiguous-sort-name) | |
| 232 | (princ "in module ") | |
| 233 | (print-chaos-object module) | |
| 234 | ;; (break "...") | |
| 235 | (format t ", sort name ~a is ambiguous:" | |
| 236 | (string sort-id)) | |
| 237 | (setq am (reverse am)) | |
| 238 | (dotimes (x (length am)) | |
| 239 | (format t "~&(~d) " (1+ x)) | |
| 240 | (print-chaos-object (nth x am)) | |
| 241 | (when *on-debug* | |
| 242 | (let ((*print-array* nil) | |
| 243 | (*print-circle* nil)) | |
| 244 | (print-next) | |
| 245 | (format t "sort = ~a" (nth x am)) | |
| 246 | (print-next) | |
| 247 | (format t "module = ~a" (sort-module (nth x am))) ))))) | |
| 248 | ;; else | |
| 249 | (if am | |
| 250 | (car am) | |
| 251 | ;; else | |
| 252 | (find-error-sort-in module sort-id))))))))) | |
| 149 | (if search-in-mod | |
| 150 | (if (or (memq sort-name (module-all-sorts module)) | |
| 151 | (memq sort-name (module-error-sorts module))) | |
| 152 | (return-from find-sort-in sort-name) | |
| 153 | (return-from find-sort-in nil)) | |
| 154 | ;; else | |
| 155 | (return-from find-sort-in sort-name))) | |
| 156 | (t (multiple-value-bind (sort-id mod-qual) | |
| 157 | (check-qualified-sort-name sort-name) | |
| 158 | (declare (type (or simple-string symbol) sort-id) | |
| 159 | (type (or null modexp) mod-qual)) | |
| 160 | (let ((ss-name (string sort-id))) | |
| 161 | (when (and mod-qual (eql #\? (schar ss-name 0))) | |
| 162 | (let ((ssort (if (equal mod-qual (module-name module)) | |
| 163 | (find-sort-in module (subseq ss-name 1)) | |
| 164 | (let ((cmod (find-module-in-env-ext | |
| 165 | mod-qual module))) | |
| 166 | (if cmod | |
| 167 | (find-sort-in cmod (subseq ss-name 1)) | |
| 168 | nil))))) | |
| 169 | (when ssort | |
| 170 | (return-from find-sort-in | |
| 171 | (the-err-sort ssort (module-sort-order module)))) | |
| 172 | ))) | |
| 173 | (when (stringp sort-id) | |
| 174 | (setf sort-id (intern sort-id))) | |
| 175 | (when (and (not mod-qual) | |
| 176 | t) ; *allow-universal-sort* | |
| 177 | (case sort-id | |
| 178 | ($name-universal | |
| 179 | (return-from find-sort-in *universal-sort*)) | |
| 180 | ($name-huniversal | |
| 181 | (return-from find-sort-in *huniversal-sort*)) | |
| 182 | ($name-cosmos | |
| 183 | (return-from find-sort-in *cosmos*)) | |
| 184 | (otherwise ; do nothing | |
| 185 | nil))) | |
| 186 | ;; | |
| 187 | (if mod-qual | |
| 188 | ;; qualified sort name | |
| 189 | (if (equal mod-qual (module-name module)) | |
| 190 | (find-sort-in module sort-id) | |
| 191 | (let ((cmod (find-module-in-env-ext mod-qual module))) | |
| 192 | (if cmod | |
| 193 | (find-sort-in cmod sort-id) | |
| 194 | nil))) | |
| 195 | ;; else | |
| 196 | (let ((am nil)) | |
| 197 | (dolist (s (module-all-sorts module)) | |
| 198 | (when (eq sort-id (sort-id s)) | |
| 199 | (push s am))) | |
| 200 | (if (cdr am) | |
| 201 | (progn | |
| 202 | (with-output-chaos-error ('ambiguous-sort-name) | |
| 203 | (princ "in module ") | |
| 204 | (print-chaos-object module) | |
| 205 | ;; (break "...") | |
| 206 | (format t ", sort name ~a is ambiguous:" | |
| 207 | (string sort-id)) | |
| 208 | (setq am (reverse am)) | |
| 209 | (dotimes (x (length am)) | |
| 210 | (format t "~&(~d) " (1+ x)) | |
| 211 | (print-chaos-object (nth x am)) | |
| 212 | (when *on-debug* | |
| 213 | (let ((*print-array* nil) | |
| 214 | (*print-circle* nil)) | |
| 215 | (print-next) | |
| 216 | (format t "sort = ~a" (nth x am)) | |
| 217 | (print-next) | |
| 218 | (format t "module = ~a" (sort-module (nth x am))) ))))) | |
| 219 | ;; else | |
| 220 | (if am | |
| 221 | (car am) | |
| 222 | ;; else | |
| 223 | (find-error-sort-in module sort-id))))))))) | |
| 253 | 224 | |
| 254 | 225 | (defun find-error-sort-in (module sort-name) |
| 255 | 226 | (declare (type module module) |
| 256 | (type (or simple-string symbol) sort-name)) | |
| 227 | (type (or simple-string symbol) sort-name)) | |
| 257 | 228 | (let ((err-sort-name (string sort-name)) |
| 258 | (sort nil)) | |
| 229 | (sort nil)) | |
| 259 | 230 | (if (eql #\? (schar err-sort-name 0)) |
| 260 | (let ((sub-sort-name (subseq err-sort-name 1))) | |
| 261 | (dolist (sn (parse-with-delimiter sub-sort-name #\+)) | |
| 262 | ;; FIX ME this is not complete | |
| 263 | (setq sort | |
| 264 | (find-sort-in module sn)) | |
| 265 | (when sort (return))) | |
| 266 | (if sort | |
| 267 | (the-err-sort sort (module-sort-order module)))) | |
| 231 | (let ((sub-sort-name (subseq err-sort-name 1))) | |
| 232 | (dolist (sn (parse-with-delimiter sub-sort-name #\+)) | |
| 233 | ;; FIX ME this is not complete | |
| 234 | (setq sort | |
| 235 | (find-sort-in module sn)) | |
| 236 | (when sort (return))) | |
| 237 | (if sort | |
| 238 | (the-err-sort sort (module-sort-order module)))) | |
| 268 | 239 | nil |
| 269 | 240 | ))) |
| 270 | ||
| 241 | ||
| 271 | 242 | |
| 272 | 243 | (defun find-all-sorts-in (module sort-name) |
| 273 | 244 | (declare (type module module) |
| 274 | (type (or sort* symbol string list) sort-name)) | |
| 245 | (type (or sort* symbol string list) sort-name)) | |
| 275 | 246 | (when (sort-struct-p sort-name) |
| 276 | 247 | (return-from find-all-sorts-in (list sort-name))) |
| 277 | 248 | (multiple-value-bind (sort-id mod-qual) |
| 278 | 249 | (check-qualified-sort-name sort-name) |
| 279 | 250 | (declare (type (or simple-string symbol) sort-id) |
| 280 | (type (or null modexp) mod-qual)) | |
| 251 | (type (or null modexp) mod-qual)) | |
| 281 | 252 | (when (stringp sort-id) |
| 282 | 253 | (setf sort-id (intern sort-id))) |
| 283 | 254 | (let ((res nil)) |
| 284 | 255 | (if mod-qual |
| 285 | (if (equal mod-qual (module-name module)) | |
| 286 | (setq res (find-sort-in module sort-id)) | |
| 287 | (let ((cmod (find-module-in-env-ext mod-qual module))) | |
| 288 | (setq res (find-sort-in cmod sort-id)))) | |
| 289 | (progn | |
| 290 | (dolist (s (module-all-sorts module)) | |
| 291 | (when (eq sort-id (sort-id s)) | |
| 292 | (push s res))) | |
| 293 | (unless res | |
| 294 | (setq res (find-error-sort-in module sort-id))))) | |
| 256 | (if (equal mod-qual (module-name module)) | |
| 257 | (setq res (find-sort-in module sort-id)) | |
| 258 | (let ((cmod (find-module-in-env-ext mod-qual module))) | |
| 259 | (setq res (find-sort-in cmod sort-id)))) | |
| 260 | (progn | |
| 261 | (dolist (s (module-all-sorts module)) | |
| 262 | (when (eq sort-id (sort-id s)) | |
| 263 | (push s res))) | |
| 264 | (unless res | |
| 265 | (setq res (find-error-sort-in module sort-id))))) | |
| 295 | 266 | (when (and res (atom res)) |
| 296 | (setq res (list res))) | |
| 267 | (setq res (list res))) | |
| 297 | 268 | res))) |
| 298 | 269 | |
| 299 | 270 | ;;; FIND-SORT-IN-KEEP |
| 300 | 271 | ;;; |
| 301 | 272 | (defun find-sort-in-keep (module sort) |
| 302 | 273 | (declare (type module module) |
| 303 | (type sort* sort)) | |
| 274 | (type sort* sort)) | |
| 304 | 275 | (if (member sort (module-sorts module) :test #'eq) |
| 305 | 276 | sort |
| 306 | 277 | (find-sort-in module (sort-id sort)))) |
| 307 | 278 | |
| 308 | 279 | (defun find-sorts-in-keep (module sort-list) |
| 309 | 280 | (declare (type module module) |
| 310 | (type list sort-list)) | |
| 281 | (type list sort-list)) | |
| 311 | 282 | (mapcar #'(lambda (s) (find-sort-in-keep module s)) sort-list) ) |
| 312 | 283 | |
| 313 | 284 | (defun simple-find-sort-in-local (module sort-id) |
| 314 | 285 | (declare (type module module) |
| 315 | (type symbol sort-id)) | |
| 286 | (type symbol sort-id)) | |
| 316 | 287 | (dolist (sort (module-sorts module)) |
| 317 | 288 | (when (eq sort-id (sort-id sort)) |
| 318 | 289 | (return-from simple-find-sort-in-local sort)))) |
| 322 | 293 | (defun find-module-error-sorts (module) |
| 323 | 294 | (declare (type module module)) |
| 324 | 295 | (let ((error-sorts nil) |
| 325 | (so (module-sort-order module))) | |
| 296 | (so (module-sort-order module))) | |
| 326 | 297 | (declare (type sort-order so)) |
| 327 | 298 | (dolist (s (module-all-sorts module)) |
| 328 | 299 | (declare (type sort* s)) |
| 329 | 300 | (unless (memq (sort-module s) *kernel-hard-wired-builtin-modules*) |
| 330 | (let ((es (the-err-sort s so))) | |
| 331 | (when (err-sort-p es) | |
| 332 | (pushnew es error-sorts))))) | |
| 301 | (let ((es (the-err-sort s so))) | |
| 302 | (when (err-sort-p es) | |
| 303 | (pushnew es error-sorts))))) | |
| 333 | 304 | error-sorts)) |
| 334 | 305 | |
| 335 | 306 | (defun get-module-top-sorts (module) |
| 336 | 307 | (declare (type module module)) |
| 337 | 308 | (let ((res nil) |
| 338 | (sorts (module-all-sorts module))) | |
| 309 | (sorts (module-all-sorts module))) | |
| 339 | 310 | (dolist (sort (maximal-sorts sorts (module-sort-order module))) |
| 340 | 311 | (declare (type sort* sort)) |
| 341 | 312 | (when (not (or (err-sort-p sort) |
| 342 | (memq (sort-module sort) | |
| 343 | *kernel-hard-wired-builtin-modules*))) | |
| 344 | (push sort res))) | |
| 313 | (memq (sort-module sort) | |
| 314 | *kernel-hard-wired-builtin-modules*))) | |
| 315 | (push sort res))) | |
| 345 | 316 | res)) |
| 346 | 317 | |
| 347 | 318 | ;;; FINDING OPERATOR/MEHTOD ____________________________________________________ |
| 349 | 320 | |
| 350 | 321 | (defun operator-name-is-ambiguous (symbol module) |
| 351 | 322 | (declare (type (or symbol list) symbol) |
| 352 | (type module module)) | |
| 323 | (type module module)) | |
| 353 | 324 | (when (atom symbol) (setq symbol (list symbol))) |
| 354 | 325 | (let ((num 0)) |
| 355 | 326 | (declare (type fixnum num)) |
| 356 | 327 | (dolist (opinfo (module-all-operators module)) |
| 357 | 328 | (when (equal symbol (operator-symbol (opinfo-operator opinfo))) |
| 358 | (incf num))) | |
| 329 | (incf num))) | |
| 359 | 330 | (if (< 1 num) |
| 360 | t | |
| 361 | nil))) | |
| 331 | t | |
| 332 | nil))) | |
| 362 | 333 | |
| 363 | 334 | (defun filter-ops-with-type (opinfos type) |
| 364 | 335 | (declare (type list opinfos) |
| 365 | (type symbol type)) | |
| 336 | (type symbol type)) | |
| 366 | 337 | (let ((res nil)) |
| 367 | 338 | (dolist (opinfo opinfos) |
| 368 | 339 | (let ((meth0 (car (opinfo-methods opinfo)))) |
| 369 | (case type | |
| 370 | (:functional | |
| 371 | (unless (method-is-behavioural meth0) | |
| 372 | (push opinfo res))) | |
| 373 | (t (when (method-is-behavioural meth0) | |
| 374 | (push opinfo res)))))) | |
| 340 | (case type | |
| 341 | (:functional | |
| 342 | (unless (method-is-behavioural meth0) | |
| 343 | (push opinfo res))) | |
| 344 | (t (when (method-is-behavioural meth0) | |
| 345 | (push opinfo res)))))) | |
| 375 | 346 | (nreverse res))) |
| 376 | ||
| 377 | ;;; *NOTE* not used now..... | |
| 378 | #| | |
| 379 | (defun simple-find-operator (operator-symbol num-args module-id) | |
| 380 | (if (module-p module-id) | |
| 381 | (setf module-id (module-name module-id))) | |
| 382 | (get-operator-unique (list operator-symbol module-id) num-args)) | |
| 383 | |# | |
| 384 | 347 | |
| 385 | 348 | (defun match-op-symbol (sym1 sym2) |
| 386 | 349 | (let ((s1 sym1) |
| 387 | (s2 sym2)) | |
| 350 | (s2 sym2)) | |
| 388 | 351 | (loop |
| 389 | (unless s2 | |
| 390 | (return-from match-op-symbol nil)) | |
| 391 | (unless (equal (car s1) (car s2)) | |
| 392 | (if (equal (car s2) "_") | |
| 393 | (return-from match-op-symbol | |
| 394 | (match-op-symbol s1 (cdr s2))) | |
| 395 | (return-from match-op-symbol nil))) | |
| 352 | (unless s2 | |
| 353 | (return-from match-op-symbol nil)) | |
| 354 | (unless (equal (car s1) (car s2)) | |
| 355 | (if (equal (car s2) "_") | |
| 356 | (return-from match-op-symbol | |
| 357 | (match-op-symbol s1 (cdr s2))) | |
| 358 | (return-from match-op-symbol nil))) | |
| 396 | 359 | (setf s1 (cdr s1) |
| 397 | s2 (cdr s2)) | |
| 360 | s2 (cdr s2)) | |
| 398 | 361 | (unless s1 (return-from match-op-symbol t)) |
| 399 | 362 | ))) |
| 400 | 363 | |
| 403 | 366 | ;;; operator-symbol must of a string or list of string (token seq). |
| 404 | 367 | ;;; |
| 405 | 368 | (defun find-operators-in-module (operator-symbol num-args module |
| 406 | &optional | |
| 407 | type | |
| 408 | allow-match) | |
| 369 | &optional | |
| 370 | type | |
| 371 | allow-match) | |
| 409 | 372 | (declare (type (or symbol string list) operator-symbol) |
| 410 | (type fixnum num-args) | |
| 411 | (type (or module modexp) module) | |
| 412 | (type symbol type)) | |
| 373 | (type fixnum num-args) | |
| 374 | (type (or module modexp) module) | |
| 375 | (type symbol type)) | |
| 413 | 376 | (when (atom operator-symbol) (setf operator-symbol (list operator-symbol))) |
| 414 | 377 | (let ((mod (if (module-p module) |
| 415 | module | |
| 416 | (find-module-in-env-ext module))) | |
| 417 | (name (cons operator-symbol num-args)) | |
| 418 | (res nil)) | |
| 378 | module | |
| 379 | (find-module-in-env-ext module))) | |
| 380 | (name (cons operator-symbol num-args)) | |
| 381 | (res nil)) | |
| 419 | 382 | (unless mod (error "Panic! no such module ~s" module)) |
| 420 | 383 | (dolist (opinfo (module-all-operators (the module mod))) |
| 421 | 384 | (if allow-match |
| 422 | (when (match-op-symbol name | |
| 423 | (operator-name (opinfo-operator opinfo))) | |
| 424 | (push opinfo res)) | |
| 425 | (when (equal name (operator-name (opinfo-operator opinfo))) | |
| 426 | (push opinfo res)))) | |
| 385 | (when (match-op-symbol name | |
| 386 | (operator-name (opinfo-operator opinfo))) | |
| 387 | (push opinfo res)) | |
| 388 | (when (equal name (operator-name (opinfo-operator opinfo))) | |
| 389 | (push opinfo res)))) | |
| 427 | 390 | ;; |
| 428 | 391 | (when type |
| 429 | 392 | (setq res (filter-ops-with-type res type))) |
| 433 | 396 | ;;; operator-symbol must be a string or list of string (tokens). |
| 434 | 397 | ;;; |
| 435 | 398 | (defun find-operators-in-module-no-number (operator-symbol module |
| 436 | &optional | |
| 437 | type | |
| 438 | allow-match) | |
| 399 | &optional | |
| 400 | type | |
| 401 | allow-match) | |
| 439 | 402 | (when (atom operator-symbol) (setf operator-symbol (list operator-symbol))) |
| 440 | 403 | (let ((mod (if (module-p module) module |
| 441 | (find-module-in-env-ext module))) | |
| 442 | (res nil)) | |
| 404 | (find-module-in-env-ext module))) | |
| 405 | (res nil)) | |
| 443 | 406 | (unless mod (error "Panic! no such module ~s" module)) |
| 444 | 407 | (dolist (opinfo (module-all-operators mod) res) |
| 445 | 408 | (if allow-match |
| 446 | (when (match-op-symbol operator-symbol | |
| 447 | (operator-symbol (opinfo-operator opinfo))) | |
| 448 | (push opinfo res)) | |
| 449 | (when (equal operator-symbol (operator-symbol | |
| 450 | (opinfo-operator opinfo))) | |
| 451 | (push opinfo res))) | |
| 409 | (when (match-op-symbol operator-symbol | |
| 410 | (operator-symbol (opinfo-operator opinfo))) | |
| 411 | (push opinfo res)) | |
| 412 | (when (equal operator-symbol (operator-symbol | |
| 413 | (opinfo-operator opinfo))) | |
| 414 | (push opinfo res))) | |
| 452 | 415 | ) |
| 453 | 416 | ;; |
| 454 | 417 | (when type |
| 458 | 421 | ;;; FIND-OPERATOR : name number-of-arguments module -> OpInfo |
| 459 | 422 | ;;; |
| 460 | 423 | (defun find-operator (op-name &optional |
| 461 | (num-args nil) | |
| 462 | (module nil) | |
| 463 | (type nil)) | |
| 424 | (num-args nil) | |
| 425 | (module nil) | |
| 426 | (type nil)) | |
| 464 | 427 | (declare (type (or symbol list) op-name) |
| 465 | (type (or null fixnum) num-args) | |
| 466 | (type symbol type)) | |
| 428 | (type (or null fixnum) num-args) | |
| 429 | (type symbol type)) | |
| 467 | 430 | (if num-args |
| 468 | 431 | (let ((opinfos (find-operators-in-module op-name num-args module type))) |
| 469 | (unless (cdr opinfos) | |
| 470 | (return-from find-operator (car opinfos))) | |
| 471 | (with-output-chaos-warning () | |
| 472 | (format t "operator name ~a is ambiguous," op-name) | |
| 473 | (print-next) | |
| 474 | (princ "qualify it by module name or sort-name")) | |
| 475 | nil) | |
| 432 | (unless (cdr opinfos) | |
| 433 | (return-from find-operator (car opinfos))) | |
| 434 | (with-output-chaos-warning () | |
| 435 | (format t "operator name ~a is ambiguous," op-name) | |
| 436 | (print-next) | |
| 437 | (princ "qualify it by module name or sort-name")) | |
| 438 | nil) | |
| 476 | 439 | (let ((opinfos (find-operators-in-module-no-number op-name module type))) |
| 477 | (if (cdr opinfos) | |
| 478 | (progn | |
| 479 | (with-output-chaos-warning () | |
| 480 | (format t "operator name ~a is ambiguous," op-name) | |
| 481 | (print-next) | |
| 482 | (princ " specify the number of arguments or qualify it.")) | |
| 483 | (return-from find-operator nil)) | |
| 484 | (car opinfos))))) | |
| 440 | (if (cdr opinfos) | |
| 441 | (progn | |
| 442 | (with-output-chaos-warning () | |
| 443 | (format t "operator name ~a is ambiguous," op-name) | |
| 444 | (print-next) | |
| 445 | (princ " specify the number of arguments or qualify it.")) | |
| 446 | (return-from find-operator nil)) | |
| 447 | (car opinfos))))) | |
| 485 | 448 | |
| 486 | 449 | ;;; |
| 487 | 450 | (defun implode-op-ref (name) |
| 488 | 451 | (declare (type list name)) |
| 489 | 452 | (let ((num nil) |
| 490 | (op-id nil)) | |
| 453 | (op-id nil)) | |
| 491 | 454 | (cond ((cdr name) |
| 492 | (cond ((equal "/" (nth (- (length name) 2) name)) | |
| 493 | (setf num (parse-integer (car (last name)) :junk-allowed t)) | |
| 494 | (if (and (integerp num) (<= 0 (the fixnum num))) | |
| 495 | (setf op-id | |
| 496 | (butlast (butlast name)) | |
| 497 | ) | |
| 498 | (progn (setf op-id name) | |
| 499 | (setf num nil) | |
| 500 | (when (member "_" name :test #'equal) | |
| 501 | (setf num 0) | |
| 502 | (dolist (n name) | |
| 503 | (if (equal n "_") | |
| 504 | (incf (the fixnum num) 1))))))) | |
| 505 | (t (let ((pos (position #\/ (the simple-string (car (last name))) | |
| 506 | :from-end t))) | |
| 507 | (if pos | |
| 508 | (progn | |
| 509 | (setf num (parse-integer (subseq (the simple-string | |
| 510 | (car (last name))) | |
| 511 | (1+ pos)) | |
| 512 | :junk-allowed t)) | |
| 513 | (if (and (integerp num) (<= 0 (the fixnum num))) | |
| 514 | (setf op-id | |
| 515 | (append (butlast name) | |
| 516 | (subseq (the simple-string | |
| 517 | (car (last name))) | |
| 518 | 0 pos))) | |
| 519 | (progn | |
| 520 | (setf op-id name) | |
| 521 | (setf num nil) | |
| 522 | (when (member "_" name :test #'equal) | |
| 523 | (setf num 0) | |
| 524 | (dolist (n name) | |
| 525 | (if (equal n "_") | |
| 526 | (incf (the fixnum num) 1))))))) | |
| 527 | (progn | |
| 528 | (setf op-id name) | |
| 529 | (setf num nil) | |
| 530 | (when (member "_" name :test #'equal) | |
| 531 | (setf num 0) | |
| 532 | (dolist (n name) | |
| 533 | (if (equal n "_") | |
| 534 | (incf (the fixnum num) 1)))))))))) | |
| 535 | (t (let ((pos (position #\/ | |
| 536 | (the simple-string | |
| 537 | (car name)) | |
| 538 | :from-end t))) | |
| 539 | (if pos | |
| 540 | (progn | |
| 541 | (setf num (parse-integer (subseq (the simple-string (car name)) | |
| 542 | (1+ pos)) | |
| 543 | :junk-allowed t)) | |
| 544 | (if (and (integerp num) (<= 0 (the fixnum num))) | |
| 545 | (setf op-id | |
| 546 | (list (subseq (the simple-string (car name)) | |
| 547 | 0 pos))) | |
| 548 | (progn | |
| 549 | (setf op-id name) | |
| 550 | (setf num nil)))) | |
| 551 | (progn | |
| 552 | (setf num nil) | |
| 553 | (setf op-id name)) | |
| 554 | )))) | |
| 455 | (cond ((equal "/" (nth (- (length name) 2) name)) | |
| 456 | (setf num (parse-integer (car (last name)) :junk-allowed t)) | |
| 457 | (if (and (integerp num) (<= 0 (the fixnum num))) | |
| 458 | (setf op-id | |
| 459 | (butlast (butlast name)) | |
| 460 | ) | |
| 461 | (progn (setf op-id name) | |
| 462 | (setf num nil) | |
| 463 | (when (member "_" name :test #'equal) | |
| 464 | (setf num 0) | |
| 465 | (dolist (n name) | |
| 466 | (if (equal n "_") | |
| 467 | (incf (the fixnum num) 1))))))) | |
| 468 | (t (let ((pos (position #\/ (the simple-string (car (last name))) | |
| 469 | :from-end t))) | |
| 470 | (if pos | |
| 471 | (progn | |
| 472 | (setf num (parse-integer (subseq (the simple-string | |
| 473 | (car (last name))) | |
| 474 | (1+ pos)) | |
| 475 | :junk-allowed t)) | |
| 476 | (if (and (integerp num) (<= 0 (the fixnum num))) | |
| 477 | (setf op-id | |
| 478 | (append (butlast name) | |
| 479 | (subseq (the simple-string | |
| 480 | (car (last name))) | |
| 481 | 0 pos))) | |
| 482 | (progn | |
| 483 | (setf op-id name) | |
| 484 | (setf num nil) | |
| 485 | (when (member "_" name :test #'equal) | |
| 486 | (setf num 0) | |
| 487 | (dolist (n name) | |
| 488 | (if (equal n "_") | |
| 489 | (incf (the fixnum num) 1))))))) | |
| 490 | (progn | |
| 491 | (setf op-id name) | |
| 492 | (setf num nil) | |
| 493 | (when (member "_" name :test #'equal) | |
| 494 | (setf num 0) | |
| 495 | (dolist (n name) | |
| 496 | (if (equal n "_") | |
| 497 | (incf (the fixnum num) 1)))))))))) | |
| 498 | (t (let ((pos (position #\/ | |
| 499 | (the simple-string | |
| 500 | (car name)) | |
| 501 | :from-end t))) | |
| 502 | (if pos | |
| 503 | (progn | |
| 504 | (setf num (parse-integer (subseq (the simple-string (car name)) | |
| 505 | (1+ pos)) | |
| 506 | :junk-allowed t)) | |
| 507 | (if (and (integerp num) (<= 0 (the fixnum num))) | |
| 508 | (setf op-id | |
| 509 | (list (subseq (the simple-string (car name)) | |
| 510 | 0 pos))) | |
| 511 | (progn | |
| 512 | (setf op-id name) | |
| 513 | (setf num nil)))) | |
| 514 | (progn | |
| 515 | (setf num nil) | |
| 516 | (setf op-id name)) | |
| 517 | )))) | |
| 555 | 518 | (values op-id num))) |
| 556 | 519 | |
| 557 | 520 | ;;; FIND-QUAL-OPERATOR-IN : module name number-of-arguments -> { OpInfo | nil } |
| 559 | 522 | ;;; |
| 560 | 523 | (defun find-qual-operator-in (module name &optional num-args type) |
| 561 | 524 | (declare (type module module) |
| 562 | (type list name) | |
| 563 | (type (or null fixnum) num-args) | |
| 564 | (type symbol type)) | |
| 565 | (unless num-args | |
| 566 | (multiple-value-bind (nam n-args) | |
| 567 | (implode-op-ref name) | |
| 568 | (if (and nam n-args) | |
| 569 | (setf name nam | |
| 570 | num-args n-args)))) | |
| 571 | (find-operator name num-args module type)) | |
| 572 | ||
| 573 | ;;; FIND-ALL-QUAL-OPERATORS-IN : module name number-of-args -> List[OpInfo] | |
| 574 | ;;; | |
| 575 | (defun find-all-qual-operators-in (module name &optional num-args type) | |
| 576 | (declare (type module module) | |
| 577 | (type list name) | |
| 578 | (type (or null fixnum) num-args) | |
| 579 | (type symbol type)) | |
| 525 | (type list name) | |
| 526 | (type (or null fixnum) num-args) | |
| 527 | (type symbol type)) | |
| 580 | 528 | (unless num-args |
| 581 | 529 | (multiple-value-bind (nam n-args) |
| 582 | 530 | (implode-op-ref name) |
| 583 | 531 | (if (and nam n-args) |
| 584 | (setf name nam | |
| 585 | num-args n-args)))) | |
| 532 | (setf name nam | |
| 533 | num-args n-args)))) | |
| 534 | (find-operator name num-args module type)) | |
| 535 | ||
| 536 | ;;; FIND-ALL-QUAL-OPERATORS-IN : module name number-of-args -> List[OpInfo] | |
| 537 | ;;; | |
| 538 | (defun find-all-qual-operators-in (module name &optional num-args type) | |
| 539 | (declare (type module module) | |
| 540 | (type list name) | |
| 541 | (type (or null fixnum) num-args) | |
| 542 | (type symbol type)) | |
| 543 | (unless num-args | |
| 544 | (multiple-value-bind (nam n-args) | |
| 545 | (implode-op-ref name) | |
| 546 | (if (and nam n-args) | |
| 547 | (setf name nam | |
| 548 | num-args n-args)))) | |
| 586 | 549 | (if num-args |
| 587 | 550 | (find-operators-in-module name num-args module type) |
| 588 | 551 | (find-operators-in-module-no-number name module type))) |
| 591 | 554 | ;;; |
| 592 | 555 | (defun find-operators-num-args (module num-args &optional type) |
| 593 | 556 | (declare (type module module) |
| 594 | (type fixnum num-args) | |
| 595 | (type symbol type)) | |
| 557 | (type fixnum num-args) | |
| 558 | (type symbol type)) | |
| 596 | 559 | (let ((res nil)) |
| 597 | 560 | (dolist (opinfo (module-all-operators module)) |
| 598 | 561 | (if (= num-args (the fixnum (operator-num-args (opinfo-operator opinfo)))) |
| 599 | (push opinfo res))) | |
| 562 | (push opinfo res))) | |
| 600 | 563 | (when type |
| 601 | 564 | (setq res (filter-ops-with-type res type))) |
| 602 | 565 | ;; |
| 608 | 571 | ;;; |
| 609 | 572 | (defun find-method-in (module op-name arity coarity) |
| 610 | 573 | (declare (type module module) |
| 611 | (type list arity) | |
| 612 | (type (or list string) op-name) | |
| 613 | (type sort* coarity)) | |
| 574 | (type list arity) | |
| 575 | (type (or list string) op-name) | |
| 576 | (type sort* coarity)) | |
| 614 | 577 | (let ((len (length arity))) |
| 615 | 578 | (declare (type fixnum len)) |
| 616 | 579 | (dolist (opinfo (find-operators-in-module op-name len module) nil) |
| 617 | 580 | (dolist (meth (opinfo-methods opinfo)) |
| 618 | (if (and (sort= coarity (method-coarity meth)) | |
| 619 | (= len (the fixnum (length (method-arity meth)))) | |
| 620 | (every #'(lambda (x y) (sort= x y)) | |
| 621 | arity (method-arity meth))) | |
| 622 | (return-from find-method-in meth)))))) | |
| 581 | (if (and (sort= coarity (method-coarity meth)) | |
| 582 | (= len (the fixnum (length (method-arity meth)))) | |
| 583 | (every #'(lambda (x y) (sort= x y)) | |
| 584 | arity (method-arity meth))) | |
| 585 | (return-from find-method-in meth)))))) | |
| 623 | 586 | |
| 624 | 587 | ;;; FIND-BUILTIN-METHOD-IN module sort op-name |
| 625 | 588 | ;;; |
| 626 | 589 | (defun find-builtin-method-in (module sort op-name) |
| 627 | 590 | (declare (type module module) |
| 628 | (type sort* sort) | |
| 629 | (type t op-name)) | |
| 591 | (type sort* sort) | |
| 592 | (type t op-name)) | |
| 630 | 593 | (if (null (cdr op-name)) |
| 631 | 594 | (let ((sort-info (bsort-info sort))) |
| 632 | (when sort-info | |
| 633 | (let ((opnm (car op-name))) | |
| 634 | (if (funcall (car sort-info) opnm) ; token predicate | |
| 635 | (make-bconst-term sort opnm) | |
| 636 | (with-in-module (module) | |
| 637 | (let ((srt nil)) | |
| 638 | (dolist (x (subsorts sort)) | |
| 639 | (let ((si nil)) | |
| 640 | (when (and (sort-is-builtin sort) | |
| 641 | (setf si (bsort-info sort)) | |
| 642 | (or (null srt) | |
| 643 | (sort< x srt)) | |
| 644 | (funcall (car si) opnm)) | |
| 645 | (setq srt x)))) | |
| 646 | (if srt | |
| 647 | (make-bconst-term srt opnm) | |
| 648 | nil) | |
| 649 | )))))) | |
| 595 | (when sort-info | |
| 596 | (let ((opnm (car op-name))) | |
| 597 | (if (funcall (car sort-info) opnm) ; token predicate | |
| 598 | (make-bconst-term sort opnm) | |
| 599 | (with-in-module (module) | |
| 600 | (let ((srt nil)) | |
| 601 | (dolist (x (subsorts sort)) | |
| 602 | (let ((si nil)) | |
| 603 | (when (and (sort-is-builtin sort) | |
| 604 | (setf si (bsort-info sort)) | |
| 605 | (or (null srt) | |
| 606 | (sort< x srt)) | |
| 607 | (funcall (car si) opnm)) | |
| 608 | (setq srt x)))) | |
| 609 | (if srt | |
| 610 | (make-bconst-term srt opnm) | |
| 611 | nil) | |
| 612 | )))))) | |
| 650 | 613 | nil)) |
| 651 | ||
| 614 | ||
| 652 | 615 | ;;; FIND-METHOD-NAMED-IN (module op-symbol) |
| 653 | 616 | ;;; |
| 654 | 617 | (defun find-method-named-in (module op-symbol) |
| 655 | 618 | (declare (type module module) |
| 656 | (type list op-symbol)) | |
| 619 | (type list op-symbol)) | |
| 657 | 620 | (let ((opinfos (find-operators-in-module-no-number op-symbol module))) |
| 658 | 621 | (if opinfos |
| 659 | (car (opinfo-methods (car opinfos))) | |
| 660 | ;; | |
| 661 | (dolist (srt (module-all-sorts module) nil) | |
| 662 | (if (sort-is-builtin srt) | |
| 663 | (let ((res (find-builtin-method-in module srt op-symbol))) | |
| 664 | (if res (return res)))))))) | |
| 665 | ||
| 622 | (car (opinfo-methods (car opinfos))) | |
| 623 | ;; | |
| 624 | (dolist (srt (module-all-sorts module) nil) | |
| 625 | (if (sort-is-builtin srt) | |
| 626 | (let ((res (find-builtin-method-in module srt op-symbol))) | |
| 627 | (if res (return res)))))))) | |
| 628 | ||
| 666 | 629 | ;;; FIND-ALL-MEHTODS-NAMED-IN |
| 667 | 630 | ;;; |
| 668 | 631 | (defun find-all-methods-named-in (module op-name) |
| 669 | 632 | (declare (type module module) |
| 670 | (type list op-name)) | |
| 633 | (type list op-name)) | |
| 671 | 634 | (nconc (let ((opinfos (find-operators-in-module-no-number op-name module)) |
| 672 | (res nil)) | |
| 673 | (dolist (info opinfos) | |
| 674 | (setf res (append res (opinfo-methods info)))) | |
| 675 | res) | |
| 676 | (mapcan #'(lambda (srt) | |
| 677 | (if (sort-is-builtin srt) | |
| 678 | (let ((res (find-builtin-method-in module srt op-name))) | |
| 679 | (if res (list res))))) | |
| 680 | (module-all-sorts module)))) | |
| 635 | (res nil)) | |
| 636 | (dolist (info opinfos) | |
| 637 | (setf res (append res (opinfo-methods info)))) | |
| 638 | res) | |
| 639 | (mapcan #'(lambda (srt) | |
| 640 | (if (sort-is-builtin srt) | |
| 641 | (let ((res (find-builtin-method-in module srt op-name))) | |
| 642 | (if res (list res))))) | |
| 643 | (module-all-sorts module)))) | |
| 681 | 644 | |
| 682 | 645 | ;;; FIND-ALL-MEHTODS-NAMED-IN-SORT module op-name sort |
| 683 | 646 | ;;; |
| 684 | 647 | (defun find-all-methods-named-in-sort (module op-name sort) |
| 685 | 648 | (declare (type module module) |
| 686 | (type list op-name) | |
| 687 | (type sort* sort)) | |
| 649 | (type list op-name) | |
| 650 | (type sort* sort)) | |
| 688 | 651 | (let ((so (module-sort-order module))) |
| 689 | 652 | (declare (type sort-order so)) |
| 690 | 653 | (append (let ((opinfos (find-operators-in-module-no-number op-name module)) |
| 691 | (res nil)) | |
| 692 | (dolist (info opinfos) | |
| 693 | (let ((res1 (find-if | |
| 694 | #'(lambda (method) | |
| 695 | (sort<= (method-coarity method) sort so)) | |
| 696 | (opinfo-methods info)))) | |
| 697 | (if res1 | |
| 698 | (setf res (nconc res res1))))) | |
| 699 | res) | |
| 700 | (mapcan #'(lambda (srt) | |
| 701 | (if (and (sort-is-builtin srt) | |
| 702 | (sort<= srt sort so)) | |
| 703 | (let ((res (find-builtin-method-in module srt op-name))) | |
| 704 | (if res (list res))))) | |
| 705 | (module-all-sorts module))))) | |
| 654 | (res nil)) | |
| 655 | (dolist (info opinfos) | |
| 656 | (let ((res1 (find-if | |
| 657 | #'(lambda (method) | |
| 658 | (sort<= (method-coarity method) sort so)) | |
| 659 | (opinfo-methods info)))) | |
| 660 | (if res1 | |
| 661 | (setf res (nconc res res1))))) | |
| 662 | res) | |
| 663 | (mapcan #'(lambda (srt) | |
| 664 | (if (and (sort-is-builtin srt) | |
| 665 | (sort<= srt sort so)) | |
| 666 | (let ((res (find-builtin-method-in module srt op-name))) | |
| 667 | (if res (list res))))) | |
| 668 | (module-all-sorts module))))) | |
| 706 | 669 | |
| 707 | 670 | (defun find-error-method-in (module method) |
| 708 | 671 | (declare (type module module) |
| 709 | (type method method)) | |
| 672 | (type method method)) | |
| 710 | 673 | (when (memq (method-module method) |
| 711 | *kernel-hard-wired-builtin-modules*) | |
| 674 | *kernel-hard-wired-builtin-modules*) | |
| 712 | 675 | (return-from find-error-method-in method)) |
| 713 | 676 | (when (method-is-universal method) |
| 714 | 677 | (return-from find-error-method-in method)) |
| 715 | 678 | ;; |
| 716 | 679 | (or (car (memq method (module-error-methods module))) |
| 717 | 680 | (let* ((alen (length (method-arity method))) |
| 718 | (opinfos (find-operators-in-module (method-symbol method) | |
| 719 | alen | |
| 720 | module)) | |
| 721 | (so (module-sort-order module))) | |
| 722 | ;; | |
| 723 | (unless opinfos | |
| 724 | (with-output-panic-message () | |
| 725 | (princ "finding error method, could not find opinfo! : ") | |
| 726 | (print-chaos-object method) | |
| 727 | (chaos-error 'panic))) | |
| 728 | ;; | |
| 729 | (let (;; (opinfo nil) | |
| 730 | (err-method nil)) | |
| 731 | (unless | |
| 732 | (block find-method | |
| 733 | (let* ((ar (mapcar #'(lambda (x) | |
| 734 | (if (err-sort-p x) | |
| 735 | (find-compatible-err-sort x module nil) | |
| 736 | (the-err-sort x so))) | |
| 737 | (method-arity method))) | |
| 738 | (ar-names (mapcar #'(lambda(x) (sort-id x)) | |
| 739 | ar)) | |
| 740 | (cr (if (err-sort-p (method-coarity method)) | |
| 741 | (find-compatible-err-sort (method-coarity method) | |
| 742 | module | |
| 743 | nil) | |
| 744 | (the-err-sort (method-coarity method) so))) | |
| 745 | (cr-name (sort-id cr))) | |
| 746 | (dolist (oi opinfos) | |
| 747 | (dolist (cand (opinfo-methods oi)) | |
| 748 | (when (and (equal ar-names | |
| 749 | (mapcar #'(lambda (x) (sort-id x)) | |
| 750 | (method-arity cand))) | |
| 751 | (equal cr-name | |
| 752 | (sort-id (method-coarity cand)))) | |
| 753 | ;; (setq opinfo oi) | |
| 754 | (setq err-method cand) | |
| 755 | (return-from find-method t)) | |
| 756 | )))) | |
| 757 | #|| | |
| 758 | (with-output-panic-message () | |
| 759 | (princ "could not find error operator! : ") | |
| 760 | (print-chaos-object method) | |
| 761 | (chaos-error 'panic)) | |
| 762 | ||# | |
| 763 | (return-from find-error-method-in method)) | |
| 764 | ;; | |
| 765 | err-method)))) | |
| 681 | (opinfos (find-operators-in-module (method-symbol method) | |
| 682 | alen | |
| 683 | module)) | |
| 684 | (so (module-sort-order module))) | |
| 685 | ;; | |
| 686 | (unless opinfos | |
| 687 | (with-output-panic-message () | |
| 688 | (princ "finding error method, could not find opinfo! : ") | |
| 689 | (print-chaos-object method) | |
| 690 | (chaos-error 'panic))) | |
| 691 | ;; | |
| 692 | (let (;; (opinfo nil) | |
| 693 | (err-method nil)) | |
| 694 | (unless | |
| 695 | (block find-method | |
| 696 | (let* ((ar (mapcar #'(lambda (x) | |
| 697 | (if (err-sort-p x) | |
| 698 | (find-compatible-err-sort x module nil) | |
| 699 | (the-err-sort x so))) | |
| 700 | (method-arity method))) | |
| 701 | (ar-names (mapcar #'(lambda(x) (sort-id x)) | |
| 702 | ar)) | |
| 703 | (cr (if (err-sort-p (method-coarity method)) | |
| 704 | (find-compatible-err-sort (method-coarity method) | |
| 705 | module | |
| 706 | nil) | |
| 707 | (the-err-sort (method-coarity method) so))) | |
| 708 | (cr-name (sort-id cr))) | |
| 709 | (dolist (oi opinfos) | |
| 710 | (dolist (cand (opinfo-methods oi)) | |
| 711 | (when (and (equal ar-names | |
| 712 | (mapcar #'(lambda (x) (sort-id x)) | |
| 713 | (method-arity cand))) | |
| 714 | (equal cr-name | |
| 715 | (sort-id (method-coarity cand)))) | |
| 716 | ;; (setq opinfo oi) | |
| 717 | (setq err-method cand) | |
| 718 | (return-from find-method t)))))) | |
| 719 | (return-from find-error-method-in method)) | |
| 720 | ;; | |
| 721 | err-method)))) | |
| 722 | ||
| 723 | ;;; FIND-CONSTRUCTORS-IN : module sort -> list(method) | |
| 724 | ;;; | |
| 725 | (defun find-sort-constructors-in (module sort) | |
| 726 | (declare (type module module)) | |
| 727 | (with-in-module (module) | |
| 728 | (let ((ops nil)) | |
| 729 | (dolist (opinfo (module-all-operators *current-module*)) | |
| 730 | (dolist (meth (opinfo-methods opinfo)) | |
| 731 | (when (and (method-is-constructor? meth) | |
| 732 | (sort<= (method-coarity meth) sort (module-sort-order *current-module*))) | |
| 733 | (push meth ops)))) | |
| 734 | (sort ops #'(lambda (x y) (< (length (method-arity x)) (length (method-arity y)))))))) | |
| 766 | 735 | |
| 767 | 736 | ;;; VARIABLES ------------------------------------------------------------------ |
| 768 | 737 | |
| 772 | 741 | (declare (type module module)) |
| 773 | 742 | (when (stringp variable-name) (setq variable-name (intern variable-name))) |
| 774 | 743 | (cdr (find variable-name (module-variables module) |
| 775 | :key 'car | |
| 776 | :test #'(lambda (n v) (eq n v)))) | |
| 744 | :key 'car | |
| 745 | :test #'(lambda (n v) (eq n v)))) | |
| 777 | 746 | ) |
| 778 | 747 | |
| 779 | 748 | ;;; PARAMETERS ----------------------------------------------------------------- |
| 787 | 756 | #|| |
| 788 | 757 | (defun get-module-imported-parameters* (module res) |
| 789 | 758 | (declare (type module module) |
| 790 | (type list res)) | |
| 759 | (type list res)) | |
| 791 | 760 | (when (or (module-is-inconsistent module) |
| 792 | (null (module-name module))) | |
| 761 | (null (module-name module))) | |
| 793 | 762 | (return-from get-module-imported-parameters* nil)) |
| 794 | 763 | (dolist (param (module-parameters module)) |
| 795 | 764 | (pushnew param (cdr res) :test #'equal)) |
| 796 | 765 | (dolist (impsub (module-direct-submodules module)) |
| 797 | 766 | (unless (eq :using (cdr impsub)) |
| 798 | 767 | (let* ((sub (car impsub)) |
| 799 | (sub-name (module-name sub))) | |
| 800 | (cond ((or (%is-instantiation sub-name) | |
| 801 | (int-instantiation-p sub-name)) | |
| 802 | (let ((args nil) | |
| 803 | (ins-mod nil)) | |
| 804 | (if (%is-instantiation sub-name) | |
| 805 | (progn | |
| 806 | (setq args (%instantiation-args sub-name)) | |
| 807 | (setq ins-mod (%instantiation-module sub-name))) | |
| 808 | (progn | |
| 809 | (setq args (int-instantiation-args sub-name)) | |
| 810 | (setq ins-mod (int-instantiation-module sub-name)))) | |
| 811 | (dolist (is (module-direct-submodules sub)) | |
| 812 | (let ((is-mod (car is)) | |
| 813 | (rst nil)) | |
| 814 | (if (module-is-parameter-theory is-mod) | |
| 815 | (when (member (setq rst | |
| 816 | (parameter-theory-arg-name is-mod)) | |
| 817 | args | |
| 818 | :test #'(lambda (a arg) | |
| 819 | (let ((arg-name | |
| 820 | (%!arg-name arg)) | |
| 821 | (arg-view | |
| 822 | (%!arg-view arg))) | |
| 823 | (or | |
| 824 | (equal arg-view "DUMMY") | |
| 825 | (progn | |
| 826 | (when (numberp arg-name) | |
| 827 | (setq arg-name | |
| 828 | (get-module-nth-arg-name | |
| 829 | ins-mod | |
| 830 | arg-name))) | |
| 831 | (when (and (consp arg-name) | |
| 832 | (null (cdr arg-name))) | |
| 833 | (setq arg-name (car arg-name))) | |
| 834 | (not (equal a arg-name)))))) | |
| 835 | ) | |
| 836 | (pushnew (cons (cons rst is-mod) | |
| 837 | (cdr is)) | |
| 838 | (cdr res) | |
| 839 | :test #'equal)) | |
| 840 | ;; | |
| 841 | (get-module-imported-parameters* is-mod res) | |
| 842 | )))) | |
| 843 | ) | |
| 844 | ((modexp-is-parameter-theory sub-name) | |
| 845 | (pushnew (cons (cons (car sub-name) | |
| 846 | sub) | |
| 847 | (cdr impsub)) | |
| 848 | (cdr res) | |
| 849 | :test #'equal)) | |
| 850 | (t | |
| 851 | (get-module-imported-parameters* sub res) | |
| 852 | )))) | |
| 768 | (sub-name (module-name sub))) | |
| 769 | (cond ((or (%is-instantiation sub-name) | |
| 770 | (int-instantiation-p sub-name)) | |
| 771 | (let ((args nil) | |
| 772 | (ins-mod nil)) | |
| 773 | (if (%is-instantiation sub-name) | |
| 774 | (progn | |
| 775 | (setq args (%instantiation-args sub-name)) | |
| 776 | (setq ins-mod (%instantiation-module sub-name))) | |
| 777 | (progn | |
| 778 | (setq args (int-instantiation-args sub-name)) | |
| 779 | (setq ins-mod (int-instantiation-module sub-name)))) | |
| 780 | (dolist (is (module-direct-submodules sub)) | |
| 781 | (let ((is-mod (car is)) | |
| 782 | (rst nil)) | |
| 783 | (if (module-is-parameter-theory is-mod) | |
| 784 | (when (member (setq rst | |
| 785 | (parameter-theory-arg-name is-mod)) | |
| 786 | args | |
| 787 | :test #'(lambda (a arg) | |
| 788 | (let ((arg-name | |
| 789 | (%!arg-name arg)) | |
| 790 | (arg-view | |
| 791 | (%!arg-view arg))) | |
| 792 | (or | |
| 793 | (equal arg-view "DUMMY") | |
| 794 | (progn | |
| 795 | (when (numberp arg-name) | |
| 796 | (setq arg-name | |
| 797 | (get-module-nth-arg-name | |
| 798 | ins-mod | |
| 799 | arg-name))) | |
| 800 | (when (and (consp arg-name) | |
| 801 | (null (cdr arg-name))) | |
| 802 | (setq arg-name (car arg-name))) | |
| 803 | (not (equal a arg-name)))))) | |
| 804 | ) | |
| 805 | (pushnew (cons (cons rst is-mod) | |
| 806 | (cdr is)) | |
| 807 | (cdr res) | |
| 808 | :test #'equal)) | |
| 809 | ;; | |
| 810 | (get-module-imported-parameters* is-mod res) | |
| 811 | )))) | |
| 812 | ) | |
| 813 | ((modexp-is-parameter-theory sub-name) | |
| 814 | (pushnew (cons (cons (car sub-name) | |
| 815 | sub) | |
| 816 | (cdr impsub)) | |
| 817 | (cdr res) | |
| 818 | :test #'equal)) | |
| 819 | (t | |
| 820 | (get-module-imported-parameters* sub res) | |
| 821 | )))) | |
| 853 | 822 | )) |
| 854 | 823 | |
| 855 | 824 | ||# |
| 860 | 829 | (return-from get-module-imported-parameters* nil)) |
| 861 | 830 | ;; |
| 862 | 831 | (when (or (module-is-inconsistent module) |
| 863 | (null (module-name module))) | |
| 832 | (null (module-name module))) | |
| 864 | 833 | (return-from get-module-imported-parameters* nil)) |
| 865 | 834 | (dolist (param (module-parameters module)) |
| 866 | 835 | (pushnew param (cdr res) :test #'equal)) |
| 867 | 836 | (dolist (impsub (module-direct-submodules module)) |
| 868 | 837 | (unless (eq :using (cdr impsub)) |
| 869 | 838 | (let* ((sub (car impsub)) |
| 870 | (sub-name (module-name sub))) | |
| 871 | (cond ((module-is-parameter-theory sub) | |
| 872 | (pushnew (cons (cons (parameter-theory-arg-name sub) | |
| 873 | sub) | |
| 874 | (cdr impsub)) | |
| 875 | (cdr res) | |
| 876 | :test #'equal)) | |
| 877 | ((or (%is-instantiation sub-name) | |
| 878 | (int-instantiation-p sub-name)) | |
| 879 | (let ((args nil) | |
| 880 | (ins-mod nil)) | |
| 881 | (if (%is-instantiation sub-name) | |
| 882 | (progn | |
| 883 | (setq args (%instantiation-args sub-name)) | |
| 884 | (setq ins-mod (%instantiation-module sub-name))) | |
| 885 | (progn | |
| 886 | (setq args (int-instantiation-args sub-name)) | |
| 887 | (setq ins-mod (int-instantiation-module sub-name)))) | |
| 888 | (dolist (is (module-direct-submodules sub)) | |
| 889 | (let ((is-mod (car is)) | |
| 890 | (rst nil)) | |
| 891 | (if (module-is-parameter-theory is-mod) | |
| 892 | (when (member (setq rst | |
| 893 | (parameter-theory-arg-name is-mod)) | |
| 894 | args | |
| 895 | :test #'(lambda (a arg) | |
| 896 | (let ((arg-name | |
| 897 | (%!arg-name arg)) | |
| 898 | (arg-view | |
| 899 | (%!arg-view arg))) | |
| 900 | (or | |
| 901 | (equal arg-view "DUMMY") | |
| 902 | (progn | |
| 903 | (when (numberp arg-name) | |
| 904 | (setq arg-name | |
| 905 | (get-module-nth-arg-name | |
| 906 | ins-mod | |
| 907 | arg-name))) | |
| 908 | (when (and (consp arg-name) | |
| 909 | (null (cdr arg-name))) | |
| 910 | (setq arg-name (car arg-name))) | |
| 911 | (not (equal a arg-name)))))) | |
| 912 | ) | |
| 913 | (pushnew (cons (cons rst is-mod) | |
| 914 | (cdr is)) | |
| 915 | (cdr res) | |
| 916 | :test #'equal)) | |
| 917 | ;; | |
| 918 | (get-module-imported-parameters* is-mod res) | |
| 919 | )))) | |
| 920 | ) | |
| 921 | ((%is-rename sub-name) | |
| 922 | (get-module-imported-parameters* (%rename-module sub-name) | |
| 923 | res)) | |
| 924 | ((int-rename-p sub-name) | |
| 925 | (get-module-imported-parameters* (int-rename-module sub-name) | |
| 926 | res)) | |
| 927 | (t | |
| 928 | (get-module-imported-parameters* sub res) | |
| 929 | )))) | |
| 839 | (sub-name (module-name sub))) | |
| 840 | (cond ((module-is-parameter-theory sub) | |
| 841 | (pushnew (cons (cons (parameter-theory-arg-name sub) | |
| 842 | sub) | |
| 843 | (cdr impsub)) | |
| 844 | (cdr res) | |
| 845 | :test #'equal)) | |
| 846 | ((or (%is-instantiation sub-name) | |
| 847 | (int-instantiation-p sub-name)) | |
| 848 | (let ((args nil) | |
| 849 | (ins-mod nil)) | |
| 850 | (if (%is-instantiation sub-name) | |
| 851 | (progn | |
| 852 | (setq args (%instantiation-args sub-name)) | |
| 853 | (setq ins-mod (%instantiation-module sub-name))) | |
| 854 | (progn | |
| 855 | (setq args (int-instantiation-args sub-name)) | |
| 856 | (setq ins-mod (int-instantiation-module sub-name)))) | |
| 857 | (dolist (is (module-direct-submodules sub)) | |
| 858 | (let ((is-mod (car is)) | |
| 859 | (rst nil)) | |
| 860 | (if (module-is-parameter-theory is-mod) | |
| 861 | (when (member (setq rst | |
| 862 | (parameter-theory-arg-name is-mod)) | |
| 863 | args | |
| 864 | :test #'(lambda (a arg) | |
| 865 | (let ((arg-name | |
| 866 | (%!arg-name arg)) | |
| 867 | (arg-view | |
| 868 | (%!arg-view arg))) | |
| 869 | (or | |
| 870 | (equal arg-view "DUMMY") | |
| 871 | (progn | |
| 872 | (when (numberp arg-name) | |
| 873 | (setq arg-name | |
| 874 | (get-module-nth-arg-name | |
| 875 | ins-mod | |
| 876 | arg-name))) | |
| 877 | (when (and (consp arg-name) | |
| 878 | (null (cdr arg-name))) | |
| 879 | (setq arg-name (car arg-name))) | |
| 880 | (not (equal a arg-name)))))) | |
| 881 | ) | |
| 882 | (pushnew (cons (cons rst is-mod) | |
| 883 | (cdr is)) | |
| 884 | (cdr res) | |
| 885 | :test #'equal)) | |
| 886 | ;; | |
| 887 | (get-module-imported-parameters* is-mod res) | |
| 888 | )))) | |
| 889 | ) | |
| 890 | ((%is-rename sub-name) | |
| 891 | (get-module-imported-parameters* (%rename-module sub-name) | |
| 892 | res)) | |
| 893 | ((int-rename-p sub-name) | |
| 894 | (get-module-imported-parameters* (int-rename-module sub-name) | |
| 895 | res)) | |
| 896 | (t | |
| 897 | (get-module-imported-parameters* sub res) | |
| 898 | )))) | |
| 930 | 899 | )) |
| 931 | 900 | |
| 932 | 901 | (defun get-module-parameters (module) |
| 937 | 906 | ;;; |
| 938 | 907 | (defun find-parameterized-submodule (name module) |
| 939 | 908 | (declare (type (or fixnum modexp) name) |
| 940 | (type (or module modexp) module)) | |
| 909 | (type (or module modexp) module)) | |
| 941 | 910 | (unless (module-p module) |
| 942 | 911 | (setq module (eval-modexp module)) |
| 943 | 912 | (when (or (modexp-is-error module) |
| 944 | (null module)) | |
| 913 | (null module)) | |
| 945 | 914 | (with-output-panic-message () |
| 946 | (format t "Internal error, could not evaluate modexp ~a" module) | |
| 947 | (chaos-error 'panic)))) | |
| 915 | (format t "Internal error, could not evaluate modexp ~a" module) | |
| 916 | (chaos-error 'panic)))) | |
| 948 | 917 | (let ((params (get-module-parameters module))) |
| 949 | 918 | (cond ((integerp name) |
| 950 | (when (< name 0) | |
| 951 | (with-output-chaos-error ('invalid-parameter-number) | |
| 952 | (princ "parameter number must be more than or equal to 1") | |
| 953 | )) | |
| 954 | (let ((param (nth name params))) | |
| 955 | (if param | |
| 956 | (parameter-theory-module param) | |
| 957 | nil))) | |
| 958 | ((consp name) | |
| 959 | (let ((real-name (car name)) | |
| 960 | (context (cdr name))) | |
| 961 | (unless (or (module-p context) (null context)) | |
| 962 | (with-output-chaos-error ('no-context) | |
| 963 | (princ "context for parameter name must be evaluated : " ) | |
| 964 | (print-chaos-object context) | |
| 965 | )) | |
| 966 | (find-parameterized-submodule real-name (if context | |
| 967 | context | |
| 968 | module)))) | |
| 969 | ((stringp name) | |
| 970 | (let ((param (find-if #'(lambda (x) | |
| 971 | (equal name (parameter-arg-name x))) | |
| 972 | params))) | |
| 973 | (if param | |
| 974 | (parameter-theory-module param) | |
| 975 | (progn | |
| 976 | (setq param (find-module-in-env-ext name module)) | |
| 977 | (if (module-is-parameter-theory param) | |
| 978 | param | |
| 979 | (cons :error name)))))) | |
| 980 | (t (with-output-panic-message () | |
| 981 | (princ "invalid parameter name comes : ") | |
| 982 | (print-chaos-object name) | |
| 983 | (chaos-to-top)))))) | |
| 919 | (when (< name 0) | |
| 920 | (with-output-chaos-error ('invalid-parameter-number) | |
| 921 | (princ "parameter number must be more than or equal to 1") | |
| 922 | )) | |
| 923 | (let ((param (nth name params))) | |
| 924 | (if param | |
| 925 | (parameter-theory-module param) | |
| 926 | nil))) | |
| 927 | ((consp name) | |
| 928 | (let ((real-name (car name)) | |
| 929 | (context (cdr name))) | |
| 930 | (unless (or (module-p context) (null context)) | |
| 931 | (with-output-chaos-error ('no-context) | |
| 932 | (princ "context for parameter name must be evaluated : " ) | |
| 933 | (print-chaos-object context) | |
| 934 | )) | |
| 935 | (find-parameterized-submodule real-name (if context | |
| 936 | context | |
| 937 | module)))) | |
| 938 | ((stringp name) | |
| 939 | (let ((param (find-if #'(lambda (x) | |
| 940 | (equal name (parameter-arg-name x))) | |
| 941 | params))) | |
| 942 | (if param | |
| 943 | (parameter-theory-module param) | |
| 944 | (progn | |
| 945 | (setq param (find-module-in-env-ext name module)) | |
| 946 | (if (module-is-parameter-theory param) | |
| 947 | param | |
| 948 | (cons :error name)))))) | |
| 949 | (t (with-output-panic-message () | |
| 950 | (princ "invalid parameter name comes : ") | |
| 951 | (print-chaos-object name) | |
| 952 | (chaos-to-top)))))) | |
| 984 | 953 | |
| 985 | 954 | (defun get-module-nth-arg-name (mod num) |
| 986 | 955 | (declare (type (or module modexp) mod) |
| 987 | (type fixnum num)) | |
| 956 | (type fixnum num)) | |
| 988 | 957 | (if (module-p mod) |
| 989 | 958 | (let ((param (nth num (get-module-parameters mod)))) |
| 990 | (if param | |
| 991 | (parameter-arg-name param) | |
| 992 | nil)) | |
| 959 | (if param | |
| 960 | (parameter-arg-name param) | |
| 961 | nil)) | |
| 993 | 962 | (let ((mod (find-module-in-env (normalize-modexp mod)))) |
| 994 | (when mod | |
| 995 | (get-module-nth-arg-name mod num))))) | |
| 963 | (when mod | |
| 964 | (get-module-nth-arg-name mod num))))) | |
| 996 | 965 | |
| 997 | 966 | |
| 998 | 967 | ;;; SUBMODULE ------------------------------------------------------------------- |
| 999 | 968 | (defun nth-sub (no mod) |
| 1000 | 969 | (declare (type t no) |
| 1001 | (type module mod)) | |
| 970 | (type module mod)) | |
| 1002 | 971 | (unless (integerp no) |
| 1003 | 972 | (with-output-chaos-error ('invalid-submodule-number) |
| 1004 | 973 | (format t "Invalid submodule number ~a" no) |
| 1008 | 977 | (princ "submodule number must be greater than or equal to 1.") |
| 1009 | 978 | )) |
| 1010 | 979 | (let ((lst nil) |
| 1011 | (params (module-parameters mod))) | |
| 980 | (params (module-parameters mod))) | |
| 1012 | 981 | (dolist (i (module-submodules mod)) |
| 1013 | 982 | (when (not (rassoc (car i) params)) (push (car i) lst))) |
| 1014 | 983 | (nth (the fixnum no) lst) |
| 1021 | 990 | |
| 1022 | 991 | (defun module-own-axioms (mod &optional no-system-axiom) |
| 1023 | 992 | (declare (type module mod) |
| 1024 | (type (or null t) no-system-axiom)) | |
| 993 | (type (or null t) no-system-axiom)) | |
| 1025 | 994 | (if no-system-axiom |
| 1026 | 995 | (nconc (remove-if-not #'(lambda (x) |
| 1027 | (declare (type axiom x)) | |
| 1028 | (or (null (axiom-kind x)) | |
| 1029 | (eq :bad-rule (axiom-kind x)) | |
| 1030 | (eq :bad-beh (axiom-kind x)))) | |
| 1031 | (module-equations mod)) | |
| 1032 | (module-rules mod)) | |
| 996 | (declare (type axiom x)) | |
| 997 | (or (null (axiom-kind x)) | |
| 998 | (eq :bad-rule (axiom-kind x)) | |
| 999 | (eq :bad-beh (axiom-kind x)))) | |
| 1000 | (module-equations mod)) | |
| 1001 | (module-rules mod)) | |
| 1033 | 1002 | (append (module-equations mod) (module-rules mod)))) |
| 1034 | 1003 | |
| 1035 | 1004 | (defun module-own-axioms-ordered (mod &optional no-system-axiom) |
| 1036 | 1005 | (declare (type module mod) |
| 1037 | (type (or null t) no-system-axiom)) | |
| 1006 | (type (or null t) no-system-axiom)) | |
| 1038 | 1007 | (if no-system-axiom |
| 1039 | 1008 | (nconc (nreverse (remove-if-not #'(lambda (x) |
| 1040 | (declare (type axiom x)) | |
| 1041 | (or (null (axiom-kind x)) | |
| 1042 | (eq :bad-rule (axiom-kind x)) | |
| 1043 | (eq :bad-beh (axiom-kind x)))) | |
| 1044 | (module-equations mod))) | |
| 1045 | (reverse (module-rules mod))) | |
| 1009 | (declare (type axiom x)) | |
| 1010 | (or (null (axiom-kind x)) | |
| 1011 | (eq :bad-rule (axiom-kind x)) | |
| 1012 | (eq :bad-beh (axiom-kind x)))) | |
| 1013 | (module-equations mod))) | |
| 1014 | (reverse (module-rules mod))) | |
| 1046 | 1015 | (nconc (reverse (module-equations mod)) |
| 1047 | (reverse (module-rules mod))))) | |
| 1016 | (reverse (module-rules mod))))) | |
| 1048 | 1017 | |
| 1049 | 1018 | (defvar *get-axioms-seen-mod* nil) |
| 1050 | 1019 | |
| 1051 | 1020 | (defun module-imported-axioms (mod &optional no-system-axiom) |
| 1052 | 1021 | (declare (type module mod) |
| 1053 | (type (or null t) no-system-axiom)) | |
| 1022 | (type (or null t) no-system-axiom)) | |
| 1054 | 1023 | (setq *get-axioms-seen-mod* nil) |
| 1055 | 1024 | (module-imported-axioms* mod no-system-axiom)) |
| 1056 | 1025 | |
| 1057 | 1026 | (defun module-imported-axioms* (mod no-system-axiom) |
| 1058 | 1027 | (declare (type module mod) |
| 1059 | (type (or null t) no-system-axiom)) | |
| 1028 | (type (or null t) no-system-axiom)) | |
| 1060 | 1029 | (let ((res nil) |
| 1061 | (subs (nreverse (module-direct-submodules mod)))) | |
| 1030 | (subs (nreverse (module-direct-submodules mod)))) | |
| 1062 | 1031 | (dolist (sub subs) |
| 1063 | 1032 | (block next-sub |
| 1064 | (let ((sm (car sub))) | |
| 1065 | (when (memq sm *get-axioms-seen-mod*) | |
| 1066 | (return-from next-sub nil)) | |
| 1067 | (push sm *get-axioms-seen-mod*) | |
| 1068 | (when (eq :using (cdr sub)) | |
| 1069 | (return-from next-sub nil)) | |
| 1070 | (when (memq sm *apply-ignore-modules*) | |
| 1071 | (return-from next-sub nil)) | |
| 1072 | (let ((sub-ax nil) | |
| 1073 | (to-be-fixed (module-axioms-to-be-fixed mod))) | |
| 1074 | (dolist (ax (module-own-axioms-ordered sm no-system-axiom)) | |
| 1075 | (push (or (cdr (assq ax to-be-fixed)) | |
| 1076 | ax) | |
| 1077 | sub-ax)) | |
| 1078 | (setq res | |
| 1079 | (nconc res | |
| 1080 | (nconc (nreverse sub-ax) | |
| 1081 | (mapcar #'(lambda (x) | |
| 1082 | (or (cdr (assq x to-be-fixed)) | |
| 1083 | x)) | |
| 1084 | (module-imported-axioms* | |
| 1085 | sm no-system-axiom))))) | |
| 1086 | )))) | |
| 1033 | (let ((sm (car sub))) | |
| 1034 | (when (memq sm *get-axioms-seen-mod*) | |
| 1035 | (return-from next-sub nil)) | |
| 1036 | (push sm *get-axioms-seen-mod*) | |
| 1037 | (when (eq :using (cdr sub)) | |
| 1038 | (return-from next-sub nil)) | |
| 1039 | (when (memq sm *apply-ignore-modules*) | |
| 1040 | (return-from next-sub nil)) | |
| 1041 | (let ((sub-ax nil) | |
| 1042 | (to-be-fixed (module-axioms-to-be-fixed mod))) | |
| 1043 | (dolist (ax (module-own-axioms-ordered sm no-system-axiom)) | |
| 1044 | (push (or (cdr (assq ax to-be-fixed)) | |
| 1045 | ax) | |
| 1046 | sub-ax)) | |
| 1047 | (setq res | |
| 1048 | (nconc res | |
| 1049 | (nconc (nreverse sub-ax) | |
| 1050 | (mapcar #'(lambda (x) | |
| 1051 | (or (cdr (assq x to-be-fixed)) | |
| 1052 | x)) | |
| 1053 | (module-imported-axioms* | |
| 1054 | sm no-system-axiom))))) | |
| 1055 | )))) | |
| 1087 | 1056 | ;; |
| 1088 | 1057 | (delete-duplicates res :test #'eq))) |
| 1089 | 1058 | |
| 1090 | 1059 | (defun get-module-axioms (mod &optional no-system-equations) |
| 1091 | 1060 | (declare (type module mod) |
| 1092 | (type (or null t) no-system-equations)) | |
| 1061 | (type (or null t) no-system-equations)) | |
| 1093 | 1062 | (if (not (or *module-all-rules-every* |
| 1094 | *chaos-verbose* | |
| 1095 | *print-all-eqns*)) | |
| 1063 | *chaos-verbose* | |
| 1064 | *print-all-eqns*)) | |
| 1096 | 1065 | (module-own-axioms-ordered mod) |
| 1097 | 1066 | (append (module-own-axioms-ordered mod) |
| 1098 | (module-imported-axioms mod no-system-equations)))) | |
| 1067 | (module-imported-axioms mod no-system-equations)))) | |
| 1099 | 1068 | |
| 1100 | 1069 | ;;; EOF |
| 1101 | 1070 | |
| 0 | 0 | ;;;-*- Mode:LISP; Package:CHAOS; Base:10; Syntax:Common-lisp -*- |
| 1 | 1 | ;;; |
| 2 | ;;; Copyright (c) 2000-2014, Toshimi Sawada. All rights reserved. | |
| 2 | ;;; Copyright (c) 2000-2015, Toshimi Sawada. All rights reserved. | |
| 3 | 3 | ;;; |
| 4 | 4 | ;;; Redistribution and use in source and binary forms, with or without |
| 5 | 5 | ;;; modification, are permitted provided that the following conditions |
| 27 | 27 | ;;; |
| 28 | 28 | (in-package :chaos) |
| 29 | 29 | #|============================================================================== |
| 30 | System: CHAOS | |
| 31 | Module: chaos | |
| 32 | File: gen-eval.lisp | |
| 30 | System: CHAOS | |
| 31 | Module: chaos | |
| 32 | File: gen-eval.lisp | |
| 33 | 33 | ==============================================================================|# |
| 34 | 34 | #-:chaos-debug |
| 35 | 35 | (declaim (optimize (speed 3) (safety 0) #-GCL (debug 0))) |
| 37 | 37 | (declaim (optimize (speed 1) (safety 3) #-GCL (debug 3))) |
| 38 | 38 | |
| 39 | 39 | ;;; **************************************************************************** |
| 40 | ;;; GENERIC AST EVALUATOR | |
| 40 | ;;; GENERIC AST EVALUATOR | |
| 41 | 41 | ;;; **************************************************************************** |
| 42 | 42 | |
| 43 | 43 | ;;;-- Generic Evaluator -------------------------------------------------------- |
| 57 | 57 | (defun ast-to-be-dribbled? (ast) |
| 58 | 58 | (and (chaos-ast? ast) |
| 59 | 59 | (or (eq (ast-category ast) ':chaos-script) |
| 60 | (eq (ast-type ast) '%view-decl) | |
| 61 | (if (eq (ast-type ast) '%module-decl) | |
| 62 | (or (not *no-log-parameter*) | |
| 63 | (not (and (consp (%module-decl-name ast)) | |
| 64 | (equal "::" (cadr (%module-decl-name ast)))))) | |
| 65 | (or *open-module* | |
| 66 | nil))))) | |
| 60 | (eq (ast-type ast) '%view-decl) | |
| 61 | (if (eq (ast-type ast) '%module-decl) | |
| 62 | (or (not *no-log-parameter*) | |
| 63 | (not (and (consp (%module-decl-name ast)) | |
| 64 | (equal "::" (cadr (%module-decl-name ast)))))) | |
| 65 | (or *open-module* | |
| 66 | nil))))) | |
| 67 | 67 | |
| 68 | 68 | (defun eval-ast (ast &optional (print-result nil)) |
| 69 | 69 | (when *dribble-ast* |
| 70 | 70 | (when (ast-to-be-dribbled? ast) |
| 71 | 71 | (when *dribble-stream* |
| 72 | (write (list 'eval-ast-if-need `',ast) :stream *dribble-stream* :escape t) | |
| 73 | (terpri *dribble-stream*) | |
| 74 | (force-output *dribble-stream*)) | |
| 72 | (write (list 'eval-ast-if-need `',ast) :stream *dribble-stream* :escape t) | |
| 73 | (terpri *dribble-stream*) | |
| 74 | (force-output *dribble-stream*)) | |
| 75 | 75 | (push ast *ast-log*))) |
| 76 | 76 | ;; |
| 77 | 77 | (when *eval-ast* |
| 78 | 78 | (cond ((chaos-ast? ast) |
| 79 | (let ((evaluator (or (ast-evaluator ast) | |
| 80 | (and (fboundp (car ast)) | |
| 81 | (symbol-function (car ast)))))) | |
| 82 | (cond (evaluator | |
| 83 | (let ((module (or ;; (chaos-eval-context ast) | |
| 84 | ;; *chaos-eval-context* | |
| 85 | *current-module* | |
| 86 | *last-module*))) | |
| 87 | (when (and module (not (module-p module))) | |
| 88 | (setq module (find-module-in-env | |
| 89 | (normalize-modexp (string module))))) | |
| 90 | (if module | |
| 91 | (if (null *current-module*) | |
| 92 | (with-in-module (module) | |
| 93 | (prog1 (funcall evaluator ast) | |
| 94 | ;; (deallocate-ast ast) | |
| 95 | )) | |
| 96 | (prog1 (funcall evaluator ast) | |
| 97 | )) | |
| 98 | ;; may cause panic. | |
| 99 | (return-from eval-ast (funcall evaluator ast))))) | |
| 100 | (t (let ((val (eval-modexp ast))) | |
| 101 | (if (modexp-is-error val) | |
| 102 | (with-output-chaos-warning () | |
| 103 | (format t "AST evaluator accepted an ast ~s with no evaluator specified." | |
| 104 | (print-ast ast)) | |
| 105 | (return-from eval-ast ast))) ; returns the ast as is. | |
| 106 | ))))) | |
| 107 | (t ;; evaluate it as lisp form | |
| 108 | (cond ((symbolp ast) | |
| 109 | (unless (boundp ast) | |
| 110 | (format t "~&symbol ~s has no bound value." ast) | |
| 111 | (return-from eval-ast nil))) | |
| 112 | ((listp ast) | |
| 113 | (unless (symbolp (car ast)) | |
| 114 | (format t "~&invalid function application form: ~a" ast) | |
| 115 | (return-from eval-ast nil)) | |
| 116 | (unless (fboundp (car ast)) | |
| 117 | (format t "~&symbol ~s has no function definition." (car ast)) | |
| 118 | (return-from eval-ast nil)))) | |
| 119 | ;; | |
| 120 | (let ((res (eval ast))) | |
| 121 | (when print-result | |
| 122 | (format t "~&~s" res)) | |
| 123 | (return-from eval-ast res)))))) | |
| 79 | (let ((evaluator (or (ast-evaluator ast) | |
| 80 | (and (fboundp (car ast)) | |
| 81 | (symbol-function (car ast)))))) | |
| 82 | (cond (evaluator | |
| 83 | (let ((module (get-context-module t))) | |
| 84 | (when (and module (not (module-p module))) | |
| 85 | (setq module (find-module-in-env | |
| 86 | (normalize-modexp (string module))))) | |
| 87 | (if module | |
| 88 | (if (null *current-module*) | |
| 89 | (with-in-module (module) | |
| 90 | (prog1 (funcall evaluator ast) | |
| 91 | ;; (deallocate-ast ast) | |
| 92 | )) | |
| 93 | (prog1 (funcall evaluator ast) | |
| 94 | )) | |
| 95 | ;; may cause panic. | |
| 96 | (return-from eval-ast (funcall evaluator ast))))) | |
| 97 | (t (let ((val (eval-modexp ast))) | |
| 98 | (if (modexp-is-error val) | |
| 99 | (with-output-chaos-warning () | |
| 100 | (format t "AST evaluator accepted an ast ~s with no evaluator specified." | |
| 101 | (print-ast ast)) | |
| 102 | (return-from eval-ast ast))) ; returns the ast as is. | |
| 103 | ))))) | |
| 104 | (t ;; evaluate it as lisp form | |
| 105 | (cond ((symbolp ast) | |
| 106 | (unless (boundp ast) | |
| 107 | (format t "~%symbol ~s has no bound value." ast) | |
| 108 | (return-from eval-ast nil))) | |
| 109 | ((listp ast) | |
| 110 | (unless (symbolp (car ast)) | |
| 111 | (format t "~%invalid function application form: ~a" ast) | |
| 112 | (return-from eval-ast nil)) | |
| 113 | (unless (fboundp (car ast)) | |
| 114 | (format t "~%symbol ~s has no function definition." (car ast)) | |
| 115 | (return-from eval-ast nil)))) | |
| 116 | ;; | |
| 117 | (let ((res (eval ast))) | |
| 118 | (when print-result | |
| 119 | (format t "~%~s" res)) | |
| 120 | (return-from eval-ast res)))))) | |
| 124 | 121 | |
| 125 | 122 | (defun eval-seq (seq) |
| 126 | 123 | (mapcar #'(lambda (obj) (eval-ast obj)) |
| 127 | (%seq-args seq))) | |
| 124 | (%seq-args seq))) | |
| 128 | 125 | |
| 129 | 126 | (defun eval-ast2 (ast) |
| 130 | 127 | (eval-ast ast) |
| 0 | 0 | ;;;-*- Mode: Lisp; Syntax:CommonLisp; Package:CHAOS; Base:10 -*- |
| 1 | 1 | ;;; |
| 2 | ;;; Copyright (c) 2000-2014, Toshimi Sawada. All rights reserved. | |
| 2 | ;;; Copyright (c) 2000-2015, Toshimi Sawada. All rights reserved. | |
| 3 | 3 | ;;; |
| 4 | 4 | ;;; Redistribution and use in source and binary forms, with or without |
| 5 | 5 | ;;; modification, are permitted provided that the following conditions |
| 71 | 71 | ;;; |
| 72 | 72 | |
| 73 | 73 | (defun print-ast-vd (ast stream print-var-sort) |
| 74 | (declare (type stream stream)) | |
| 74 | 75 | (print-check) |
| 75 | 76 | (cond ((consp ast) |
| 76 | 77 | (let ((flg nil)) |
| 85 | 86 | (defun is-ast (obj) |
| 86 | 87 | (and (consp obj) |
| 87 | 88 | (let ((cat (car obj))) |
| 88 | (and (symbolp cat) | |
| 89 | (getf (symbol-plist cat) :category))))) | |
| 89 | (and (symbolp cat) | |
| 90 | (getf (symbol-plist cat) :category))))) | |
| 90 | 91 | |
| 91 | 92 | ;;;==================================================== |
| 92 | 93 | ;;; TERM PRINTER |
| 161 | 162 | `(":literal" ,(variable-print-string term print-var-sort vars-so-far))) |
| 162 | 163 | (return-from term-to-sexpr |
| 163 | 164 | (variable-print-string term print-var-sort vars-so-far)))) |
| 164 | ((term-is-system-object? term) | |
| 165 | (if as-tree | |
| 166 | (return-from term-to-sexpr | |
| 167 | `(":sysobj" ,(format nil "~s" (term-system-object term)))) | |
| 168 | (return-from term-to-sexpr | |
| 169 | (format nil "(~s)" (term-system-object term))))) | |
| 165 | ((term-is-system-object? term) | |
| 166 | (if as-tree | |
| 167 | (return-from term-to-sexpr | |
| 168 | `(":sysobj" ,(format nil "~s" (term-system-object term)))) | |
| 169 | (return-from term-to-sexpr | |
| 170 | (format nil "(~s)" (term-system-object term))))) | |
| 170 | 171 | ((term-is-builtin-constant? term) |
| 171 | 172 | (if as-tree |
| 172 | 173 | (return-from term-to-sexpr |
| 243 | 244 | (cond ((or (term$is-variable? body) (term$is-psuedo-constant? body)) |
| 244 | 245 | (let ((vstr (variable-print-string term print-var-sort vars-so-far))) |
| 245 | 246 | (princ vstr stream))) |
| 246 | ((term$is-system-object? body) | |
| 247 | (let ((obj (term-system-object term))) | |
| 248 | (when (chaos-list-p obj) | |
| 249 | (setq obj (chaos-list-list obj))) | |
| 250 | (if (or (atom obj) (is-ast obj)) | |
| 251 | (prin1 obj stream) | |
| 252 | (progn | |
| 253 | (princ ":[" stream) | |
| 254 | (format stream "~{~S~^,~}" obj) | |
| 255 | (princ "]" stream))))) | |
| 247 | ((term$is-system-object? body) | |
| 248 | (let ((obj (term-system-object term))) | |
| 249 | (when (chaos-list-p obj) | |
| 250 | (setq obj (chaos-list-list obj))) | |
| 251 | (if (or (atom obj) (is-ast obj)) | |
| 252 | (prin1 obj stream) | |
| 253 | (progn | |
| 254 | (princ ":[" stream) | |
| 255 | (format stream "~{~S~^,~}" obj) | |
| 256 | (princ "]" stream))))) | |
| 256 | 257 | ((term$is-builtin-constant? body) |
| 257 | 258 | (princ (bconst-print-string term) stream)) |
| 258 | 259 | ((term$is-lisp-form? body) |
| 259 | 260 | (if (term$is-simple-lisp-form? body) |
| 260 | 261 | (princ "#! " stream) |
| 261 | 262 | (princ "#!! " stream)) |
| 262 | (let ((*print-pretty* t)) | |
| 263 | (format t "~s" (term$lisp-form-original-form body)))) | |
| 263 | (let ((*print-pretty* t)) | |
| 264 | (format t "~s" (term$lisp-form-original-form body)))) | |
| 264 | 265 | ((term$is-applform? body) |
| 265 | 266 | (let* ((hd (term$head body)) |
| 266 | 267 | (op (method-operator hd))) |
| 267 | 268 | (cond ((not (operator-is-mixfix op)) |
| 268 | (princ (format nil "~{~a~^ ~}" (operator-symbol op)) stream) | |
| 269 | (princ (format nil "~{~a~^ ~}" (operator-symbol op)) stream) | |
| 269 | 270 | (let ((subs (term$subterms body))) |
| 270 | 271 | (when subs |
| 271 | 272 | (princ "(") |
| 273 | 274 | (dolist (i subs) |
| 274 | 275 | (if flg |
| 275 | 276 | (progn (princ ",")) |
| 276 | (setq flg t)) | |
| 277 | (setq flg t)) | |
| 277 | 278 | (term-print1 i stream print-var-sort vars-so-far))) |
| 278 | 279 | (princ ")")))) |
| 279 | ;; mix fix | |
| 280 | ;; mix fix | |
| 280 | 281 | (t (let ((subs (term$subterms body)) |
| 281 | (token-seq (operator-token-sequence op)) | |
| 282 | (token-seq (operator-token-sequence op)) | |
| 282 | 283 | (prv nil)) |
| 283 | 284 | (princ "(" stream) |
| 284 | 285 | (dolist (i token-seq) |
| 294 | 295 | (t (print-check .file-col. (+ 2 (length (string i))) stream) |
| 295 | 296 | (princ i stream)))) |
| 296 | 297 | (princ ")" stream)))))) |
| 297 | ;; what is this? | |
| 298 | ;; what is this? | |
| 298 | 299 | (t (format stream "~s" body))))) |
| 299 | 300 | |
| 300 | 301 | ;;; pretty printer |
| 330 | 331 | print-var-sort |
| 331 | 332 | vars-so-far))) |
| 332 | 333 | (princ vstr stream))) |
| 333 | ((term-is-system-object? term) | |
| 334 | (let ((obj (term-system-object term))) | |
| 335 | (when (chaos-list-p obj) | |
| 336 | (setq obj (chaos-list-list obj))) | |
| 337 | (if (or (atom obj) (is-ast obj)) | |
| 338 | (prin1 obj stream) | |
| 339 | (progn | |
| 340 | (princ "[:: " stream) | |
| 341 | (dolist (x obj) | |
| 342 | (term-print2 x prec stream print-var-sort vars-so-far)) | |
| 343 | (princ "]" stream))))) | |
| 334 | ((term-is-system-object? term) | |
| 335 | (let ((obj (term-system-object term))) | |
| 336 | (when (chaos-list-p obj) | |
| 337 | (setq obj (chaos-list-list obj))) | |
| 338 | (if (or (atom obj) (is-ast obj)) | |
| 339 | (prin1 obj stream) | |
| 340 | (progn | |
| 341 | (princ "[:: " stream) | |
| 342 | (dolist (x obj) | |
| 343 | (term-print2 x prec stream print-var-sort vars-so-far)) | |
| 344 | (princ "]" stream))))) | |
| 344 | 345 | ((term-is-builtin-constant? term) |
| 345 | 346 | (let ((bstr (bconst-print-string term))) |
| 346 | 347 | (princ bstr stream))) |
| 347 | 348 | ;; |
| 348 | 349 | ((term-is-lisp-form? term) |
| 349 | (let ((*print-pretty* t)) | |
| 350 | (if (term-is-simple-lisp-form? term) | |
| 351 | (princ "#! ") | |
| 350 | (let ((*print-pretty* t)) | |
| 351 | (if (term-is-simple-lisp-form? term) | |
| 352 | (princ "#! ") | |
| 352 | 353 | (princ "#!! ")) |
| 353 | (format t "~s" (lisp-form-original-form term)))) | |
| 354 | (format t "~s" (lisp-form-original-form term)))) | |
| 354 | 355 | ;; application form |
| 355 | 356 | ((term-is-applform? term) |
| 356 | 357 | (let* ((hd (term-head term)) |
| 384 | 385 | (<= prec (get-method-precedence hd)))) |
| 385 | 386 | (assoc-test (method-is-associative hd)) |
| 386 | 387 | (token-seq (operator-token-sequence |
| 387 | (method-operator hd)))) | |
| 388 | (method-operator hd))) | |
| 389 | (some-eql-form? nil)) | |
| 390 | (when (equal '("_" "=" "_") | |
| 391 | (car (method-name hd))) | |
| 392 | (setq some-eql-form? t)) | |
| 388 | 393 | (setq .file-col. (file-column stream)) |
| 389 | (when prec-test | |
| 394 | (when (or prec-test some-eql-form?) | |
| 390 | 395 | (princ "(" stream) |
| 391 | 396 | (setq .file-col. (1+ .file-col.))) |
| 392 | 397 | ;; |
| 393 | 398 | (let ((subs (term-subterms term)) |
| 394 | 399 | (prv nil)) |
| 395 | (do* ((tseq token-seq (cdr tseq)) | |
| 396 | (i (car tseq) (car tseq))) | |
| 397 | ((endp tseq)) | |
| 400 | (do* ((tseq token-seq (cdr tseq)) | |
| 401 | (i (car tseq) (car tseq))) | |
| 402 | ((endp tseq)) | |
| 398 | 403 | (when prv |
| 399 | 404 | (princ #\space stream)) |
| 400 | 405 | (setq prv t) |
| 401 | 406 | (cond ((eq i t) |
| 402 | (let ((tm (car subs))) | |
| 403 | (term-print2 tm | |
| 404 | (if (and assoc-test | |
| 405 | tm | |
| 406 | (term-is-application-form? tm) | |
| 407 | (method-is-of-same-operator | |
| 408 | (term-head term) | |
| 409 | (term-head tm))) | |
| 410 | parser-max-precedence | |
| 411 | (or (get-method-precedence hd) 0)) | |
| 412 | stream | |
| 413 | print-var-sort | |
| 414 | vars-so-far) | |
| 415 | (setq subs (cdr subs)))) | |
| 416 | (t (let ((name (string i))) | |
| 417 | (princ name stream) | |
| 418 | (print-check .file-col. 20 stream)))))) | |
| 419 | (when prec-test (princ ")" stream))))))) | |
| 407 | (let ((tm (car subs))) | |
| 408 | (term-print2 tm | |
| 409 | (if (and assoc-test | |
| 410 | tm | |
| 411 | (term-is-application-form? tm) | |
| 412 | (method-is-of-same-operator | |
| 413 | (term-head term) | |
| 414 | (term-head tm))) | |
| 415 | parser-max-precedence | |
| 416 | (or (get-method-precedence hd) 0)) | |
| 417 | stream | |
| 418 | print-var-sort | |
| 419 | vars-so-far) | |
| 420 | (setq subs (cdr subs)))) | |
| 421 | (t (let ((name (string i))) | |
| 422 | (princ name stream) | |
| 423 | (print-check .file-col. 20 stream)))))) | |
| 424 | (when (or prec-test some-eql-form?) (princ ")" stream))))))) | |
| 420 | 425 | (t (format stream "(~s)" (term-body term)))))) |
| 421 | 426 | |
| 422 | 427 | (defun term-print (term &optional (stream *standard-output*) |
| 539 | 544 | ((symbolp value) |
| 540 | 545 | (string value)) |
| 541 | 546 | (t (format nil "(~s)" value)))) |
| 542 | (if (term-is-variable? term) | |
| 543 | (string (variable-print-name term)) | |
| 544 | (if (term-is-lisp-form? term) | |
| 545 | (lisp-form-original-form term) | |
| 546 | (if (and *chaos-verbose* | |
| 547 | (term-is-reduced? term)) | |
| 548 | (format nil "!~{~a~}" (method-symbol (term-head term))) | |
| 549 | (format nil "~{~a~}" | |
| 550 | (method-symbol (term-head term)))))))) | |
| 547 | (if (term-is-variable? term) | |
| 548 | (string (variable-print-name term)) | |
| 549 | (if (term-is-lisp-form? term) | |
| 550 | (lisp-form-original-form term) | |
| 551 | (if (and *chaos-verbose* | |
| 552 | (term-is-reduced? term)) | |
| 553 | (format nil "!~{~a~}" (method-symbol (term-head term))) | |
| 554 | (format nil "~{~a~}" | |
| 555 | (method-symbol (term-head term)))))))) | |
| 551 | 556 | (sort (term-sort term))) |
| 552 | 557 | (if *show-sort* |
| 553 | 558 | (format nil "~a:~a" name (string (if sort |
| 590 | 595 | (cond ((chaos-ast? object) |
| 591 | 596 | (let ((printer (ast-printer object))) |
| 592 | 597 | (if printer |
| 593 | (let ((mod (or *current-module* *last-module*))) | |
| 598 | (let ((mod (get-context-module t))) | |
| 594 | 599 | (if mod |
| 595 | 600 | (with-in-module (mod) |
| 596 | 601 | (funcall printer object stream)) |
| 601 | 606 | ((and (chaos-object? object) (not (stringp object))) |
| 602 | 607 | (let ((printer (object-printer object))) |
| 603 | 608 | (if printer |
| 604 | (let ((mod (or *current-module* | |
| 605 | *last-module*))) | |
| 609 | (let ((mod (get-context-module t))) | |
| 606 | 610 | (if mod |
| 607 | 611 | (with-in-module (mod) |
| 608 | 612 | (funcall printer object stream)) |
| 611 | 615 | (*print-pretty* nil)) |
| 612 | 616 | (prin1 object stream))))) |
| 613 | 617 | ((term? object) |
| 614 | (let ((mod (or *current-module* *last-module*))) | |
| 618 | (let ((mod (get-context-module t))) | |
| 615 | 619 | (if mod |
| 616 | 620 | (with-in-module (mod) |
| 617 | 621 | (term-print object stream)) |
| 619 | 623 | ((opinfo-p object) |
| 620 | 624 | (fresh-line stream) |
| 621 | 625 | (print-chaos-object (opinfo-operator object) stream) |
| 622 | (format stream "~&-- delcrations -------------------") | |
| 626 | (format stream "~%-- delcrations -------------------") | |
| 623 | 627 | (dolist (meth (opinfo-methods object)) |
| 624 | 628 | (print-next) |
| 625 | 629 | (print-chaos-object meth stream))) |
| 747 | 751 | ;;; HASH TABLE |
| 748 | 752 | |
| 749 | 753 | (defun dump-chaos-hash (hash-table &optional (title "chaos hash table dump")) |
| 750 | (format t "~&~a__________________________" title) | |
| 754 | (format t "~%~a__________________________" title) | |
| 751 | 755 | (maphash #'(lambda (key value) |
| 752 | 756 | (format t "~&key(type:~a) = | ~a ~% " (type-of key) key) |
| 753 | 757 | (print-chaos-object key) |
| 758 | 762 | (ast-type value) |
| 759 | 763 | 'unknown))) |
| 760 | 764 | (print-chaos-object value) |
| 761 | (format t "~&----------------------------------------")) | |
| 765 | (format t "~%----------------------------------------")) | |
| 762 | 766 | hash-table)) |
| 763 | 767 | |
| 764 | 768 | ;;; ASSOC TABLE |
| 765 | 769 | (defun dump-chaos-assoc-table (table &optional (title "chaos assoc table dump")) |
| 766 | (format t "~&~a__________________________" title) | |
| 770 | (format t "~%~a__________________________" title) | |
| 767 | 771 | (dolist (entry table) |
| 768 | 772 | (let ((key (car entry)) |
| 769 | 773 | (value (cdr entry))) |
| 775 | 779 | (object-type value) |
| 776 | 780 | (if (chaos-ast? value) |
| 777 | 781 | (ast-type value) |
| 778 | (type-of value) | |
| 779 | ))) | |
| 782 | (type-of value)))) | |
| 780 | 783 | (print-chaos-object value) |
| 781 | (format t "~&----------------------------------------")))) | |
| 784 | (format t "~%----------------------------------------")))) | |
| 782 | 785 | |
| 783 | 786 | (defun dump-modexp-local () |
| 784 | 787 | (dump-chaos-assoc-table *modexp-local-table* "Moduexp Local ")) |
| 0 | 0 | ;;;-*- Mode:LISP; Package: Chaos; Base:10; Syntax:Common-lisp -*- |
| 1 | 1 | ;;; |
| 2 | ;;; Copyright (c) 2000-2014, Toshimi Sawada. All rights reserved. | |
| 2 | ;;; Copyright (c) 2000-2015, Toshimi Sawada. All rights reserved. | |
| 3 | 3 | ;;; |
| 4 | 4 | ;;; Redistribution and use in source and binary forms, with or without |
| 5 | 5 | ;;; modification, are permitted provided that the following conditions |
| 227 | 227 | (return-from get-importing-path |
| 228 | 228 | (nconc path im2)))))))))) |
| 229 | 229 | |
| 230 | (defun get-real-importing-mode (module2 &optional (module (or *current-module* | |
| 231 | *last-module*))) | |
| 230 | (defun get-real-importing-mode (module2 &optional (module (get-context-module))) | |
| 232 | 231 | (declare (type module module2 module) |
| 233 | 232 | (values symbol)) |
| 234 | 233 | ;; |
| 0 | 0 | ;;;-*- Mode:LISP; Package: Chaos; Base:10; Syntax:Common-lisp -*- |
| 1 | 1 | ;;; |
| 2 | ;;; Copyright (c) 2000-2014, Toshimi Sawada. All rights reserved. | |
| 2 | ;;; Copyright (c) 2000-2015, Toshimi Sawada. All rights reserved. | |
| 3 | 3 | ;;; |
| 4 | 4 | ;;; Redistribution and use in source and binary forms, with or without |
| 5 | 5 | ;;; modification, are permitted provided that the following conditions |
| 0 | 0 | ;;;-*- Mode:LISP; Package: Chaos; Base:10; Syntax:Common-lisp -*- |
| 1 | 1 | ;;; |
| 2 | ;;; Copyright (c) 2000-2014, Toshimi Sawada. All rights reserved. | |
| 2 | ;;; Copyright (c) 2000-2015, Toshimi Sawada. All rights reserved. | |
| 3 | 3 | ;;; |
| 4 | 4 | ;;; Redistribution and use in source and binary forms, with or without |
| 5 | 5 | ;;; modification, are permitted provided that the following conditions |
| 0 | 0 | ;;;-*-Mode:LISP; Package: Chaos; Base:10; Syntax:Common-lisp -*- |
| 1 | 1 | ;;; |
| 2 | ;;; Copyright (c) 2000-2014, Toshimi Sawada. All rights reserved. | |
| 2 | ;;; Copyright (c) 2000-2015, Toshimi Sawada. All rights reserved. | |
| 3 | 3 | ;;; |
| 4 | 4 | ;;; Redistribution and use in source and binary forms, with or without |
| 5 | 5 | ;;; modification, are permitted provided that the following conditions |
| 0 | 0 | ;;;-*- Mode:LISP; Package:CHAOS; Base:10; Syntax:Common-lisp -*- |
| 1 | 1 | ;;; |
| 2 | ;;; Copyright (c) 2000-2014, Toshimi Sawada. All rights reserved. | |
| 2 | ;;; Copyright (c) 2000-2015, Toshimi Sawada. All rights reserved. | |
| 3 | 3 | ;;; |
| 4 | 4 | ;;; Redistribution and use in source and binary forms, with or without |
| 5 | 5 | ;;; modification, are permitted provided that the following conditions |
| 27 | 27 | ;;; |
| 28 | 28 | (in-package :chaos) |
| 29 | 29 | #|============================================================================== |
| 30 | System: CHAOS | |
| 31 | Module: primitives | |
| 32 | File: normodexp.lisp | |
| 30 | System: CHAOS | |
| 31 | Module: primitives | |
| 32 | File: normodexp.lisp | |
| 33 | 33 | ==============================================================================|# |
| 34 | 34 | #-:chaos-debug |
| 35 | 35 | (declaim (optimize (speed 3) (safety 0) #-GCL (debug 0))) |
| 58 | 58 | |
| 59 | 59 | (defun find-normalized-modexp (modexp) |
| 60 | 60 | (declare (type modexp modexp) |
| 61 | (values (or null modexp))) | |
| 61 | (values (or null modexp))) | |
| 62 | 62 | (find-in-assoc-table *modexp-normalized-table* modexp)) |
| 63 | 63 | |
| 64 | 64 | (defun add-modexp-normalized (modexp) |
| 65 | 65 | (declare (type modexp) |
| 66 | (values t)) | |
| 66 | (values t)) | |
| 67 | 67 | (add-to-assoc-table *modexp-normalized-table* modexp modexp)) |
| 68 | 68 | |
| 69 | 69 | |
| 77 | 77 | (setq modexp (car modexp))) |
| 78 | 78 | ;; |
| 79 | 79 | (when (and (equal modexp "*the-current-module*") |
| 80 | *current-module*) | |
| 81 | (setq modexp *current-module*)) | |
| 82 | ;; (when (and (equal modexp "THE-LAST-MODULE") *last-module*) | |
| 83 | ;; (setq modexp *last-module*)) | |
| 84 | ;; | |
| 80 | (get-context-module t)) | |
| 81 | (setq modexp (get-context-module))) | |
| 85 | 82 | (cond ((module-p modexp) (normalize-modexp (module-name modexp))) |
| 86 | ((stringp modexp) (canonicalize-simple-module-name modexp)) | |
| 87 | ((atom modexp) modexp) | |
| 88 | ((modexp-is-?name? modexp) | |
| 89 | (make-?-name (normalize-modexp (?name-name modexp)))) | |
| 90 | ((modexp-is-parameter-theory modexp) | |
| 91 | (let ((norm (find-normalized-modexp modexp))) | |
| 92 | (if norm norm | |
| 93 | (progn (add-modexp-normalized modexp) | |
| 94 | modexp)))) | |
| 95 | (t (let ((norm (find-normalized-modexp modexp))) | |
| 96 | (if norm norm | |
| 97 | (progn | |
| 98 | (setq norm (do-normalize-modexp modexp)) | |
| 99 | (add-modexp-normalized norm) | |
| 100 | norm)))))) | |
| 83 | ((stringp modexp) (canonicalize-simple-module-name modexp)) | |
| 84 | ((atom modexp) modexp) | |
| 85 | ((modexp-is-?name? modexp) | |
| 86 | (make-?-name (normalize-modexp (?name-name modexp)))) | |
| 87 | ((modexp-is-parameter-theory modexp) | |
| 88 | (let ((norm (find-normalized-modexp modexp))) | |
| 89 | (if norm norm | |
| 90 | (progn (add-modexp-normalized modexp) | |
| 91 | modexp)))) | |
| 92 | (t (let ((norm (find-normalized-modexp modexp))) | |
| 93 | (if norm norm | |
| 94 | (progn | |
| 95 | (setq norm (do-normalize-modexp modexp)) | |
| 96 | (add-modexp-normalized norm) | |
| 97 | norm)))))) | |
| 101 | 98 | |
| 102 | 99 | (defun canonicalize-simple-module-name (me) |
| 103 | 100 | #|| |
| 104 | 101 | (when (and (not (find-module-in-env me nil)) |
| 105 | *current-module* | |
| 106 | (get-modexp-local (list me (module-name *current-module*)))) | |
| 102 | *current-module* | |
| 103 | (get-modexp-local (list me (module-name *current-module*)))) | |
| 107 | 104 | (setq me (concatenate 'string me "." (module-name *current-module*)))) |
| 108 | 105 | ||# |
| 109 | 106 | (let ((real-me (find-normalized-modexp me))) |
| 110 | 107 | (if real-me |
| 111 | real-me | |
| 112 | (progn | |
| 113 | (add-modexp-normalized me) | |
| 114 | me)))) | |
| 115 | ||
| 108 | real-me | |
| 109 | (progn | |
| 110 | (add-modexp-normalized me) | |
| 111 | me)))) | |
| 112 | ||
| 116 | 113 | ;;; DO-NORMALIZE-MODEXP modexp |
| 117 | 114 | ;;; perform canonicalization on modexp. known not to be in canonical form |
| 118 | 115 | ;;; ops %+, %*, %view, %view-under |
| 120 | 117 | (defun do-normalize-modexp (modexp) |
| 121 | 118 | (declare (type (or module view-struct modexp) modexp)) |
| 122 | 119 | (cond ((module-p modexp) modexp) |
| 123 | ((view-p modexp) modexp) | |
| 124 | ((%is-plus modexp) ; right associate and re-order | |
| 125 | (normalize-plus modexp)) | |
| 126 | ((%is-rename modexp) | |
| 127 | (normalize-rename modexp)) | |
| 128 | ((%is-instantiation modexp) | |
| 129 | (normalize-instantiation modexp)) | |
| 130 | ;; need to have corresponding theory to be able to interpret view | |
| 131 | ((%is-view modexp) (normalize-view modexp)) | |
| 132 | ;; internal error | |
| 133 | (t (break "Internal error : do-normalize-modexp: bad modexp form ")) | |
| 134 | )) | |
| 120 | ((view-p modexp) modexp) | |
| 121 | ((%is-plus modexp) ; right associate and re-order | |
| 122 | (normalize-plus modexp)) | |
| 123 | ((%is-rename modexp) | |
| 124 | (normalize-rename modexp)) | |
| 125 | ((%is-instantiation modexp) | |
| 126 | (normalize-instantiation modexp)) | |
| 127 | ;; need to have corresponding theory to be able to interpret view | |
| 128 | ((%is-view modexp) (normalize-view modexp)) | |
| 129 | ;; internal error | |
| 130 | (t (break "Internal error : do-normalize-modexp: bad modexp form ")) | |
| 131 | )) | |
| 135 | 132 | |
| 136 | 133 | ;;; NORMALIZE-RENAME |
| 137 | 134 | ;;; |
| 138 | 135 | (defun normalize-rename (modexp) |
| 139 | 136 | (declare (type modexp) |
| 140 | (values modexp)) | |
| 137 | (values modexp)) | |
| 141 | 138 | (setf (%rename-module modexp) (normalize-modexp (%rename-module modexp))) |
| 142 | 139 | (setf (%rename-map modexp) (normalize-rename-map (%rename-map modexp))) |
| 143 | 140 | modexp) |
| 148 | 145 | ;;; |
| 149 | 146 | (defun normalize-plus (modexp) |
| 150 | 147 | (declare (type modexp modexp) |
| 151 | (values modexp)) | |
| 148 | (values modexp)) | |
| 152 | 149 | (setf (%plus-args modexp) |
| 153 | (sort (remove-duplicates (mapcar #'normalize-modexp (%plus-args modexp))) | |
| 154 | #'ob<)) | |
| 150 | (sort (remove-duplicates (mapcar #'normalize-modexp (%plus-args modexp))) | |
| 151 | #'ob<)) | |
| 155 | 152 | modexp) |
| 156 | 153 | |
| 157 | 154 | ;;; NORMALZE-INSTANTIATION |
| 158 | 155 | ;;; |
| 159 | 156 | (defun normalize-instantiation (modexp) |
| 160 | 157 | (declare (type modexp modexp) |
| 161 | (values modexp)) | |
| 158 | (values modexp)) | |
| 162 | 159 | (setf (%instantiation-module modexp) |
| 163 | (normalize-modexp (%instantiation-module modexp))) | |
| 160 | (normalize-modexp (%instantiation-module modexp))) | |
| 164 | 161 | (setf (%instantiation-args modexp) |
| 165 | (normalize-instantiation-args (%instantiation-args modexp))) | |
| 162 | (normalize-instantiation-args (%instantiation-args modexp))) | |
| 166 | 163 | modexp) |
| 167 | 164 | |
| 168 | 165 | #|| |
| 169 | 166 | (defun normalize-instantiation-args (args) |
| 170 | 167 | (let ((r-res (sort args #'(lambda (x y) |
| 171 | (let ((arg-x (%!arg-name x)) | |
| 172 | (arg-y (%!arg-name y))) | |
| 173 | (if (integerp arg-x) | |
| 174 | (< arg-x arg-y) | |
| 175 | (string< (string (if (consp arg-x) | |
| 176 | (car arg-x) | |
| 177 | arg-y)) | |
| 178 | (string (if (consp arg-y) | |
| 179 | (car arg-y) | |
| 180 | arg-y))))))))) | |
| 168 | (let ((arg-x (%!arg-name x)) | |
| 169 | (arg-y (%!arg-name y))) | |
| 170 | (if (integerp arg-x) | |
| 171 | (< arg-x arg-y) | |
| 172 | (string< (string (if (consp arg-x) | |
| 173 | (car arg-x) | |
| 174 | arg-y)) | |
| 175 | (string (if (consp arg-y) | |
| 176 | (car arg-y) | |
| 177 | arg-y))))))))) | |
| 181 | 178 | (dolist (arg r-res) |
| 182 | 179 | (setf (%!arg-view arg) |
| 183 | (normalize-view (%!arg-view arg)))) | |
| 180 | (normalize-view (%!arg-view arg)))) | |
| 184 | 181 | r-res)) |
| 185 | 182 | ||# |
| 186 | 183 | |
| 187 | 184 | (defun normalize-instantiation-args (args) |
| 188 | 185 | (declare (type list args) |
| 189 | (values list)) | |
| 186 | (values list)) | |
| 190 | 187 | (dolist (arg args) |
| 191 | 188 | (setf (%!arg-view arg) |
| 192 | ;;; (normalize-view (%!arg-view arg)) | |
| 193 | (normalize-modexp (%!arg-view arg)) | |
| 194 | )) | |
| 189 | ;;; (normalize-view (%!arg-view arg)) | |
| 190 | (normalize-modexp (%!arg-view arg)) | |
| 191 | )) | |
| 195 | 192 | args) |
| 196 | 193 | |
| 197 | 194 | ;;; |
| 198 | 195 | (defun reorder-maps (maps) |
| 199 | 196 | (declare (type list maps) |
| 200 | (values list)) | |
| 197 | (values list)) | |
| 201 | 198 | (when maps |
| 202 | 199 | (sort maps #'(lambda (x y) (ob< (car x) (car y)))))) |
| 203 | 200 | |
| 204 | 201 | (defun normalize-rename-map (rmap) |
| 205 | 202 | (declare (type list rmap) |
| 206 | (values list)) | |
| 203 | (values list)) | |
| 207 | 204 | (let* ((rmap-body (%rmap-map rmap)) |
| 208 | (sort-map (reorder-maps (cadr (assq '%ren-sort rmap-body)))) | |
| 209 | (hsort-map (reorder-maps (cadr (assq '%ren-hsort rmap-body)))) | |
| 210 | (op-map (reorder-maps (cadr (assq '%ren-op rmap-body)))) | |
| 211 | (bop-map (reorder-maps (cadr (assq '%ren-bop rmap-body)))) | |
| 212 | (p-map (reorder-maps (cadr (assq '%vars rmap-body))))) | |
| 205 | (sort-map (reorder-maps (cadr (assq '%ren-sort rmap-body)))) | |
| 206 | (hsort-map (reorder-maps (cadr (assq '%ren-hsort rmap-body)))) | |
| 207 | (op-map (reorder-maps (cadr (assq '%ren-op rmap-body)))) | |
| 208 | (bop-map (reorder-maps (cadr (assq '%ren-bop rmap-body)))) | |
| 209 | (p-map (reorder-maps (cadr (assq '%vars rmap-body))))) | |
| 213 | 210 | (setf (%rmap-map rmap) |
| 214 | (nconc (when sort-map (list (%ren-sort* sort-map))) | |
| 215 | (when hsort-map (list (%ren-hsort* hsort-map))) | |
| 216 | (when op-map (list (%ren-op* op-map))) | |
| 217 | (when bop-map (list (%ren-bop* bop-map))) | |
| 218 | (if p-map (list (%vars* p-map))))) | |
| 211 | (nconc (when sort-map (list (%ren-sort* sort-map))) | |
| 212 | (when hsort-map (list (%ren-hsort* hsort-map))) | |
| 213 | (when op-map (list (%ren-op* op-map))) | |
| 214 | (when bop-map (list (%ren-bop* bop-map))) | |
| 215 | (if p-map (list (%vars* p-map))))) | |
| 219 | 216 | rmap)) |
| 220 | 217 | |
| 221 | 218 | ;;; NORMALIZE-VIEW |
| 222 | 219 | ;;; |
| 223 | 220 | (defun normalize-view (view) |
| 224 | 221 | (declare (type modexp view) |
| 225 | (type modexp)) | |
| 222 | (type modexp)) | |
| 226 | 223 | (setf (%view-module view) (normalize-modexp (%view-module view))) |
| 227 | 224 | (setf (%view-target view) (normalize-modexp (%view-target view))) |
| 228 | 225 | (when (%view-map view) |
| 0 | 0 | ;;;-*-Mode:LISP; Package: CHAOS; Base:10; Syntax:Common-lisp -*- |
| 1 | 1 | ;;; |
| 2 | ;;; Copyright (c) 2000-2014, Toshimi Sawada. All rights reserved. | |
| 2 | ;;; Copyright (c) 2000-2015, Toshimi Sawada. All rights reserved. | |
| 3 | 3 | ;;; |
| 4 | 4 | ;;; Redistribution and use in source and binary forms, with or without |
| 5 | 5 | ;;; modification, are permitted provided that the following conditions |
| 27 | 27 | ;;; |
| 28 | 28 | (in-package :chaos) |
| 29 | 29 | #|============================================================================= |
| 30 | System:CHAOS | |
| 31 | Module: primitives | |
| 32 | File: op-theory.lisp | |
| 30 | System:CHAOS | |
| 31 | Module: primitives | |
| 32 | File: op-theory.lisp | |
| 33 | 33 | =============================================================================|# |
| 34 | 34 | #-:chaos-debug |
| 35 | 35 | (declaim (optimize (speed 3) (safety 0) #-GCL (debug 0))) |
| 37 | 37 | (declaim (optimize (speed 1) (safety 3) #-GCL (debug 3))) |
| 38 | 38 | |
| 39 | 39 | ;;;============================================================================= |
| 40 | ;;; OPERATOR THEORY | |
| 40 | ;;; OPERATOR THEORY | |
| 41 | 41 | ;;;============================================================================= |
| 42 | 42 | |
| 43 | 43 | ;;; *************** |
| 85 | 85 | |
| 86 | 86 | (defun zero-rule-only (th) |
| 87 | 87 | (declare (type op-theory th) |
| 88 | (values (or null t))) | |
| 88 | (values (or null t))) | |
| 89 | 89 | (let ((val (theory-zero th))) |
| 90 | 90 | (and val (cdr val)))) |
| 91 | 91 | |
| 135 | 135 | `(the symbol (svref ,_th_ 8))) |
| 136 | 136 | |
| 137 | 137 | (defun new-theory-info (name code empty-for-unify match-equal-fun match-init-fun |
| 138 | match-next-fun unify-equal-fun unify-init-fun unify-next-fun) | |
| 138 | match-next-fun unify-equal-fun unify-init-fun unify-next-fun) | |
| 139 | 139 | (declare (type symbol name match-equal-fun match-init-fun |
| 140 | match-next-fun unify-equal-fun unify-init-fun | |
| 141 | unify-next-fun) | |
| 142 | (type (or null t) empty-for-unify) | |
| 143 | (type fixnum code) | |
| 144 | (values theory-info)) | |
| 140 | match-next-fun unify-equal-fun unify-init-fun | |
| 141 | unify-next-fun) | |
| 142 | (type (or null t) empty-for-unify) | |
| 143 | (type fixnum code) | |
| 144 | (values theory-info)) | |
| 145 | 145 | (let ((th (alloc-svec 9))) |
| 146 | 146 | (declare (type theory-info th)) |
| 147 | 147 | (setf (theory-info-name th) name) |
| 148 | 148 | (setf (theory-info-code th) code) |
| 149 | 149 | (setf (theory-info-empty-for-unify th) empty-for-unify |
| 150 | (theory-info-match-equal-fun th) match-equal-fun | |
| 151 | (theory-info-match-init-fun th) match-init-fun | |
| 152 | (theory-info-match-next-fun th) match-next-fun | |
| 153 | (theory-info-unify-equal-fun th) unify-equal-fun | |
| 154 | (theory-info-unify-init-fun th) unify-init-fun | |
| 155 | (theory-info-unify-next-fun th) unify-next-fun) | |
| 150 | (theory-info-match-equal-fun th) match-equal-fun | |
| 151 | (theory-info-match-init-fun th) match-init-fun | |
| 152 | (theory-info-match-next-fun th) match-next-fun | |
| 153 | (theory-info-unify-equal-fun th) unify-equal-fun | |
| 154 | (theory-info-unify-init-fun th) unify-init-fun | |
| 155 | (theory-info-unify-next-fun th) unify-next-fun) | |
| 156 | 156 | th)) |
| 157 | ||
| 158 | (defun pr-theory-info (th-info) | |
| 159 | (format t "~%#<Theory ~s : init = ~s" | |
| 160 | (theory-info-name th-info) | |
| 161 | (theory-info-match-init-fun th-info))) | |
| 157 | 162 | |
| 158 | 163 | (defun pr-optheory-internal (opth stream &rest ignore) |
| 159 | 164 | (declare (ignore ignore)) |
| 160 | 165 | (format stream "#<Theory ~s : zero = ~s>" |
| 161 | (theory-info-name (theory-info opth)) | |
| 162 | (theory-zero opth))) | |
| 166 | (theory-info-name (theory-info opth)) | |
| 167 | (theory-zero opth))) | |
| 163 | 168 | |
| 164 | 169 | (defun is-operator-theory? (object) |
| 165 | 170 | (declare (type t object) |
| 166 | (values (or null t))) | |
| 171 | (values (or null t))) | |
| 167 | 172 | (and (consp object) |
| 168 | 173 | (typep (car object) 'vector) |
| 169 | 174 | (= 9 (length (the vector (car object)))))) |
| 193 | 198 | ;;; theory informations. |
| 194 | 199 | ;;; |
| 195 | 200 | ;;(declaim (special .E. .Z. .I. .C. .A. .AC. .AI. .AZ. .CZ. .CI. .IZ. .ACI. |
| 196 | ;; .ACZ. .CIZ. .AIZ. .ACIZ.)) | |
| 201 | ;; .ACZ. .CIZ. .AIZ. .ACIZ.)) | |
| 197 | 202 | |
| 198 | 203 | (eval-when (:execute :compile-toplevel :load-toplevel) |
| 199 | 204 | (defconstant .E. 0) |
| 219 | 224 | (defmacro test-theory (_x _y) |
| 220 | 225 | `(the (or null t) |
| 221 | 226 | (not (= 0 (logand (the fixnum ,_x) |
| 222 | (the fixnum ,_y)))))) | |
| 227 | (the fixnum ,_y)))))) | |
| 223 | 228 | #+gcl |
| 224 | 229 | (defmacro test-theory (_x _y) `(test-and (the fixnum ,_x) (the fixnum ,_y))) |
| 225 | 230 | ;;; |
| 244 | 249 | ;;; |
| 245 | 250 | (defun create-theory (code-or-info zero) |
| 246 | 251 | (declare (type (or fixnum theory-info) code-or-info) |
| 247 | (type (or null t) zero) | |
| 248 | (values op-theory)) | |
| 252 | (type (or null t) zero) | |
| 253 | (values op-theory)) | |
| 249 | 254 | (theory-make (if (numberp code-or-info) |
| 250 | (theory-code-to-info code-or-info) | |
| 251 | code-or-info) | |
| 252 | zero)) | |
| 253 | ||
| 254 | (declaim (special the-e-property ; .E. | |
| 255 | the-z-property ; .Z. | |
| 256 | the-i-property ; .I. | |
| 257 | the-iz-property ; .IZ. | |
| 258 | the-c-property ; .C. | |
| 259 | the-cz-property ; .CZ. | |
| 260 | the-ci-property ; .CI. | |
| 261 | the-ciz-property ; .CIZ. | |
| 262 | the-a-property ; .A. | |
| 263 | the-az-property ; .AZ. | |
| 264 | the-ai-property ; .AI. | |
| 265 | the-ac-property ; .AC. | |
| 266 | the-acz-property ; .ACZ. | |
| 267 | the-aci-property ; .ACI. | |
| 268 | the-aiz-property ; .AIZ. | |
| 269 | the-aciz-property)) ; .ACIZ. | |
| 255 | (theory-code-to-info code-or-info) | |
| 256 | code-or-info) | |
| 257 | zero)) | |
| 258 | ||
| 259 | (declaim (special the-e-property ; .E. | |
| 260 | the-z-property ; .Z. | |
| 261 | the-i-property ; .I. | |
| 262 | the-iz-property ; .IZ. | |
| 263 | the-c-property ; .C. | |
| 264 | the-cz-property ; .CZ. | |
| 265 | the-ci-property ; .CI. | |
| 266 | the-ciz-property ; .CIZ. | |
| 267 | the-a-property ; .A. | |
| 268 | the-az-property ; .AZ. | |
| 269 | the-ai-property ; .AI. | |
| 270 | the-ac-property ; .AC. | |
| 271 | the-acz-property ; .ACZ. | |
| 272 | the-aci-property ; .ACI. | |
| 273 | the-aiz-property ; .AIZ. | |
| 274 | the-aciz-property)) ; .ACIZ. | |
| 270 | 275 | |
| 271 | 276 | (defmacro define-theory-info (info-name |
| 272 | name | |
| 273 | &key | |
| 274 | empty-for-unify | |
| 275 | match-equal-fun | |
| 276 | match-init-fun | |
| 277 | match-next-fun | |
| 278 | unify-equal-fun | |
| 279 | unify-init-fun | |
| 280 | unify-next-fun) | |
| 277 | name | |
| 278 | &key | |
| 279 | empty-for-unify | |
| 280 | match-equal-fun | |
| 281 | match-init-fun | |
| 282 | match-next-fun | |
| 283 | unify-equal-fun | |
| 284 | unify-init-fun | |
| 285 | unify-next-fun) | |
| 281 | 286 | ` (eval-when (:execute :load-toplevel) |
| 282 | 287 | (setf (aref *theory-info-array* ,name) |
| 283 | (setf ,info-name | |
| 284 | (new-theory-info ',name | |
| 285 | ,name | |
| 286 | ,empty-for-unify | |
| 287 | ',match-equal-fun | |
| 288 | ',match-init-fun | |
| 289 | ',match-next-fun | |
| 290 | ',unify-equal-fun | |
| 291 | ',unify-init-fun | |
| 292 | ',unify-next-fun))))) | |
| 288 | (setf ,info-name | |
| 289 | (new-theory-info ',name | |
| 290 | ,name | |
| 291 | ,empty-for-unify | |
| 292 | ',match-equal-fun | |
| 293 | ',match-init-fun | |
| 294 | ',match-next-fun | |
| 295 | ',unify-equal-fun | |
| 296 | ',unify-init-fun | |
| 297 | ',unify-next-fun))))) | |
| 293 | 298 | |
| 294 | 299 | (define-theory-info the-E-property .E. |
| 295 | 300 | :empty-for-unify t |
| 440 | 445 | (defvar *the-empty-theory*) |
| 441 | 446 | (eval-when (:execute :load-toplevel) |
| 442 | 447 | (setf *the-empty-theory* |
| 443 | (theory-make the-e-property nil))) | |
| 448 | (theory-make the-e-property nil))) | |
| 444 | 449 | |
| 445 | 450 | (defmacro theory-info-is-empty-for-unify (_theory-info) |
| 446 | 451 | `(theory-info-empty-for-unify ,_theory-info)) |
| 513 | 518 | |
| 514 | 519 | (defun theory-info-is-restriction-of-ignoring-id (thn1 thn2) |
| 515 | 520 | (= 0 (logandc2 (theory-info-code thn1) |
| 516 | (logior .Z. (theory-info-code thn2))))) | |
| 521 | (logior .Z. (theory-info-code thn2))))) | |
| 517 | 522 | |
| 518 | 523 | |
| 519 | 524 | ;;; **************** |
| 536 | 541 | (defun E-equal-in-theory-direct (th t1 t2 &optional (unify? nil)) |
| 537 | 542 | (let ((theory-info (theory-info th))) |
| 538 | 543 | (cond ((or (theory-info-is-empty theory-info) |
| 539 | (theory-info-is-Z theory-info) | |
| 540 | (theory-info-is-I theory-info) | |
| 541 | (theory-info-is-IZ theory-info)) | |
| 542 | (if unify? | |
| 543 | (unify-empty-equal t1 t2) | |
| 544 | (match-empty-equal t1 t2))) | |
| 545 | ((or (theory-info-is-AC theory-info) | |
| 546 | (theory-info-is-ACI theory-info) | |
| 547 | (theory-info-is-ACZ theory-info) | |
| 548 | (theory-info-is-ACIZ theory-info)) | |
| 549 | (if unify? | |
| 550 | (unify-AC-equal t1 t2) | |
| 551 | (match-AC-equal t1 t2))) | |
| 552 | ((or (theory-info-is-A theory-info) | |
| 553 | (theory-info-is-AI theory-info) | |
| 554 | (theory-info-is-AZ theory-info) | |
| 555 | (theory-info-is-AIZ theory-info)) | |
| 556 | (if unify? | |
| 557 | (unify-A-equal t1 t2) | |
| 558 | (match-A-equal t1 t2))) | |
| 559 | ((or (theory-info-is-C theory-info) | |
| 560 | (theory-info-is-CI theory-info) | |
| 561 | (theory-info-is-CZ theory-info) | |
| 562 | (theory-info-is-CIZ theory-info)) | |
| 563 | (if unify? | |
| 564 | (unify-C-equal t1 t2) | |
| 565 | (match-C-equal t1 t2)))))) | |
| 544 | (theory-info-is-Z theory-info) | |
| 545 | (theory-info-is-I theory-info) | |
| 546 | (theory-info-is-IZ theory-info)) | |
| 547 | (if unify? | |
| 548 | (unify-empty-equal t1 t2) | |
| 549 | (match-empty-equal t1 t2))) | |
| 550 | ((or (theory-info-is-AC theory-info) | |
| 551 | (theory-info-is-ACI theory-info) | |
| 552 | (theory-info-is-ACZ theory-info) | |
| 553 | (theory-info-is-ACIZ theory-info)) | |
| 554 | (if unify? | |
| 555 | (unify-AC-equal t1 t2) | |
| 556 | (match-AC-equal t1 t2))) | |
| 557 | ((or (theory-info-is-A theory-info) | |
| 558 | (theory-info-is-AI theory-info) | |
| 559 | (theory-info-is-AZ theory-info) | |
| 560 | (theory-info-is-AIZ theory-info)) | |
| 561 | (if unify? | |
| 562 | (unify-A-equal t1 t2) | |
| 563 | (match-A-equal t1 t2))) | |
| 564 | ((or (theory-info-is-C theory-info) | |
| 565 | (theory-info-is-CI theory-info) | |
| 566 | (theory-info-is-CZ theory-info) | |
| 567 | (theory-info-is-CIZ theory-info)) | |
| 568 | (if unify? | |
| 569 | (unify-C-equal t1 t2) | |
| 570 | (match-C-equal t1 t2)))))) | |
| 566 | 571 | |
| 567 | 572 | ||# |
| 568 | 573 | |
| 578 | 583 | (defun theory-contains-associativity-direct (th) |
| 579 | 584 | (let ((theory-info (theory-info th))) |
| 580 | 585 | (and (not (theory-info-is-empty theory-info)) |
| 581 | (or (theory-info-is-A theory-info) | |
| 582 | (theory-info-is-AC theory-info) | |
| 583 | (theory-info-is-AI theory-info) | |
| 584 | (theory-info-is-AZ theory-info) | |
| 585 | (theory-info-is-AIZ theory-info) | |
| 586 | (theory-info-is-ACI theory-info) | |
| 587 | (theory-info-is-ACZ theory-info) | |
| 588 | (theory-info-is-ACIZ theory-info))))) | |
| 586 | (or (theory-info-is-A theory-info) | |
| 587 | (theory-info-is-AC theory-info) | |
| 588 | (theory-info-is-AI theory-info) | |
| 589 | (theory-info-is-AZ theory-info) | |
| 590 | (theory-info-is-AIZ theory-info) | |
| 591 | (theory-info-is-ACI theory-info) | |
| 592 | (theory-info-is-ACZ theory-info) | |
| 593 | (theory-info-is-ACIZ theory-info))))) | |
| 589 | 594 | |
| 590 | 595 | ;;; returns true iff the theory "th" contains the commutativity axiom |
| 591 | 596 | ;;; |
| 595 | 600 | (defun theory-contains-commutativity-direct (th) |
| 596 | 601 | (let ((theory-info (theory-info th))) |
| 597 | 602 | (and (not (theory-info-is-empty theory-info)) |
| 598 | (or (theory-info-is-C theory-info) | |
| 599 | (theory-info-is-AC theory-info) | |
| 600 | (theory-info-is-CI theory-info) | |
| 601 | (theory-info-is-CZ theory-info) | |
| 602 | (theory-info-is-CIZ theory-info) | |
| 603 | (theory-info-is-ACI theory-info) | |
| 604 | (theory-info-is-ACZ theory-info) | |
| 605 | (theory-info-is-ACIZ theory-info))))) | |
| 603 | (or (theory-info-is-C theory-info) | |
| 604 | (theory-info-is-AC theory-info) | |
| 605 | (theory-info-is-CI theory-info) | |
| 606 | (theory-info-is-CZ theory-info) | |
| 607 | (theory-info-is-CIZ theory-info) | |
| 608 | (theory-info-is-ACI theory-info) | |
| 609 | (theory-info-is-ACZ theory-info) | |
| 610 | (theory-info-is-ACIZ theory-info))))) | |
| 606 | 611 | |
| 607 | 612 | (defmacro theory-contains-AC (*th) |
| 608 | 613 | `(test-theory .AC. (theory-info-code (theory-info ,*th)))) |
| 610 | 615 | (defun theory-contains-AC-direct (th) |
| 611 | 616 | (let ((theory-info (theory-info th))) |
| 612 | 617 | (or (theory-info-is-AC theory-info) |
| 613 | (theory-info-is-ACZ theory-info) | |
| 614 | (theory-info-is-ACI theory-info) | |
| 615 | (theory-info-is-ACIZ theory-info)))) | |
| 618 | (theory-info-is-ACZ theory-info) | |
| 619 | (theory-info-is-ACI theory-info) | |
| 620 | (theory-info-is-ACIZ theory-info)))) | |
| 616 | 621 | |
| 617 | 622 | ;;; returns true iff the theory "th" contains the idempotency axiom |
| 618 | 623 | ;;; |
| 622 | 627 | (defun theory-contains-idempotency-direct (th) |
| 623 | 628 | (let ((theory-info (theory-info th))) |
| 624 | 629 | (or (theory-info-is-I theory-info) |
| 625 | (theory-info-is-CI theory-info) | |
| 626 | (theory-info-is-IZ theory-info) | |
| 627 | (theory-info-is-AI theory-info) | |
| 628 | (theory-info-is-AIZ theory-info) | |
| 629 | (theory-info-is-ACI theory-info) | |
| 630 | (theory-info-is-CIZ theory-info) | |
| 631 | (theory-info-is-ACIZ theory-info)))) | |
| 630 | (theory-info-is-CI theory-info) | |
| 631 | (theory-info-is-IZ theory-info) | |
| 632 | (theory-info-is-AI theory-info) | |
| 633 | (theory-info-is-AIZ theory-info) | |
| 634 | (theory-info-is-ACI theory-info) | |
| 635 | (theory-info-is-CIZ theory-info) | |
| 636 | (theory-info-is-ACIZ theory-info)))) | |
| 632 | 637 | |
| 633 | 638 | ;;; returns true iff the theory contains the identity axiom. |
| 634 | 639 | ;;; |
| 638 | 643 | (defun theory-contains-identity-direct (th) |
| 639 | 644 | (let ((theory-info (theory-info th))) |
| 640 | 645 | (or (theory-info-is-Z theory-info) |
| 641 | (theory-info-is-CZ theory-info) | |
| 642 | (theory-info-is-AZ theory-info) | |
| 643 | (theory-info-is-IZ theory-info) | |
| 644 | (theory-info-is-AIZ theory-info) | |
| 645 | (theory-info-is-ACZ theory-info) | |
| 646 | (theory-info-is-CIZ theory-info) | |
| 647 | (theory-info-is-ACIZ theory-info)))) | |
| 646 | (theory-info-is-CZ theory-info) | |
| 647 | (theory-info-is-AZ theory-info) | |
| 648 | (theory-info-is-IZ theory-info) | |
| 649 | (theory-info-is-AIZ theory-info) | |
| 650 | (theory-info-is-ACZ theory-info) | |
| 651 | (theory-info-is-CIZ theory-info) | |
| 652 | (theory-info-is-ACIZ theory-info)))) | |
| 648 | 653 | |
| 649 | 654 | (defmacro theory-contains-ACZ (*th) |
| 650 | 655 | `(test-theory .ACZ. (theory-info-code (theory-info ,*th)))) |
| 652 | 657 | (defun theory-contains-ACZ-direct (th) |
| 653 | 658 | (let ((theory-info (theory-info th))) |
| 654 | 659 | (or (theory-info-is-ACZ theory-info) |
| 655 | (theory-info-is-ACIZ theory-info)))) | |
| 660 | (theory-info-is-ACIZ theory-info)))) | |
| 656 | 661 | |
| 657 | 662 | (defmacro theory-contains-AZ (*th) |
| 658 | 663 | `(test-theory .AZ. (theory-info-code (theory-info ,*th)))) |
| 660 | 665 | (defun theory-contains-AZ-direct (th) |
| 661 | 666 | (let ((theory-info (theory-info th))) |
| 662 | 667 | (or (theory-info-is-AZ theory-info) |
| 663 | (theory-info-is-AIZ theory-info) | |
| 664 | (theory-info-is-ACZ theory-info) | |
| 665 | (theory-info-is-ACIZ theory-info)))) | |
| 668 | (theory-info-is-AIZ theory-info) | |
| 669 | (theory-info-is-ACZ theory-info) | |
| 670 | (theory-info-is-ACIZ theory-info)))) | |
| 666 | 671 | |
| 667 | 672 | ;;; EOF |
| 0 | 0 | ;;;-*- Mode:LISP; Package:CHAOS; Base:10; Syntax:Common-lisp -*- |
| 1 | 1 | ;;; |
| 2 | ;;; Copyright (c) 2000-2014, Toshimi Sawada. All rights reserved. | |
| 2 | ;;; Copyright (c) 2000-2015, Toshimi Sawada. All rights reserved. | |
| 3 | 3 | ;;; |
| 4 | 4 | ;;; Redistribution and use in source and binary forms, with or without |
| 5 | 5 | ;;; modification, are permitted provided that the following conditions |
| 27 | 27 | ;;; |
| 28 | 28 | (in-package :chaos) |
| 29 | 29 | #|============================================================================== |
| 30 | System: CHAOS | |
| 31 | Module: primitives | |
| 32 | File: parse-modexp.lisp | |
| 30 | System: CHAOS | |
| 31 | Module: primitives | |
| 32 | File: parse-modexp.lisp | |
| 33 | 33 | ==============================================================================|# |
| 34 | 34 | #-:chaos-debug |
| 35 | 35 | (declaim (optimize (speed 3) (safety 0) #-GCL (debug 0))) |
| 78 | 78 | ;;; op bop_->_ : Term Term -> OpMap |
| 79 | 79 | ;;; |
| 80 | 80 | |
| 81 | ;;; *** Changes in module expression syntax *** | |
| 81 | ;;; *** Changes in module expression syntax *** | |
| 82 | 82 | ;;; Mon May 19 15:45:41 JST 1997 |
| 83 | 83 | ;;; due to the discussion held at JAIST in the late March of '97, |
| 84 | 84 | ;;; the syntax is changed. |
| 91 | 91 | ;;; |
| 92 | 92 | ;;;***************************************************************************** |
| 93 | 93 | |
| 94 | ;;; **** READER **** | |
| 94 | ;;; **** READER **** | |
| 95 | 95 | ;;; now defined in comlib/reader.lisp |
| 96 | 96 | |
| 97 | ;;; **** PARSER **** | |
| 97 | ;;; **** PARSER **** | |
| 98 | 98 | ;;;============================================================================= |
| 99 | 99 | |
| 100 | 100 | ;;;----------------------------------------------------------------------------- |
| 116 | 116 | (setf inp (list inp))) |
| 117 | 117 | (let ((*modexp-parse-input* inp)) |
| 118 | 118 | (prog1 |
| 119 | (do-parse-modexp) | |
| 119 | (do-parse-modexp) | |
| 120 | 120 | (when *modexp-parse-input* |
| 121 | (with-output-chaos-error ('invalid-modexp) | |
| 122 | (format t "invalid module expression: ~a" inp) | |
| 123 | (print-next) | |
| 124 | (format t "remaining ~a" *modexp-parse-input*))))) | |
| 121 | (with-output-chaos-error ('invalid-modexp) | |
| 122 | (format t "invalid module expression: ~a" inp) | |
| 123 | (print-next) | |
| 124 | (format t "remaining ~a" *modexp-parse-input*))))) | |
| 125 | 125 | ) |
| 126 | 126 | |
| 127 | 127 | ;;; DO-PARSE-MODEXP : {*modexp-parse-input*} -> |
| 132 | 132 | ;; |
| 133 | 133 | (let ((e1 (parse-rename-or-inst))) |
| 134 | 134 | (if (null *modexp-parse-input*) |
| 135 | ;; the whole expression is parsed by `parse-rename-or-inst'. | |
| 136 | e1 | |
| 137 | (case-equal (car *modexp-parse-input*) | |
| 138 | ;; parse remainders | |
| 139 | ("+" (let ((args (list e1))) | |
| 140 | (loop (modexp-skip) ; skip "+" | |
| 141 | ; collect "+" arguments. | |
| 142 | (push (parse-rename-or-inst) args) | |
| 143 | (when (or (null *modexp-parse-input*) | |
| 144 | (not (equal "+" (car *modexp-parse-input*)))) | |
| 145 | ;; whole modexpr is parsed, or other types comes. | |
| 146 | (return))) | |
| 147 | (%plus* (reverse args)))) | |
| 148 | ;; the following tokens can terminate one module expr. | |
| 149 | (("]" "," ")" "{" "to" "->" "}") e1) | |
| 150 | (t (with-output-chaos-error ('invlaid-modexp) | |
| 151 | (princ "error in module expression: ") | |
| 152 | (print-chaos-object e1) | |
| 153 | (format t " is followed by ~a.~%" (car *modexp-parse-input*)) | |
| 154 | )))))) | |
| 135 | ;; the whole expression is parsed by `parse-rename-or-inst'. | |
| 136 | e1 | |
| 137 | (case-equal (car *modexp-parse-input*) | |
| 138 | ;; parse remainders | |
| 139 | ("+" (let ((args (list e1))) | |
| 140 | (loop (modexp-skip) ; skip "+" | |
| 141 | ; collect "+" arguments. | |
| 142 | (push (parse-rename-or-inst) args) | |
| 143 | (when (or (null *modexp-parse-input*) | |
| 144 | (not (equal "+" (car *modexp-parse-input*)))) | |
| 145 | ;; whole modexpr is parsed, or other types comes. | |
| 146 | (return))) | |
| 147 | (%plus* (reverse args)))) | |
| 148 | ;; the following tokens can terminate one module expr. | |
| 149 | (("]" "," ")" "{" "to" "->" "}") e1) | |
| 150 | (t (with-output-chaos-error ('invlaid-modexp) | |
| 151 | (princ "error in module expression: ") | |
| 152 | (print-chaos-object e1) | |
| 153 | (format t " is followed by ~a.~%" (car *modexp-parse-input*)) | |
| 154 | )))))) | |
| 155 | 155 | |
| 156 | 156 | ;;; PARSING ROUTINES FOR EACH SYNTACTIC CLASS.__________________________________ |
| 157 | 157 | |
| 162 | 162 | ;; first we try to parse instantiation. |
| 163 | 163 | (let ((e1 (parse-instantiation))) |
| 164 | 164 | (if (null *modexp-parse-input*) |
| 165 | ;; the whole expression is parsed by `parse-instantiation'. | |
| 166 | e1 | |
| 167 | ;; e1 may be an instantiation or of other types of module expressions. | |
| 168 | (case-equal (car *modexp-parse-input*) | |
| 169 | ("*" ; Rename. | |
| 170 | ;; gather renaming operations in left associative manner. | |
| 171 | (loop (modexp-skip) ; skip "*" | |
| 172 | (setq e1 (%rename* e1 (parse-map-body))) | |
| 173 | (when (or (null *modexp-parse-input*) | |
| 174 | (not (equal "*" (car *modexp-parse-input*)))) | |
| 175 | ;; all are parsed or other type of ModExpr comes. | |
| 176 | (return e1)))) | |
| 177 | ||
| 178 | ;; the following tokens terminate rename or other preceding module expressions, | |
| 179 | ;; thus we return it as is. | |
| 180 | (("]" "," ")" "{" "to" "->" "::" "+" "}") e1) ; "with" "and" ...?? | |
| 181 | ||
| 182 | ;; otherwise we encounter an error. | |
| 183 | (t (with-output-chaos-error ('invalid-modexp) | |
| 184 | (princ "module expression: ") | |
| 185 | (print-chaos-object e1) | |
| 186 | (format t " is followed by ~a.~%" (car *modexp-parse-input*)) | |
| 187 | )))))) | |
| 165 | ;; the whole expression is parsed by `parse-instantiation'. | |
| 166 | e1 | |
| 167 | ;; e1 may be an instantiation or of other types of module expressions. | |
| 168 | (case-equal (car *modexp-parse-input*) | |
| 169 | ("*" ; Rename. | |
| 170 | ;; gather renaming operations in left associative manner. | |
| 171 | (loop (modexp-skip) ; skip "*" | |
| 172 | (setq e1 (%rename* e1 (parse-map-body))) | |
| 173 | (when (or (null *modexp-parse-input*) | |
| 174 | (not (equal "*" (car *modexp-parse-input*)))) | |
| 175 | ;; all are parsed or other type of ModExpr comes. | |
| 176 | (return e1)))) | |
| 177 | ||
| 178 | ;; the following tokens terminate rename or other preceding module expressions, | |
| 179 | ;; thus we return it as is. | |
| 180 | (("]" "," ")" "{" "to" "->" "::" "+" "}") e1) ; "with" "and" ...?? | |
| 181 | ||
| 182 | ;; otherwise we encounter an error. | |
| 183 | (t (with-output-chaos-error ('invalid-modexp) | |
| 184 | (princ "module expression: ") | |
| 185 | (print-chaos-object e1) | |
| 186 | (format t " is followed by ~a.~%" (car *modexp-parse-input*)) | |
| 187 | )))))) | |
| 188 | 188 | |
| 189 | 189 | ;;; PARSE-MAP-BODY |
| 190 | 190 | ;;; gather mapping. |
| 193 | 193 | (defun parse-map-body (&optional (type :rename)) |
| 194 | 194 | (declare (type symbol type)) |
| 195 | 195 | (cond ((null *modexp-parse-input*) |
| 196 | (with-output-chaos-error ('invalid-modexp) | |
| 197 | (princ "premature end of module expression in a mapping."))) | |
| 198 | ;; the first token of rename must be "{". | |
| 199 | ((not (equal "{" (car *modexp-parse-input*))) | |
| 200 | (with-output-chaos-error ('invalid-modexp) | |
| 201 | (princ "body of renaming should be preceded by \"{\""))) | |
| 202 | (t (modexp-skip) ; skip "{" | |
| 203 | (let ((sort-map nil) ; accumulators | |
| 204 | (hsort-map nil) | |
| 205 | (op-map nil) | |
| 206 | (bop-map nil) | |
| 207 | (vars nil) | |
| 208 | (param-map nil) | |
| 209 | (map nil)) | |
| 210 | ;; gather rename map elements | |
| 211 | (loop (when (null *modexp-parse-input*) | |
| 212 | (with-output-chaos-error ('invalid-modexp) | |
| 213 | (princ "ill-formed mapping."))) | |
| 214 | (setq map (if (eq type :rename) | |
| 215 | (parse-map-elt) | |
| 216 | (parse-view-elt))) | |
| 217 | (case (car map) | |
| 218 | (:sort (push (cdr map) sort-map)) | |
| 219 | (:hsort (push (cdr map) hsort-map)) | |
| 220 | (:op (push (cdr map) op-map)) | |
| 221 | (:bop (push (cdr map) bop-map)) | |
| 222 | (:var (push (cdr map) vars)) ; only for case view map | |
| 223 | (:param (push (cdr map) param-map)) ; only for case rename map | |
| 224 | ; *note* not implemented yet though. | |
| 225 | (t nil)) ; empty case | |
| 226 | ;; "}" terminates rename map. | |
| 227 | (when (equal "}" (car *modexp-parse-input*)) | |
| 228 | (modexp-skip) ; consume "}" | |
| 229 | (return)) ; then return | |
| 230 | ;; we just ignore ",", a unnecessary separator of renaming. | |
| 231 | (when (equal "," (car *modexp-parse-input*)) | |
| 232 | (modexp-skip))) | |
| 233 | (%rmap* (nconc (when sort-map (list (%ren-sort* sort-map))) | |
| 234 | (when hsort-map (list (%ren-hsort* hsort-map))) | |
| 235 | (when op-map (list (%ren-op* op-map))) | |
| 236 | (when bop-map (list (%ren-bop* bop-map))) | |
| 237 | (when vars (list (%vars* vars))) | |
| 238 | (when param-map (list (%ren-param* param-map))))))))) | |
| 196 | (with-output-chaos-error ('invalid-modexp) | |
| 197 | (princ "premature end of module expression in a mapping."))) | |
| 198 | ;; the first token of rename must be "{". | |
| 199 | ((not (equal "{" (car *modexp-parse-input*))) | |
| 200 | (with-output-chaos-error ('invalid-modexp) | |
| 201 | (princ "body of renaming should be preceded by \"{\""))) | |
| 202 | (t (modexp-skip) ; skip "{" | |
| 203 | (let ((sort-map nil) ; accumulators | |
| 204 | (hsort-map nil) | |
| 205 | (op-map nil) | |
| 206 | (bop-map nil) | |
| 207 | (vars nil) | |
| 208 | (param-map nil) | |
| 209 | (map nil)) | |
| 210 | ;; gather rename map elements | |
| 211 | (loop (when (null *modexp-parse-input*) | |
| 212 | (with-output-chaos-error ('invalid-modexp) | |
| 213 | (princ "ill-formed mapping."))) | |
| 214 | (setq map (if (eq type :rename) | |
| 215 | (parse-map-elt) | |
| 216 | (parse-view-elt))) | |
| 217 | (case (car map) | |
| 218 | (:sort (push (cdr map) sort-map)) | |
| 219 | (:hsort (push (cdr map) hsort-map)) | |
| 220 | (:op (push (cdr map) op-map)) | |
| 221 | (:bop (push (cdr map) bop-map)) | |
| 222 | (:var (push (cdr map) vars)) ; only for case view map | |
| 223 | (:param (push (cdr map) param-map)) ; only for case rename map | |
| 224 | ; *note* not implemented yet though. | |
| 225 | (t nil)) ; empty case | |
| 226 | ;; "}" terminates rename map. | |
| 227 | (when (equal "}" (car *modexp-parse-input*)) | |
| 228 | (modexp-skip) ; consume "}" | |
| 229 | (return)) ; then return | |
| 230 | ;; we just ignore ",", a unnecessary separator of renaming. | |
| 231 | (when (equal "," (car *modexp-parse-input*)) | |
| 232 | (modexp-skip))) | |
| 233 | (%rmap* (nconc (when sort-map (list (%ren-sort* sort-map))) | |
| 234 | (when hsort-map (list (%ren-hsort* hsort-map))) | |
| 235 | (when op-map (list (%ren-op* op-map))) | |
| 236 | (when bop-map (list (%ren-bop* bop-map))) | |
| 237 | (when vars (list (%vars* vars))) | |
| 238 | (when param-map (list (%ren-param* param-map))))))))) | |
| 239 | 239 | |
| 240 | 240 | ;;; PARSE-MAP-ELT |
| 241 | 241 | ;;; parse one map element. |
| 244 | 244 | ;;; |
| 245 | 245 | (defun parse-map-elt () |
| 246 | 246 | (cond ((null *modexp-parse-input*) |
| 247 | (with-output-chaos-error ('invalid-modexp) | |
| 248 | (princ "premature end of map elements.") | |
| 249 | )) | |
| 250 | (t (case-equal (car *modexp-parse-input*) | |
| 251 | ("sort" ; sort map | |
| 252 | (let (from to) | |
| 253 | (modexp-skip) ; skip "sort" | |
| 254 | ;; "->" separates from\to | |
| 255 | (setq from (parse-sort-reference '("->"))) | |
| 256 | (when (not (equal "->" (car *modexp-parse-input*))) | |
| 257 | (with-output-chaos-error ('invalid-modexp) | |
| 258 | (format t "parsing sort mapping of ~a, missing \"->\"" | |
| 259 | from) | |
| 260 | )) | |
| 261 | (modexp-skip) ; skip "->" | |
| 262 | ;; parse `to' part. | |
| 263 | (setq to (parse-sort-reference '("," "}" "]"))) | |
| 264 | (list :sort from to))) | |
| 265 | ("hsort" ; hidden sort map | |
| 266 | (let (from to) | |
| 267 | (modexp-skip) ; skip "hsort" | |
| 268 | ;; "->" separates from & to | |
| 269 | (setq from (parse-sort-reference '("->"))) | |
| 270 | (when (not (equal "->" (car *modexp-parse-input*))) | |
| 271 | (with-output-chaos-error ('invalid-modexp) | |
| 272 | (format t "parsing hidden sort mapping of ~a, missing \"->\"" | |
| 273 | from) | |
| 274 | )) | |
| 275 | (modexp-skip) ; skip "->" | |
| 276 | ;; parse `to' part. | |
| 277 | (setq to (parse-sort-reference '("," "}" "]"))) | |
| 278 | (list :hsort from to))) | |
| 279 | ("op" ; operator renaming | |
| 280 | (let (from to) | |
| 281 | (modexp-skip) ; skip "op" | |
| 282 | (setq from (parse-operator-reference '("->"))) | |
| 283 | (when (not (equal "->" (car *modexp-parse-input*))) | |
| 284 | (with-output-chaos-error ('invalid-modexp) | |
| 285 | (format t "parsing operator mapping of ~a, missing \"->\"" | |
| 286 | from) | |
| 287 | )) | |
| 288 | (modexp-skip) ; skip "->" | |
| 289 | (setq to (parse-operator-reference '("," "}" "]"))) | |
| 290 | (list :op from to))) | |
| 291 | ("bop" ; behavioural operator renaming | |
| 292 | (let (from to) | |
| 293 | (modexp-skip) ; skip "bop" | |
| 294 | (setq from (parse-operator-reference '("->"))) | |
| 295 | (when (not (equal "->" (car *modexp-parse-input*))) | |
| 296 | (with-output-chaos-error ('invalid-modexp) | |
| 297 | (format t "parsing behavioural operator mapping of ~a, missing \"->\"" | |
| 298 | from) | |
| 299 | )) | |
| 300 | (modexp-skip) ; skip "->" | |
| 301 | (setq to (parse-operator-reference '("," "}" "]"))) | |
| 302 | (list :bop from to))) | |
| 303 | ("param" ; parameter mapping. | |
| 304 | ; can parse but NOT really implemented. **** | |
| 305 | (let (from to) | |
| 306 | (modexp-skip) ; skip "param" | |
| 307 | (setq from (modexp-parse-param-specn '("->"))) | |
| 308 | (when (not (equal "->" (car *modexp-parse-input*))) | |
| 309 | (with-output-chaos-error ('invalid-modexp) | |
| 310 | (format t "parsing parameter mapping of ~a, missing \"->\"" | |
| 311 | from) | |
| 312 | )) | |
| 313 | (modexp-skip) ; skip "->" | |
| 314 | (setq to (modexp-parse-param-specn '("," "}" "]"))) | |
| 315 | (list :param from to))) | |
| 316 | ("}" ; emtpy map | |
| 317 | nil) | |
| 318 | (t (with-output-chaos-error ('invalid-modexp) | |
| 319 | (format t "expecting \"sort\",\"hsort\",\"op\" or \"bop\", encounterd ~a." | |
| 320 | (car *modexp-parse-input*)) | |
| 321 | ))) | |
| 322 | ))) | |
| 247 | (with-output-chaos-error ('invalid-modexp) | |
| 248 | (princ "premature end of map elements.") | |
| 249 | )) | |
| 250 | (t (case-equal (car *modexp-parse-input*) | |
| 251 | ("sort" ; sort map | |
| 252 | (let (from to) | |
| 253 | (modexp-skip) ; skip "sort" | |
| 254 | ;; "->" separates from\to | |
| 255 | (setq from (parse-sort-reference '("->"))) | |
| 256 | (when (not (equal "->" (car *modexp-parse-input*))) | |
| 257 | (with-output-chaos-error ('invalid-modexp) | |
| 258 | (format t "parsing sort mapping of ~a, missing \"->\"" | |
| 259 | from) | |
| 260 | )) | |
| 261 | (modexp-skip) ; skip "->" | |
| 262 | ;; parse `to' part. | |
| 263 | (setq to (parse-sort-reference '("," "}" "]"))) | |
| 264 | (list :sort from to))) | |
| 265 | ("hsort" ; hidden sort map | |
| 266 | (let (from to) | |
| 267 | (modexp-skip) ; skip "hsort" | |
| 268 | ;; "->" separates from & to | |
| 269 | (setq from (parse-sort-reference '("->"))) | |
| 270 | (when (not (equal "->" (car *modexp-parse-input*))) | |
| 271 | (with-output-chaos-error ('invalid-modexp) | |
| 272 | (format t "parsing hidden sort mapping of ~a, missing \"->\"" | |
| 273 | from) | |
| 274 | )) | |
| 275 | (modexp-skip) ; skip "->" | |
| 276 | ;; parse `to' part. | |
| 277 | (setq to (parse-sort-reference '("," "}" "]"))) | |
| 278 | (list :hsort from to))) | |
| 279 | ("op" ; operator renaming | |
| 280 | (let (from to) | |
| 281 | (modexp-skip) ; skip "op" | |
| 282 | (setq from (parse-operator-reference '("->"))) | |
| 283 | (when (not (equal "->" (car *modexp-parse-input*))) | |
| 284 | (with-output-chaos-error ('invalid-modexp) | |
| 285 | (format t "parsing operator mapping of ~a, missing \"->\"" | |
| 286 | from) | |
| 287 | )) | |
| 288 | (modexp-skip) ; skip "->" | |
| 289 | (setq to (parse-operator-reference '("," "}" "]"))) | |
| 290 | (list :op from to))) | |
| 291 | ("bop" ; behavioural operator renaming | |
| 292 | (let (from to) | |
| 293 | (modexp-skip) ; skip "bop" | |
| 294 | (setq from (parse-operator-reference '("->"))) | |
| 295 | (when (not (equal "->" (car *modexp-parse-input*))) | |
| 296 | (with-output-chaos-error ('invalid-modexp) | |
| 297 | (format t "parsing behavioural operator mapping of ~a, missing \"->\"" | |
| 298 | from) | |
| 299 | )) | |
| 300 | (modexp-skip) ; skip "->" | |
| 301 | (setq to (parse-operator-reference '("," "}" "]"))) | |
| 302 | (list :bop from to))) | |
| 303 | ("param" ; parameter mapping. | |
| 304 | ; can parse but NOT really implemented. **** | |
| 305 | (let (from to) | |
| 306 | (modexp-skip) ; skip "param" | |
| 307 | (setq from (modexp-parse-param-specn '("->"))) | |
| 308 | (when (not (equal "->" (car *modexp-parse-input*))) | |
| 309 | (with-output-chaos-error ('invalid-modexp) | |
| 310 | (format t "parsing parameter mapping of ~a, missing \"->\"" | |
| 311 | from) | |
| 312 | )) | |
| 313 | (modexp-skip) ; skip "->" | |
| 314 | (setq to (modexp-parse-param-specn '("," "}" "]"))) | |
| 315 | (list :param from to))) | |
| 316 | ("}" ; emtpy map | |
| 317 | nil) | |
| 318 | (t (with-output-chaos-error ('invalid-modexp) | |
| 319 | (format t "expecting \"sort\",\"hsort\",\"op\" or \"bop\", encounterd ~a." | |
| 320 | (car *modexp-parse-input*)) | |
| 321 | ))) | |
| 322 | ))) | |
| 323 | 323 | |
| 324 | 324 | ;;; PARSE-INSTATIATION |
| 325 | 325 | ;;; parse a modexpr, then try to parse the first of the rest as instantiation, |
| 327 | 327 | ;;;----------------------------------------------------------------------------- |
| 328 | 328 | (defun parse-instantiation () |
| 329 | 329 | (labels ((token-is-not-instantiation (token) |
| 330 | (declare (type simple-string token)) | |
| 331 | (dotimes (i (length token) t) | |
| 332 | (declare (type fixnum i)) | |
| 333 | (let ((ch (schar token i))) | |
| 334 | (declare (type character ch)) | |
| 335 | (when (member ch '(#\[ #\] #\( #\))) | |
| 336 | (return nil))))) | |
| 337 | (parse-basic () | |
| 338 | ;; * assumes Modexpr which can be an argument of any type | |
| 339 | ;; of module expressions other than instantiation, or can be a | |
| 340 | ;; simple name. | |
| 341 | (cond ((equal "(" (car *modexp-parse-input*)) | |
| 342 | (modexp-skip) | |
| 343 | (let ((m (do-parse-modexp))) | |
| 344 | (cond ((equal ")" (car *modexp-parse-input*)) | |
| 345 | (modexp-skip) | |
| 346 | m) | |
| 347 | (t (with-output-msg () | |
| 348 | (princ "unmatched \"(\" in module expression after ") | |
| 349 | (print-next) | |
| 350 | (print-modexp m) | |
| 351 | (chaos-error 'invalid-modexp) ))))) | |
| 352 | ((token-is-not-instantiation (car *modexp-parse-input*)) | |
| 353 | (prog1 (car *modexp-parse-input*) (modexp-skip))) | |
| 354 | (t (with-output-chaos-error ('invalid-modexp) | |
| 355 | (princ (car *modexp-parse-input*)) | |
| 356 | (print "doesn't make sense in module expression.") | |
| 357 | ))))) | |
| 330 | (declare (type simple-string token)) | |
| 331 | (dotimes (i (length token) t) | |
| 332 | (declare (type fixnum i)) | |
| 333 | (let ((ch (schar token i))) | |
| 334 | (declare (type character ch)) | |
| 335 | (when (member ch '(#\[ #\] #\( #\))) | |
| 336 | (return nil))))) | |
| 337 | (parse-basic () | |
| 338 | ;; * assumes Modexpr which can be an argument of any type | |
| 339 | ;; of module expressions other than instantiation, or can be a | |
| 340 | ;; simple name. | |
| 341 | (cond ((equal "(" (car *modexp-parse-input*)) | |
| 342 | (modexp-skip) | |
| 343 | (let ((m (do-parse-modexp))) | |
| 344 | (cond ((equal ")" (car *modexp-parse-input*)) | |
| 345 | (modexp-skip) | |
| 346 | m) | |
| 347 | (t (with-output-msg () | |
| 348 | (princ "unmatched \"(\" in module expression after ") | |
| 349 | (print-next) | |
| 350 | (print-modexp m) | |
| 351 | (chaos-error 'invalid-modexp) ))))) | |
| 352 | ((token-is-not-instantiation (car *modexp-parse-input*)) | |
| 353 | (prog1 (car *modexp-parse-input*) (modexp-skip))) | |
| 354 | (t (with-output-chaos-error ('invalid-modexp) | |
| 355 | (format t "~s doesn't make sense in module expression." | |
| 356 | (car *modexp-parse-input*))))))) | |
| 358 | 357 | (let ((m (parse-basic))) |
| 359 | 358 | (cond ((null *modexp-parse-input*) m) ; was just a simple name or parenced |
| 360 | ; modexpr. | |
| 361 | ((member (car *modexp-parse-input*) | |
| 362 | '("[" "(") :test #'equal) | |
| 363 | ;; instantiation!, its first argument is now bound to `m'. | |
| 364 | (modexp-skip) ; skip "[" ("(") | |
| 365 | (let ((args (modexp-parse-args))) | |
| 366 | ; parse second arg, i.e., the view. | |
| 367 | ;; view must be ended with "]". | |
| 368 | (when (not (member (car *modexp-parse-input*) | |
| 369 | '("]" ")") :test #'equal)) | |
| 370 | (with-output-chaos-error ('invalid-modexp) | |
| 371 | (princ "\"[\" appears without matching \"]\" in instantiation.") | |
| 372 | )) | |
| 373 | (modexp-skip) ; skip "]" (")"). | |
| 374 | (%instantiation* m args))) | |
| 375 | ;; the *modexp-parse-input* was a module expression any other than | |
| 376 | ;; instantiation. which is either a simple name or a parenced modexpr, | |
| 377 | ;; and it can be an argument of the following operator or it just a | |
| 378 | ;; simple name. | |
| 379 | (t | |
| 380 | m))))) | |
| 359 | ; modexpr. | |
| 360 | ((member (car *modexp-parse-input*) | |
| 361 | '("[" "(") :test #'equal) | |
| 362 | ;; instantiation!, its first argument is now bound to `m'. | |
| 363 | (modexp-skip) ; skip "[" ("(") | |
| 364 | (let ((args (modexp-parse-args))) | |
| 365 | ; parse second arg, i.e., the view. | |
| 366 | ;; view must be ended with "]". | |
| 367 | (when (not (member (car *modexp-parse-input*) | |
| 368 | '("]" ")") :test #'equal)) | |
| 369 | (with-output-chaos-error ('invalid-modexp) | |
| 370 | (princ "\"[\" appears without matching \"]\" in instantiation.") | |
| 371 | )) | |
| 372 | (modexp-skip) ; skip "]" (")"). | |
| 373 | (%instantiation* m args))) | |
| 374 | ;; the *modexp-parse-input* was a module expression any other than | |
| 375 | ;; instantiation. which is either a simple name or a parenced modexpr, | |
| 376 | ;; and it can be an argument of the following operator or it just a | |
| 377 | ;; simple name. | |
| 378 | (t | |
| 379 | m))))) | |
| 381 | 380 | |
| 382 | 381 | ;;; MODEXP-PARSE-ARGS |
| 383 | 382 | ;;; called by `parse-instantiation'; parses arguments to parameterized module. |
| 392 | 391 | |
| 393 | 392 | (defun modexp-parse-args () |
| 394 | 393 | (let ((*positional-arg-pos* 0) |
| 395 | (*arg-type* nil)) | |
| 394 | (*arg-type* nil)) | |
| 396 | 395 | (cond ((null *modexp-parse-input*) |
| 397 | (with-output-chaos-error ('invalid-modexp) | |
| 398 | (princ "parsing instantiation, premature end of input in argument list.") | |
| 399 | )) | |
| 400 | ((member (car *modexp-parse-input*) '("]" ")") :test #'equal) | |
| 401 | nil) ; empty arugment. | |
| 402 | ;; accumulate arguments. | |
| 403 | (t (let ((res nil) | |
| 404 | (arg nil)) | |
| 405 | (loop (setf arg (modexp-parse-arg)) | |
| 406 | (when arg | |
| 407 | (setq res (cons arg res)) | |
| 408 | (incf *positional-arg-pos*)) | |
| 409 | ;; "]" teminates arguments. | |
| 410 | (when (member (car *modexp-parse-input*) '("]" ")") :test #'equal) | |
| 411 | (return (nreverse res))) | |
| 412 | ;; skip "," as a separator of each argument. | |
| 413 | (when (equal "," (car *modexp-parse-input*)) | |
| 414 | (modexp-skip)))) | |
| 415 | )))) | |
| 396 | (with-output-chaos-error ('invalid-modexp) | |
| 397 | (princ "parsing instantiation, premature end of input in argument list.") | |
| 398 | )) | |
| 399 | ((member (car *modexp-parse-input*) '("]" ")") :test #'equal) | |
| 400 | nil) ; empty arugment. | |
| 401 | ;; accumulate arguments. | |
| 402 | (t (let ((res nil) | |
| 403 | (arg nil)) | |
| 404 | (loop (setf arg (modexp-parse-arg)) | |
| 405 | (when arg | |
| 406 | (setq res (cons arg res)) | |
| 407 | (incf *positional-arg-pos*)) | |
| 408 | ;; "]" teminates arguments. | |
| 409 | (when (member (car *modexp-parse-input*) '("]" ")") :test #'equal) | |
| 410 | (return (nreverse res))) | |
| 411 | ;; skip "," as a separator of each argument. | |
| 412 | (when (equal "," (car *modexp-parse-input*)) | |
| 413 | (modexp-skip)))) | |
| 414 | )))) | |
| 416 | 415 | |
| 417 | 416 | (defun parse-instantiate-arg-name (name) |
| 418 | 417 | (declare (type simple-string name)) |
| 419 | 418 | (let ((pos (position #\@ name))) |
| 420 | (if pos ; indirect argument ref. | |
| 421 | (cons (subseq name 0 pos) | |
| 422 | (subseq name (1+ pos))) | |
| 423 | (cons name nil)))) | |
| 419 | (if pos ; indirect argument ref. | |
| 420 | (cons (subseq name 0 pos) | |
| 421 | (subseq name (1+ pos))) | |
| 422 | (cons name nil)))) | |
| 424 | 423 | |
| 425 | 424 | (defun modexp-parse-arg () |
| 426 | 425 | (when (null *modexp-parse-input*) |
| 429 | 428 | )) |
| 430 | 429 | ;; |
| 431 | 430 | (let ((arg-name (car *modexp-parse-input*))) |
| 432 | (modexp-skip) ; move to next token | |
| 431 | (modexp-skip) ; move to next token | |
| 433 | 432 | ;; try to parse formal argument name. |
| 434 | 433 | ;; - it can be omitted, in this case we are parsing positional arguments, |
| 435 | 434 | ;;; and `arg-name' should bind a real argument, i.e., a view. |
| 436 | 435 | ;; - otherwise normal keyword type argument passing is processed. |
| 437 | 436 | ;; in this case, arg-name should bind formal argument name. |
| 438 | 437 | (if (equal "<=" (car *modexp-parse-input*)) |
| 439 | (progn | |
| 440 | (unless (or (eq *arg-type* ':key) (null *arg-type*)) | |
| 441 | (with-output-chaos-error ('invalid-modexp) | |
| 442 | (princ "you can not use both positional and keyword type argument in a combined manner.") | |
| 443 | )) | |
| 444 | (modexp-skip) ; skip "<=" | |
| 445 | (setq arg-name (parse-instantiate-arg-name arg-name)) | |
| 446 | (setq *arg-type* ':key)) | |
| 447 | (progn | |
| 448 | (unless (or (eq *arg-type* ':pos) (null *arg-type*)) | |
| 449 | (with-output-chaos-error ('invalid-modexp) | |
| 450 | (princ "you cannot use both positional and keyword type argument in a combined manner.") | |
| 451 | )) | |
| 452 | (setq *arg-type* ':pos) | |
| 453 | (push arg-name *modexp-parse-input*) ; restore view | |
| 454 | (setq arg-name *positional-arg-pos*) ; should we set keyword name | |
| 455 | ; here? | |
| 456 | ||
| 457 | )) | |
| 438 | (progn | |
| 439 | (unless (or (eq *arg-type* ':key) (null *arg-type*)) | |
| 440 | (with-output-chaos-error ('invalid-modexp) | |
| 441 | (princ "you can not use both positional and keyword type argument in a combined manner.") | |
| 442 | )) | |
| 443 | (modexp-skip) ; skip "<=" | |
| 444 | (setq arg-name (parse-instantiate-arg-name arg-name)) | |
| 445 | (setq *arg-type* ':key)) | |
| 446 | (progn | |
| 447 | (unless (or (eq *arg-type* ':pos) (null *arg-type*)) | |
| 448 | (with-output-chaos-error ('invalid-modexp) | |
| 449 | (princ "you cannot use both positional and keyword type argument in a combined manner.") | |
| 450 | )) | |
| 451 | (setq *arg-type* ':pos) | |
| 452 | (push arg-name *modexp-parse-input*) ; restore view | |
| 453 | (setq arg-name *positional-arg-pos*) ; should we set keyword name | |
| 454 | ; here? | |
| 455 | ||
| 456 | )) | |
| 458 | 457 | ;; parse actual argument, i.e., view. |
| 459 | 458 | (cond ((equal "view" (car *modexp-parse-input*)) ; explicit view argument. |
| 460 | (%!arg* arg-name (do-parse-view))) | |
| 461 | ((equal "{" (car *modexp-parse-input*)) ; given map directly. | |
| 462 | ;; both `from' & `to' is omitted... | |
| 463 | (let (view) ; the resulting view | |
| 464 | (setq view (%view* 'none 'none (parse-view-body))) | |
| 465 | ; was parse-map-body | |
| 466 | (%!arg* arg-name view))) | |
| 467 | ;; normal? argument | |
| 468 | (t (let ((mod (do-parse-modexp)) ; either a name of declared view or | |
| 469 | ; a modexpr. | |
| 470 | (view nil)) | |
| 471 | ;; | |
| 472 | (cond ((equal "{" (car *modexp-parse-input*)) ; the map is given | |
| 473 | ;; this case mod must be a modexpr other than view name. | |
| 474 | (setq view (%view* 'none mod (parse-view-body))) | |
| 475 | ; was parse-map-body | |
| 476 | (%!arg* arg-name view)) | |
| 477 | ;; NO map is given................. | |
| 478 | (t (setq view (%view* 'none | |
| 479 | (make-?-name mod) | |
| 480 | nil)) | |
| 481 | (%!arg* arg-name view)))))) | |
| 459 | (%!arg* arg-name (do-parse-view))) | |
| 460 | ((equal "{" (car *modexp-parse-input*)) ; given map directly. | |
| 461 | ;; both `from' & `to' is omitted... | |
| 462 | (let (view) ; the resulting view | |
| 463 | (setq view (%view* 'none 'none (parse-view-body))) | |
| 464 | ; was parse-map-body | |
| 465 | (%!arg* arg-name view))) | |
| 466 | ;; normal? argument | |
| 467 | (t (let ((mod (do-parse-modexp)) ; either a name of declared view or | |
| 468 | ; a modexpr. | |
| 469 | (view nil)) | |
| 470 | ;; | |
| 471 | (cond ((equal "{" (car *modexp-parse-input*)) ; the map is given | |
| 472 | ;; this case mod must be a modexpr other than view name. | |
| 473 | (setq view (%view* 'none mod (parse-view-body))) | |
| 474 | ; was parse-map-body | |
| 475 | (%!arg* arg-name view)) | |
| 476 | ;; NO map is given................. | |
| 477 | (t (setq view (%view* 'none | |
| 478 | (make-?-name mod) | |
| 479 | nil)) | |
| 480 | (%!arg* arg-name view)))))) | |
| 482 | 481 | )) |
| 483 | 482 | |
| 484 | 483 | ;;;----------------------------------------------------------------------------- |
| 498 | 497 | ;;; |
| 499 | 498 | (defun do-parse-view () |
| 500 | 499 | (cond ((equal "view" (car *modexp-parse-input*)) |
| 501 | (modexp-skip) ; skip "view" | |
| 502 | (let ((from 'none) ; theory | |
| 503 | (to nil) ; target module | |
| 504 | (mapping nil)) ; mapping | |
| 505 | ||
| 506 | ;; parse theory module part if specified | |
| 507 | (when (equal "from" (car *modexp-parse-input*)) | |
| 508 | (modexp-skip) ; skip "from" | |
| 509 | ;; theory module can be an arbitrary module expression. | |
| 510 | (setq from (do-parse-modexp))) | |
| 511 | ;; we always require target module | |
| 512 | (when (not (equal "to" (car *modexp-parse-input*))) | |
| 513 | (with-output-chaos-error ('invalid-modexp) | |
| 514 | (format t "expecting \"to\" in view, but encountered ~A" | |
| 515 | (car *modexp-parse-input*)) | |
| 516 | )) | |
| 517 | (modexp-skip) ; skip "to" | |
| 518 | ;; parse target module expression | |
| 519 | (setq to (do-parse-modexp)) | |
| 520 | ;; parse mapping | |
| 521 | (setq mapping (parse-view-body)) ; was parse-map-body... | |
| 522 | ;; | |
| 523 | (%view* from to mapping))) | |
| 524 | (t (with-output-chaos-error ('invalid-modexp) | |
| 525 | (princ "in view, not expecting ") | |
| 526 | (princ (car *modexp-parse-input*)) | |
| 527 | )))) | |
| 500 | (modexp-skip) ; skip "view" | |
| 501 | (let ((from 'none) ; theory | |
| 502 | (to nil) ; target module | |
| 503 | (mapping nil)) ; mapping | |
| 504 | ||
| 505 | ;; parse theory module part if specified | |
| 506 | (when (equal "from" (car *modexp-parse-input*)) | |
| 507 | (modexp-skip) ; skip "from" | |
| 508 | ;; theory module can be an arbitrary module expression. | |
| 509 | (setq from (do-parse-modexp))) | |
| 510 | ;; we always require target module | |
| 511 | (when (not (equal "to" (car *modexp-parse-input*))) | |
| 512 | (with-output-chaos-error ('invalid-modexp) | |
| 513 | (format t "expecting \"to\" in view, but encountered ~A" | |
| 514 | (car *modexp-parse-input*)) | |
| 515 | )) | |
| 516 | (modexp-skip) ; skip "to" | |
| 517 | ;; parse target module expression | |
| 518 | (setq to (do-parse-modexp)) | |
| 519 | ;; parse mapping | |
| 520 | (setq mapping (parse-view-body)) ; was parse-map-body... | |
| 521 | ;; | |
| 522 | (%view* from to mapping))) | |
| 523 | (t (with-output-chaos-error ('invalid-modexp) | |
| 524 | (princ "in view, not expecting ") | |
| 525 | (princ (car *modexp-parse-input*)) | |
| 526 | )))) | |
| 528 | 527 | |
| 529 | 528 | ;;; PARSE-VIEW-BODY |
| 530 | 529 | ;;; similar to `parse-map-body' but allows variable declaration and |
| 536 | 535 | ;;; |
| 537 | 536 | (defun parse-view-elt () |
| 538 | 537 | (flet ((parse-op-name (cntxt) |
| 539 | (declare (type list cntxt)) | |
| 540 | (let ((res nil)) | |
| 541 | (loop (when (null *modexp-parse-input*) | |
| 542 | (with-output-chaos-error ('invalid-modexp) | |
| 543 | (princ "premature end of input in operator pattern:") | |
| 544 | (print-next) | |
| 545 | (format t "beginning of pattern: ~{~s~}" (nreverse res)) | |
| 546 | )) | |
| 547 | (when (member (car *modexp-parse-input*) cntxt :test #'equal) | |
| 548 | (return)) | |
| 549 | (setq res (nconc res (parse-balanced-context cntxt)))) | |
| 550 | res ))) | |
| 538 | (declare (type list cntxt)) | |
| 539 | (let ((res nil)) | |
| 540 | (loop (when (null *modexp-parse-input*) | |
| 541 | (with-output-chaos-error ('invalid-modexp) | |
| 542 | (princ "premature end of input in operator pattern:") | |
| 543 | (print-next) | |
| 544 | (format t "beginning of pattern: ~{~s~}" (nreverse res)))) | |
| 545 | (when (member (car *modexp-parse-input*) cntxt :test #'equal) | |
| 546 | (return)) | |
| 547 | (setq res (nconc res (parse-balanced-context cntxt)))) | |
| 548 | res ))) | |
| 551 | 549 | (cond ((null *modexp-parse-input*) |
| 552 | (with-output-chaos-error ('invalid-modexp) | |
| 553 | (princ "premature end of view body") | |
| 554 | )) | |
| 555 | (t (case-equal (car *modexp-parse-input*) | |
| 556 | ("sort" ; sort map | |
| 557 | (let (from to) | |
| 558 | (modexp-skip) ; skip "sort" | |
| 559 | ;; "->" separates from & to | |
| 560 | (setq from (parse-sort-reference '("->"))) | |
| 561 | (when (not (equal "->" (car *modexp-parse-input*))) | |
| 562 | (with-output-chaos-error ('invalid-modexp) | |
| 563 | (format t "parsing sort mapping of ~a, missing \"->\"" | |
| 564 | from) | |
| 565 | )) | |
| 566 | (modexp-skip) ; skip "->" | |
| 567 | ;; parse `to' part. | |
| 568 | (setq to (parse-sort-reference '("," "}" "]"))) | |
| 569 | `(:sort ,from ,to))) | |
| 570 | ("hsort" ; hidden sort map | |
| 571 | (let (from to) | |
| 572 | (modexp-skip) ; skip "hsort" | |
| 573 | ;; "->" separates from & to | |
| 574 | (setq from (parse-sort-reference '("->"))) | |
| 575 | (when (not (equal "->" (car *modexp-parse-input*))) | |
| 576 | (with-output-chaos-error ('invalid-modexp) | |
| 577 | (format t "parsing hidden sort mapping of ~a, missing \"->\"" | |
| 578 | from) | |
| 579 | )) | |
| 580 | (modexp-skip) ; skip "->" | |
| 581 | ;; parse `to' part. | |
| 582 | (setq to (parse-sort-reference '("," "}" "]"))) | |
| 583 | `(:hsort ,from ,to))) | |
| 584 | (("var" "vars") | |
| 585 | (let (v s) | |
| 586 | (modexp-skip) ; skip "var", "vars" | |
| 587 | (setq v nil) | |
| 588 | (loop (let ((inp (car *modexp-parse-input*))) | |
| 589 | (when (equal ":" inp) (return)) | |
| 590 | (push inp v) | |
| 591 | (modexp-skip))) | |
| 592 | (modexp-skip) | |
| 593 | (setq s (parse-sort-reference '("," "}" "." "]"))) | |
| 594 | `(:var ,v ,s))) | |
| 595 | ("op" ; operator map | |
| 596 | (let (a b) | |
| 597 | (modexp-skip) ; skip "op" | |
| 598 | (setq a (parse-op-name '("->"))) | |
| 599 | (when (not (equal "->" (car *modexp-parse-input*))) | |
| 600 | (with-output-chaos-error ('invalid-modexp) | |
| 601 | (format t "in view body, for op ~a, missing \"->\"" a) | |
| 602 | )) | |
| 603 | (modexp-skip) | |
| 604 | (setq b (parse-op-name '("." "}" ","))) | |
| 605 | `(:op ,a ,b))) | |
| 606 | ("bop" ; behavioural operator map | |
| 607 | (let (a b) | |
| 608 | (modexp-skip) ; skip "bop" | |
| 609 | (setq a (parse-op-name '("->"))) | |
| 610 | (when (not (equal "->" (car *modexp-parse-input*))) | |
| 611 | (with-output-chaos-error ('invalid-modexp) | |
| 612 | (format t "in view body, for bop ~a, missing \"->\"" a) | |
| 613 | )) | |
| 614 | (modexp-skip) | |
| 615 | (setq b (parse-op-name '("." "}" ","))) | |
| 616 | `(:bop ,a ,b))) | |
| 617 | ("}" ; empty body | |
| 618 | nil) | |
| 619 | (t (with-output-chaos-error ('invalid-modexp) | |
| 620 | (format t "in view mapping, expecting \"sort\", \"hsort\", \"op\", \"bop\" or \"var\", but encoutered ~A." | |
| 621 | (car *modexp-parse-input*)) | |
| 622 | ))) | |
| 623 | )))) | |
| 550 | (with-output-chaos-error ('invalid-modexp) | |
| 551 | (princ "premature end of view body"))) | |
| 552 | (t (case-equal (car *modexp-parse-input*) | |
| 553 | ("sort" ; sort map | |
| 554 | (let (from to) | |
| 555 | (modexp-skip) ; skip "sort" | |
| 556 | ;; "->" separates from & to | |
| 557 | (setq from (parse-sort-reference '("->"))) | |
| 558 | (when (not (equal "->" (car *modexp-parse-input*))) | |
| 559 | (with-output-chaos-error ('invalid-modexp) | |
| 560 | (format t "parsing sort mapping of ~a, missing \"->\"" | |
| 561 | from))) | |
| 562 | (modexp-skip) ; skip "->" | |
| 563 | ;; parse `to' part. | |
| 564 | (setq to (parse-sort-reference '("," "}" "]"))) | |
| 565 | `(:sort ,from ,to))) | |
| 566 | ("hsort" ; hidden sort map | |
| 567 | (let (from to) | |
| 568 | (modexp-skip) ; skip "hsort" | |
| 569 | ;; "->" separates from & to | |
| 570 | (setq from (parse-sort-reference '("->"))) | |
| 571 | (when (not (equal "->" (car *modexp-parse-input*))) | |
| 572 | (with-output-chaos-error ('invalid-modexp) | |
| 573 | (format t "parsing hidden sort mapping of ~a, missing \"->\"" | |
| 574 | from) | |
| 575 | )) | |
| 576 | (modexp-skip) ; skip "->" | |
| 577 | ;; parse `to' part. | |
| 578 | (setq to (parse-sort-reference '("," "}" "]"))) | |
| 579 | `(:hsort ,from ,to))) | |
| 580 | (("var" "vars") | |
| 581 | (let (v s) | |
| 582 | (modexp-skip) ; skip "var", "vars" | |
| 583 | (setq v nil) | |
| 584 | (loop (let ((inp (car *modexp-parse-input*))) | |
| 585 | (when (equal ":" inp) (return)) | |
| 586 | (push inp v) | |
| 587 | (modexp-skip))) | |
| 588 | (modexp-skip) | |
| 589 | (setq s (parse-sort-reference '("," "}" "." "]"))) | |
| 590 | `(:var ,v ,s))) | |
| 591 | ("op" ; operator map | |
| 592 | (let (a b) | |
| 593 | (modexp-skip) ; skip "op" | |
| 594 | (setq a (parse-op-name '("->"))) | |
| 595 | (when (not (equal "->" (car *modexp-parse-input*))) | |
| 596 | (with-output-chaos-error ('invalid-modexp) | |
| 597 | (format t "in view body, for op ~a, missing \"->\"" a))) | |
| 598 | (modexp-skip) | |
| 599 | (setq b (parse-op-name '("." "}" ","))) | |
| 600 | `(:op ,a ,b))) | |
| 601 | ("bop" ; behavioural operator map | |
| 602 | (let (a b) | |
| 603 | (modexp-skip) ; skip "bop" | |
| 604 | (setq a (parse-op-name '("->"))) | |
| 605 | (when (not (equal "->" (car *modexp-parse-input*))) | |
| 606 | (with-output-chaos-error ('invalid-modexp) | |
| 607 | (format t "in view body, for bop ~a, missing \"->\"" a))) | |
| 608 | (modexp-skip) | |
| 609 | (setq b (parse-op-name '("." "}" ","))) | |
| 610 | `(:bop ,a ,b))) | |
| 611 | ("}" ; empty body | |
| 612 | nil) | |
| 613 | (t (with-output-chaos-error ('invalid-modexp) | |
| 614 | (format t "in view mapping, expecting \"sort\", \"hsort\", \"op\", \"bop\" or \"var\", but encoutered ~A." | |
| 615 | (car *modexp-parse-input*))))))))) | |
| 624 | 616 | |
| 625 | 617 | ;;; ************************* |
| 626 | 618 | ;;; PARSE SORT REFERENCE FORM___________________________________________________ |
| 637 | 629 | )) |
| 638 | 630 | (do-parse-sort-ref cntxt)) |
| 639 | 631 | |
| 640 | #|| | |
| 641 | ;;; MODEXP-CHECK-QUAL | |
| 642 | (defun modexp-check-qual (x) | |
| 643 | (if (stringp x) | |
| 644 | (let ((pos (position #\. x))) | |
| 645 | (if (and pos (< 0 pos) (< (1+ pos) (length x))) | |
| 646 | `(:qual ,(list (subseq x 0 pos)) | |
| 647 | ,(subseq x (1+ pos))) | |
| 648 | x)) | |
| 649 | x)) | |
| 650 | ||# | |
| 651 | ||
| 652 | 632 | ;;; DO-PARSE-SORT-REF |
| 653 | 633 | ;;; * NOTE * |
| 654 | 634 | ;;; Because sort reference can have qualifier, we need to parse module expression. |
| 661 | 641 | (defun do-parse-sort-ref (cntxt) |
| 662 | 642 | (declare (type list cntxt)) |
| 663 | 643 | (cond ((equal "(" (car *modexp-parse-input*)) |
| 664 | ;; parenthesized reference | |
| 665 | (modexp-skip) ; skip "(" | |
| 666 | ;; get first one token | |
| 667 | (let ((val (parse-balanced-context-one ")")) | |
| 668 | (flag t)) ; t iff we are in parenthesized units. | |
| 669 | (when (equal ")" (car *modexp-parse-input*)) | |
| 670 | (modexp-skip) ; skip ")" | |
| 671 | (setq flag nil)) ; we are no more in parenthe | |
| 672 | ;; consider the rest. | |
| 673 | (let ((res (cond ((and (equal "." (car *modexp-parse-input*)) | |
| 674 | (not (member "." cntxt :test #'equal))) | |
| 675 | ;; ( <sort-ref> . <ModExpr> ) --------------------- | |
| 676 | (modexp-skip) ; skip "." | |
| 677 | (%sort-ref* (car val) (do-parse-modexp))) | |
| 678 | ((and (null (cdr val)) | |
| 679 | (stringp (car val)) | |
| 680 | (eql #\. (char (the simple-string (car val)) | |
| 681 | (1- (length (the simple-string | |
| 682 | (car val))))))) | |
| 683 | ;; ( "sort-name." ... ) -------------------------- | |
| 684 | (%sort-ref* (subseq (the simple-string (car val)) | |
| 685 | 0 | |
| 686 | (1- (length | |
| 687 | (the simple-string (car val))))) | |
| 688 | (do-parse-modexp))) | |
| 689 | ((and *modexp-parse-input* | |
| 690 | (<= 2 (length | |
| 691 | (the simple-string | |
| 692 | (car *modexp-parse-input*)))) | |
| 693 | (eql #\. (char (the simple-string | |
| 694 | (car *modexp-parse-input*)) | |
| 695 | 0))) | |
| 696 | ;; ( <sort-ref> ".foo" ... ) --------------------- | |
| 697 | (let ((name (car *modexp-parse-input*))) | |
| 698 | (declare (type simple-string name)) | |
| 699 | (modexp-skip) | |
| 700 | (%sort-ref* (car val) (subseq name 1)))) | |
| 701 | ;; ( <sort-ref> ) --------------------------------- | |
| 702 | (t (%sort-ref* (car val)))))) | |
| 703 | (when flag | |
| 704 | (unless (equal ")" (car *modexp-parse-input*)) | |
| 705 | (with-output-chaos-error ('invalid-modexp) | |
| 706 | (princ "unbalanced parentheses in sort specification.") | |
| 707 | (print-next) | |
| 708 | (princ "context: ") | |
| 709 | (print-simple-princ-open val) | |
| 710 | )) | |
| 711 | (modexp-skip)) | |
| 712 | res))) | |
| 713 | ;; | |
| 714 | ;; not parenthesized reference | |
| 715 | ;; | |
| 716 | (t (let ((val (car *modexp-parse-input*))) | |
| 717 | (modexp-skip) ; skip one token | |
| 718 | (if (stringp val) | |
| 719 | ;; | |
| 720 | (if (eql #\. (char (the simple-string val) (1- (length val)))) | |
| 721 | ;; the last character is ".", thus we assume the rest is | |
| 722 | ;; a modexp which qualifies the name. | |
| 723 | (%sort-ref* (subseq (the simple-string val) | |
| 724 | 0 (1- (length val))) ; name | |
| 725 | (do-parse-modexp)) ; quilifier | |
| 726 | (let ((pos (position #\. (the simple-string val)))) | |
| 727 | (if pos ; name is quilified by simple modexpr. | |
| 728 | (%sort-ref* (subseq (the simple-string val) 0 pos) | |
| 729 | (subseq (the simple-string val) (1+ pos))) | |
| 730 | (%sort-ref* val)))) | |
| 731 | ;; return it as is. | |
| 732 | (%sort-ref* val) | |
| 733 | ))))) | |
| 644 | ;; parenthesized reference | |
| 645 | (modexp-skip) ; skip "(" | |
| 646 | ;; get first one token | |
| 647 | (let ((val (parse-balanced-context-one ")")) | |
| 648 | (flag t)) ; t iff we are in parenthesized units. | |
| 649 | (when (equal ")" (car *modexp-parse-input*)) | |
| 650 | (modexp-skip) ; skip ")" | |
| 651 | (setq flag nil)) ; we are no more in parenthe | |
| 652 | ;; consider the rest. | |
| 653 | (let ((res (cond ((and (equal "." (car *modexp-parse-input*)) | |
| 654 | (not (member "." cntxt :test #'equal))) | |
| 655 | ;; ( <sort-ref> . <ModExpr> ) --------------------- | |
| 656 | (modexp-skip) ; skip "." | |
| 657 | (%sort-ref* (car val) (do-parse-modexp))) | |
| 658 | ((and (null (cdr val)) | |
| 659 | (stringp (car val)) | |
| 660 | (eql #\. (char (the simple-string (car val)) | |
| 661 | (1- (length (the simple-string | |
| 662 | (car val))))))) | |
| 663 | ;; ( "sort-name." ... ) -------------------------- | |
| 664 | (%sort-ref* (subseq (the simple-string (car val)) | |
| 665 | 0 | |
| 666 | (1- (length | |
| 667 | (the simple-string (car val))))) | |
| 668 | (do-parse-modexp))) | |
| 669 | ((and *modexp-parse-input* | |
| 670 | (<= 2 (length | |
| 671 | (the simple-string | |
| 672 | (car *modexp-parse-input*)))) | |
| 673 | (eql #\. (char (the simple-string | |
| 674 | (car *modexp-parse-input*)) | |
| 675 | 0))) | |
| 676 | ;; ( <sort-ref> ".foo" ... ) --------------------- | |
| 677 | (let ((name (car *modexp-parse-input*))) | |
| 678 | (declare (type simple-string name)) | |
| 679 | (modexp-skip) | |
| 680 | (%sort-ref* (car val) (subseq name 1)))) | |
| 681 | ;; ( <sort-ref> ) --------------------------------- | |
| 682 | (t (%sort-ref* (car val)))))) | |
| 683 | (when flag | |
| 684 | (unless (equal ")" (car *modexp-parse-input*)) | |
| 685 | (with-output-chaos-error ('invalid-modexp) | |
| 686 | (princ "unbalanced parentheses in sort specification.") | |
| 687 | (print-next) | |
| 688 | (princ "context: ") | |
| 689 | (print-simple-princ-open val) | |
| 690 | )) | |
| 691 | (modexp-skip)) | |
| 692 | res))) | |
| 693 | ;; | |
| 694 | ;; not parenthesized reference | |
| 695 | ;; | |
| 696 | (t (let ((val (car *modexp-parse-input*))) | |
| 697 | (modexp-skip) ; skip one token | |
| 698 | (if (stringp val) | |
| 699 | ;; | |
| 700 | (if (eql #\. (char (the simple-string val) (1- (length val)))) | |
| 701 | ;; the last character is ".", thus we assume the rest is | |
| 702 | ;; a modexp which qualifies the name. | |
| 703 | (%sort-ref* (subseq (the simple-string val) | |
| 704 | 0 (1- (length val))) ; name | |
| 705 | (do-parse-modexp)) ; quilifier | |
| 706 | (let ((pos (position #\. (the simple-string val)))) | |
| 707 | (if pos ; name is quilified by simple modexpr. | |
| 708 | (%sort-ref* (subseq (the simple-string val) 0 pos) | |
| 709 | (subseq (the simple-string val) (1+ pos))) | |
| 710 | (%sort-ref* val)))) | |
| 711 | ;; return it as is. | |
| 712 | (%sort-ref* val)))))) | |
| 734 | 713 | |
| 735 | 714 | ;;; **************************** |
| 736 | 715 | ;;; PARSE OPERATOR REFRENCE FORM______________________________________________________ |
| 742 | 721 | (defun parse-operator-reference (cntxt &optional (ignore-qual nil)) |
| 743 | 722 | (declare (type list cntxt)) |
| 744 | 723 | (when *on-modexp-debug* |
| 745 | (format t "~&[parse-operator-reference]:*modexp-parse-input*=~a" *modexp-parse-input*)) | |
| 724 | (format t "~%[parse-operator-reference]:*modexp-parse-input*:~% ~s" *modexp-parse-input*)) | |
| 746 | 725 | (cond ((null *modexp-parse-input*) |
| 747 | (with-output-chaos-error ('invalid-modexp) | |
| 748 | (princ "premature end of input at operator specification"))) | |
| 749 | ((equal "(" (car *modexp-parse-input*)) | |
| 750 | ;; parenthesized reference ------------------------------------------------- | |
| 751 | (modexp-skip) ; skip "(" | |
| 752 | (let ((val (parse-op-simple-name '(")"))) | |
| 753 | (flag t)) | |
| 754 | (when (equal ")" (car *modexp-parse-input*)) | |
| 755 | (modexp-skip) | |
| 756 | (setq flag nil)) ; we are now out of parens. | |
| 757 | ;; | |
| 758 | (let ((res (cond ((and (not ignore-qual) | |
| 759 | (equal "." (car *modexp-parse-input*)) | |
| 760 | (not (member "." cntxt :test #'equal))) | |
| 761 | ;; ( <simple-op-ref> . <Modexpr> ...) | |
| 762 | (modexp-skip) ; skip "." | |
| 763 | (%opref* val (do-parse-modexp))) | |
| 764 | ((and *modexp-parse-input* | |
| 765 | (not ignore-qual) | |
| 766 | (<= 2 (length (car *modexp-parse-input*))) | |
| 767 | (eql #\. (char | |
| 768 | (the simple-string | |
| 769 | (car *modexp-parse-input*)) | |
| 770 | 0))) | |
| 771 | ;; ( <simple-op-ref> ".foo" .. ) | |
| 772 | (let ((name (car *modexp-parse-input*))) | |
| 773 | (declare (type simple-string name)) | |
| 774 | (modexp-skip) ; consume one token | |
| 775 | (%opref* val (subseq name 1)))) | |
| 776 | ;; as is | |
| 777 | (t (%opref* val))))) | |
| 778 | (when flag | |
| 779 | (unless (equal ")" (car *modexp-parse-input*)) | |
| 780 | (with-output-chaos-error ('invalid-modexp) | |
| 781 | (princ "unbalanced parentheses in operator specification.") | |
| 782 | (print-next) | |
| 783 | (princ "context: ") | |
| 784 | (print-simple-princ-open val) | |
| 785 | )) | |
| 786 | (modexp-skip)) | |
| 787 | res))) | |
| 788 | ;; not in parenthe --------------------------------------------------------- | |
| 789 | (t (let ((val (parse-op-simple-name cntxt))) | |
| 790 | (if (and (consp val) (null (cdr val)) (stringp (car val))) | |
| 791 | ;; op-ref is just a simple string. | |
| 792 | (let ((name (car val))) | |
| 793 | (declare (type simple-string name)) | |
| 794 | (let ((pos (and (not ignore-qual) (position #\. name)))) | |
| 795 | (if (and pos (< 0 pos) (< (1+ pos) (length name))) | |
| 796 | ;; "foo.qualifier" | |
| 797 | (%opref* (list (subseq name 0 pos)) | |
| 798 | (subseq name (1+ pos))) | |
| 799 | (%opref* val)))) | |
| 800 | (%opref* val))))) | |
| 801 | ) | |
| 726 | (with-output-chaos-error ('invalid-modexp) | |
| 727 | (princ "premature end of input at operator specification"))) | |
| 728 | ((equal "(" (car *modexp-parse-input*)) | |
| 729 | ;; parenthesized reference ------------------------------------------------- | |
| 730 | (modexp-skip) ; skip "(" | |
| 731 | (let ((val (parse-op-simple-name '(")"))) | |
| 732 | (in-paren t)) | |
| 733 | (when (equal ")" (car *modexp-parse-input*)) | |
| 734 | (modexp-skip) | |
| 735 | (setq in-paren nil)) ; we are now out of parens. | |
| 736 | (let ((res (cond ((and (not ignore-qual) | |
| 737 | ;; check qualifier | |
| 738 | (equal "." (car *modexp-parse-input*)) | |
| 739 | (cdr *modexp-parse-input*) | |
| 740 | (not (member "." cntxt :test #'equal))) | |
| 741 | ;; ( <simple-op-ref> . <Modexpr> ...) | |
| 742 | (modexp-skip) ; skip "." | |
| 743 | (%opref* val (do-parse-modexp))) | |
| 744 | ((and *modexp-parse-input* | |
| 745 | (not ignore-qual) | |
| 746 | ;; check qualifier | |
| 747 | (<= 2 (length (car *modexp-parse-input*))) | |
| 748 | (eql #\. (char | |
| 749 | (the simple-string | |
| 750 | (car *modexp-parse-input*)) | |
| 751 | 0))) | |
| 752 | ;; ( <simple-op-ref> ".foo" .. ) | |
| 753 | (let ((name (car *modexp-parse-input*))) | |
| 754 | (declare (type simple-string name)) | |
| 755 | (modexp-skip) ; consume one token | |
| 756 | (%opref* val (subseq name 1)))) | |
| 757 | ;; as is | |
| 758 | (t (%opref* val))))) | |
| 759 | (when in-paren | |
| 760 | (unless (equal ")" (car *modexp-parse-input*)) | |
| 761 | (with-output-chaos-error ('invalid-modexp) | |
| 762 | (princ "unbalanced parentheses in operator specification.") | |
| 763 | (print-next) | |
| 764 | (princ "context: ") | |
| 765 | (print-simple-princ-open val))) | |
| 766 | (modexp-skip)) | |
| 767 | res))) | |
| 768 | ;; not in parenthe --------------------------------------------------------- | |
| 769 | (t (let ((val (parse-op-simple-name cntxt))) | |
| 770 | (if (and (consp val) (null (cdr val)) (stringp (car val))) | |
| 771 | ;; op-ref is just a simple string. | |
| 772 | (let ((name (car val))) | |
| 773 | (declare (type simple-string name)) | |
| 774 | (let ((pos (and (not ignore-qual) (position #\. name)))) | |
| 775 | (if (and pos (< 0 pos) (< (1+ pos) (length name))) | |
| 776 | ;; "foo.qualifier" | |
| 777 | (%opref* (list (subseq name 0 pos)) | |
| 778 | (subseq name (1+ pos))) | |
| 779 | (%opref* val)))) | |
| 780 | (let ((mod-ref (last val))) | |
| 781 | (when (stringp (car mod-ref)) | |
| 782 | (setq mod-ref (car mod-ref)) | |
| 783 | (let ((pos (and (not ignore-qual) (position #\. mod-ref)))) | |
| 784 | (when *on-modexp-debug* | |
| 785 | (format t "~%[]:pos = ~a, mod-ref = ~s" pos mod-ref)) | |
| 786 | (if (and pos (< (1+ pos) (length mod-ref))) | |
| 787 | ;; .qualifier | |
| 788 | (%opref* (butlast val) | |
| 789 | (subseq mod-ref (1+ pos))) | |
| 790 | (%opref* val)))))))))) | |
| 802 | 791 | |
| 803 | 792 | ;;; PARSE-OP-SIMPLE-NAME |
| 804 | 793 | |
| 805 | 794 | (defun parse-op-simple-name (cntxt) |
| 806 | 795 | (if (equal "(" (car *modexp-parse-input*)) |
| 807 | 796 | (progn (modexp-skip) |
| 808 | (prog1 | |
| 809 | (parse-balanced-context '(")")) | |
| 810 | (modexp-skip))) | |
| 797 | (prog1 | |
| 798 | (parse-balanced-context '(")")) | |
| 799 | (modexp-skip))) | |
| 811 | 800 | (let ((res nil)) |
| 812 | (loop (when (null *modexp-parse-input*) | |
| 813 | (if (null cntxt) | |
| 814 | (return) | |
| 815 | (with-output-chaos-error ('invalid-modexp) | |
| 816 | (princ "premature end of input in operator pattern.") | |
| 817 | (print-next) | |
| 818 | (princ "beginning of pattern: ") | |
| 819 | (print-simple-princ-open (nreverse res)) | |
| 820 | (print-next) | |
| 821 | (princ "expecting one of: ") | |
| 822 | (princ cntxt) | |
| 823 | ))) | |
| 824 | (when (member (car *modexp-parse-input*) cntxt :test #'equal) | |
| 825 | (return)) | |
| 826 | (setq res (nconc res (parse-balanced-context cntxt)))) | |
| 827 | (setq res (mapcan #'(lambda (x) (remove "" (parse-with-delimiter2 x #\_) :test #'equal)) res)) | |
| 828 | ;; (setq res (remove "" res :test #'equal)) | |
| 829 | res))) | |
| 801 | (loop (when (null *modexp-parse-input*) | |
| 802 | (if (null cntxt) | |
| 803 | (return) | |
| 804 | (with-output-chaos-error ('invalid-modexp) | |
| 805 | (princ "premature end of input in operator pattern.") | |
| 806 | (print-next) | |
| 807 | (princ "beginning of pattern: ") | |
| 808 | (print-simple-princ-open (nreverse res)) | |
| 809 | (print-next) | |
| 810 | (princ "expecting one of: ") | |
| 811 | (princ cntxt)))) | |
| 812 | (when (member (car *modexp-parse-input*) cntxt :test #'equal) | |
| 813 | (return)) | |
| 814 | (setq res (nconc res (parse-balanced-context cntxt)))) | |
| 815 | (setq res (mapcan #'(lambda (x) (remove "" (parse-with-delimiter2 x #\_) :test #'equal)) res)) | |
| 816 | ;; (setq res (remove "" res :test #'equal)) | |
| 817 | res))) | |
| 830 | 818 | |
| 831 | 819 | ;;; PARSE PARAMETER REFERENCE |
| 832 | 820 | ;;;***************************************************************************** |
| 836 | 824 | (declare (type list cntxt)) |
| 837 | 825 | (if (equal "(" (car *modexp-parse-input*)) |
| 838 | 826 | (progn (modexp-skip) |
| 839 | (prog1 | |
| 840 | (parse-balanced-context '(")")) | |
| 841 | (modexp-skip))) | |
| 827 | (prog1 | |
| 828 | (parse-balanced-context '(")")) | |
| 829 | (modexp-skip))) | |
| 842 | 830 | (let ((res nil)) |
| 843 | (loop (when (null *modexp-parse-input*) | |
| 844 | (if (null cntxt) | |
| 845 | (return) | |
| 846 | (with-output-chaos-error ('invalid-modexp) | |
| 847 | (princ "premature end of input in parameter name.") | |
| 848 | (print-next) | |
| 849 | (princ "beginning of pattern: ") | |
| 850 | (print-simple-princ-open (nreverse res)) | |
| 851 | (print-next) | |
| 852 | (princ "expecting one of: ") | |
| 853 | (princ cntxt) | |
| 854 | ))) | |
| 855 | (when (member (car *modexp-parse-input*) cntxt :test #'equal) | |
| 856 | (return)) | |
| 857 | (setq res (nconc res (parse-balanced-context cntxt)))) | |
| 858 | res))) | |
| 831 | (loop (when (null *modexp-parse-input*) | |
| 832 | (if (null cntxt) | |
| 833 | (return) | |
| 834 | (with-output-chaos-error ('invalid-modexp) | |
| 835 | (princ "premature end of input in parameter name.") | |
| 836 | (print-next) | |
| 837 | (princ "beginning of pattern: ") | |
| 838 | (print-simple-princ-open (nreverse res)) | |
| 839 | (print-next) | |
| 840 | (princ "expecting one of: ") | |
| 841 | (princ cntxt) | |
| 842 | ))) | |
| 843 | (when (member (car *modexp-parse-input*) cntxt :test #'equal) | |
| 844 | (return)) | |
| 845 | (setq res (nconc res (parse-balanced-context cntxt)))) | |
| 846 | res))) | |
| 859 | 847 | |
| 860 | 848 | |
| 861 | 849 | ;;; PARSE-BALANCED-CONTEXT |
| 863 | 851 | (defun parse-balanced-context (cntxt) |
| 864 | 852 | (declare (type list cntxt)) |
| 865 | 853 | (let ((res nil) |
| 866 | (d 0)) | |
| 854 | (d 0)) | |
| 867 | 855 | (declare (type fixnum d)) |
| 868 | 856 | (loop (cond ((null *modexp-parse-input*) |
| 869 | (if (null cntxt) | |
| 870 | (return (nreverse res)) | |
| 871 | (with-output-chaos-error ('invalid-modexp) | |
| 872 | (princ "premature end of input after:") | |
| 873 | (print-simple-princ-open (nreverse res)) | |
| 874 | ))) | |
| 875 | (t (let ((cur (car *modexp-parse-input*))) | |
| 876 | (when (and (and (= 0 d) | |
| 877 | (member cur cntxt :test #'equal))) | |
| 878 | (return (nreverse res))) | |
| 879 | (setq res (cons cur res)) | |
| 880 | (modexp-skip) | |
| 881 | (cond ((equal ")" cur) | |
| 882 | (decf d) | |
| 883 | (when (= -1 d) | |
| 884 | (with-output-simple-msg () | |
| 885 | (princ "[Error] too many ')'s") | |
| 886 | (return (nreverse res))))) | |
| 887 | ((equal "(" cur) (incf d))))))))) | |
| 857 | (if (null cntxt) | |
| 858 | (return (nreverse res)) | |
| 859 | (with-output-chaos-error ('invalid-modexp) | |
| 860 | (princ "premature end of input after:") | |
| 861 | (print-simple-princ-open (nreverse res)) | |
| 862 | ))) | |
| 863 | (t (let ((cur (car *modexp-parse-input*))) | |
| 864 | (when (and (and (= 0 d) | |
| 865 | (member cur cntxt :test #'equal))) | |
| 866 | (return (nreverse res))) | |
| 867 | (setq res (cons cur res)) | |
| 868 | (modexp-skip) | |
| 869 | (cond ((equal ")" cur) | |
| 870 | (decf d) | |
| 871 | (when (= -1 d) | |
| 872 | (with-output-simple-msg () | |
| 873 | (princ "[Error] too many ')'s") | |
| 874 | (return (nreverse res))))) | |
| 875 | ((equal "(" cur) (incf d))))))))) | |
| 888 | 876 | |
| 889 | 877 | ;;; PARSE-BALANCED-CONTEXT-ONE |
| 890 | 878 | |
| 892 | 880 | (declare (ignore cntxt)) |
| 893 | 881 | (if (equal "(" (car *modexp-parse-input*)) |
| 894 | 882 | (progn (modexp-skip) |
| 895 | (prog1 | |
| 896 | (parse-balanced-context '(")")) | |
| 897 | (modexp-skip))) | |
| 883 | (prog1 | |
| 884 | (parse-balanced-context '(")")) | |
| 885 | (modexp-skip))) | |
| 898 | 886 | (prog1 |
| 899 | (list (car *modexp-parse-input*)) | |
| 900 | (modexp-skip)) | |
| 887 | (list (car *modexp-parse-input*)) | |
| 888 | (modexp-skip)) | |
| 901 | 889 | )) |
| 902 | 890 | |
| 903 | 891 | ;;; EOF |
| 0 | 0 | ;;;-*- Mode:LISP; Package:CHAOS; Base:10; Syntax:Common-lisp -*- |
| 1 | 1 | ;;; |
| 2 | ;;; Copyright (c) 2000-2014, Toshimi Sawada. All rights reserved. | |
| 2 | ;;; Copyright (c) 2000-2015, Toshimi Sawada. All rights reserved. | |
| 3 | 3 | ;;; |
| 4 | 4 | ;;; Redistribution and use in source and binary forms, with or without |
| 5 | 5 | ;;; modification, are permitted provided that the following conditions |
| 27 | 27 | ;;; |
| 28 | 28 | (in-package :chaos) |
| 29 | 29 | #|============================================================================== |
| 30 | System: CHAOS | |
| 31 | Module: primitives | |
| 32 | File: print-object.lisp | |
| 30 | System: CHAOS | |
| 31 | Module: primitives | |
| 32 | File: print-object.lisp | |
| 33 | 33 | ==============================================================================|# |
| 34 | 34 | #-:chaos-debug |
| 35 | 35 | (declaim (optimize (speed 3) (safety 0) #-GCL (debug 0))) |
| 37 | 37 | (declaim (optimize (speed 1) (safety 3) #-GCL (debug 3))) |
| 38 | 38 | |
| 39 | 39 | ;;;***************************************************************************** |
| 40 | ;;; INTERNAL OBJECT PRINTERS | |
| 40 | ;;; INTERNAL OBJECT PRINTERS | |
| 41 | 41 | ;;;***************************************************************************** |
| 42 | 42 | |
| 43 | 43 | ;;;********************** |
| 49 | 49 | (defun print-sort-ast (ast &optional (stream *standard-output*)) |
| 50 | 50 | (let ((*standard-output* stream)) |
| 51 | 51 | (let ((name (%sort-ref-name ast)) |
| 52 | (qual (%sort-ref-qualifier ast))) | |
| 53 | (format t "~&Sort : ~a" name) | |
| 52 | (qual (%sort-ref-qualifier ast))) | |
| 53 | (format t "~%Sort : ~a" name) | |
| 54 | 54 | (when qual |
| 55 | (format t "~& qualified by the module expression: ") | |
| 56 | (print-modexp qual stream t t))))) | |
| 55 | (format t "~& qualified by the module expression: ") | |
| 56 | (print-modexp qual stream t t))))) | |
| 57 | 57 | |
| 58 | 58 | (defun print-sort-ref (ast &optional (stream *standard-output*)) |
| 59 | 59 | (if (%is-sort-ref ast) |
| 60 | 60 | (let ((*standard-output* stream) |
| 61 | (name (%sort-ref-name ast)) | |
| 62 | (qual (%sort-ref-qualifier ast))) | |
| 63 | (if qual | |
| 64 | (progn | |
| 65 | (format t "~a." name) | |
| 66 | (print-modexp qual stream t t)) | |
| 67 | (format t "~a" name))) | |
| 61 | (name (%sort-ref-name ast)) | |
| 62 | (qual (%sort-ref-qualifier ast))) | |
| 63 | (if qual | |
| 64 | (progn | |
| 65 | (format t "~a." name) | |
| 66 | (print-modexp qual stream t t)) | |
| 67 | (format t "~a" name))) | |
| 68 | 68 | (princ ast))) |
| 69 | 69 | |
| 70 | 70 | ;;;(B)SORT/SUBSORT DECLARATION |
| 73 | 73 | ;;; SORT DECLARATION |
| 74 | 74 | (defun print-sort-decl (ast &optional (stream *standard-output*)) |
| 75 | 75 | (format stream "(%sort-decl ~s ~s)" (%sort-decl-name ast) |
| 76 | (%sort-decl-hidden ast))) | |
| 76 | (%sort-decl-hidden ast))) | |
| 77 | 77 | |
| 78 | 78 | ;;; SUBSORT DECLARATION |
| 79 | 79 | (defun print-subsort-decl (ast &optional (stream *standard-output*)) |
| 80 | 80 | ;; #|| |
| 81 | 81 | (fresh-line) |
| 82 | 82 | (let ((s-seq (remove nil (mapcar #'(lambda (x) |
| 83 | (if (atom x) | |
| 84 | x | |
| 85 | (%sort-ref-name x))) | |
| 86 | (%subsort-decl-sort-relation ast))))) | |
| 87 | (format stream "~&Subsort declaration : ~{~a~^ ~a ~}" s-seq)) | |
| 83 | (if (atom x) | |
| 84 | x | |
| 85 | (%sort-ref-name x))) | |
| 86 | (%subsort-decl-sort-relation ast))))) | |
| 87 | (format stream "~%Subsort declaration : ~{~a~^ ~a ~}" s-seq)) | |
| 88 | 88 | ;; ||# |
| 89 | 89 | #|| |
| 90 | 90 | (format stream |
| 91 | "(%subsort-decl ~{~s~^ ~s ~})" | |
| 92 | (%subsort-decl-sort-relation ast)) | |
| 91 | "(%subsort-decl ~{~s~^ ~s ~})" | |
| 92 | (%subsort-decl-sort-relation ast)) | |
| 93 | 93 | ||# |
| 94 | 94 | ) |
| 95 | 95 | |
| 96 | 96 | ;;; BSORT DECLARATION |
| 97 | 97 | (defun print-bsort-decl (ast &optional (stream *standard-output*)) |
| 98 | 98 | (let ((tp (%bsort-decl-token-predicate ast)) |
| 99 | (tc (%bsort-decl-term-creator ast)) | |
| 100 | (tpr (%bsort-decl-term-printer ast)) | |
| 101 | (td (%bsort-decl-term-predicate ast))) | |
| 99 | (tc (%bsort-decl-term-creator ast)) | |
| 100 | (tpr (%bsort-decl-term-printer ast)) | |
| 101 | (td (%bsort-decl-term-predicate ast))) | |
| 102 | 102 | (format stream "(%bsort-decl ~s ~s ~s ~s ~s ~s)" (%bsort-decl-name ast) |
| 103 | tp tc tpr td | |
| 104 | (%bsort-decl-hidden ast)) | |
| 103 | tp tc tpr td | |
| 104 | (%bsort-decl-hidden ast)) | |
| 105 | 105 | #|| |
| 106 | 106 | (when tp |
| 107 | 107 | (format stream "~& token predicate = ~a" tp)) |
| 117 | 117 | ;;; PRINCIPAL-SORT-DECLARATION |
| 118 | 118 | (defun print-psort-decl (ast &optional (stream *standard-output*)) |
| 119 | 119 | #|| |
| 120 | (format stream "~&Principal sort declaration : ~a" | |
| 121 | (%psort-decl-sort ast)) | |
| 120 | (format stream "~%Principal sort declaration : ~a" | |
| 121 | (%psort-decl-sort ast)) | |
| 122 | 122 | ||# |
| 123 | (format stream "(%psort-decl ~s)" (%psort-decl-sort ast))) | |
| 123 | (format stream "~&(%psort-decl ~s)" (%psort-decl-sort ast))) | |
| 124 | 124 | |
| 125 | 125 | ;;; Operator Reference |
| 126 | 126 | ;;;----------------------------------------------------------------------------- |
| 127 | 127 | (defun print-opref (ast &optional (stream *standard-output*)) |
| 128 | 128 | #|| |
| 129 | 129 | (let ((*standard-output* stream) |
| 130 | (name (%opref-name ast)) | |
| 131 | (module (%opref-module ast)) | |
| 132 | (numargs (%opref-num-args ast))) | |
| 133 | (format t "~&operator reference : name = ~a" name) | |
| 130 | (name (%opref-name ast)) | |
| 131 | (module (%opref-module ast)) | |
| 132 | (numargs (%opref-num-args ast))) | |
| 133 | (format t "~%operator reference : name = ~a" name) | |
| 134 | 134 | (format t "~& module = ") |
| 135 | 135 | (print-modexp module stream t t) |
| 136 | 136 | (when numargs |
| 137 | 137 | (format t "~& number of arguments = ~d" numargs))) |
| 138 | 138 | ||# |
| 139 | 139 | (format stream "~s ~s ~s" (%opref-name ast) |
| 140 | (%opref-module ast) | |
| 141 | (%opref-num-args ast)) | |
| 140 | (%opref-module ast) | |
| 141 | (%opref-num-args ast)) | |
| 142 | 142 | ) |
| 143 | 143 | |
| 144 | 144 | (defun print-opref-simple (ast &optional (stream *standard-output*)) |
| 145 | 145 | (let ((*standard-output* stream) |
| 146 | (name (%opref-name ast)) | |
| 147 | (module (%opref-module ast))) | |
| 146 | (name (%opref-name ast)) | |
| 147 | (module (%opref-module ast))) | |
| 148 | 148 | (if (cdr name) |
| 149 | (princ name) | |
| 150 | (princ (car name))) | |
| 149 | (princ name) | |
| 150 | (princ (car name))) | |
| 151 | 151 | (when module |
| 152 | 152 | (princ ".") |
| 153 | 153 | (print-modexp module stream t t)))) |
| 156 | 156 | ;;;----------------------------------------------------------------------------- |
| 157 | 157 | (defun print-op-decl-ast (ast &optional (stream *standard-output*)) |
| 158 | 158 | (let ((*standard-output* stream) |
| 159 | (name (%op-decl-name ast)) | |
| 160 | (arity (%op-decl-arity ast)) | |
| 161 | (coarity (%op-decl-coarity ast)) | |
| 162 | (attr (%op-decl-attribute ast))) | |
| 159 | (name (%op-decl-name ast)) | |
| 160 | (arity (%op-decl-arity ast)) | |
| 161 | (coarity (%op-decl-coarity ast)) | |
| 162 | (attr (%op-decl-attribute ast))) | |
| 163 | 163 | (format t "Operator declaration:") |
| 164 | 164 | (let ((*print-indent* (+ 2 *print-indent*))) |
| 165 | 165 | (print-next) |
| 167 | 167 | (print-next) |
| 168 | 168 | (format t "arity = ") |
| 169 | 169 | (if arity |
| 170 | (let ((flg nil)) | |
| 171 | (dolist (s arity) | |
| 172 | (if flg (princ " ") (setf flg t)) | |
| 173 | (print-sort-ref s))) | |
| 174 | (princ "NONE")) | |
| 170 | (let ((flg nil)) | |
| 171 | (dolist (s arity) | |
| 172 | (if flg (princ " ") (setf flg t)) | |
| 173 | (print-sort-ref s))) | |
| 174 | (princ "NONE")) | |
| 175 | 175 | (print-next) |
| 176 | 176 | (format t "coarity = ") |
| 177 | 177 | (print-sort-ref coarity) |
| 178 | 178 | (when attr |
| 179 | (print-opattrs-ast attr))))) | |
| 179 | (print-opattrs-ast attr))))) | |
| 180 | 180 | |
| 181 | 181 | ;;; Operator Attribute declarations |
| 182 | 182 | ;;;----------------------------------------------------------------------------- |
| 183 | 183 | #|| |
| 184 | 184 | (defun print-opattr-decl (ast &optional (stream *standard-output*)) |
| 185 | 185 | (let ((opref (%opattr-decl-opref ast)) |
| 186 | (attribute (%opattr-decl-attribute ast))) | |
| 186 | (attribute (%opattr-decl-attribute ast))) | |
| 187 | 187 | (print-opref opref stream) |
| 188 | 188 | (print-opattrs-ast attribute stream))) |
| 189 | 189 | |
| 191 | 191 | |
| 192 | 192 | (defun print-opattrs-ast (ast &optional (stream *standard-output*)) |
| 193 | 193 | (let ((theory (%opattrs-theory ast)) |
| 194 | (assoc (%opattrs-assoc ast)) | |
| 195 | (prec (%opattrs-prec ast)) | |
| 196 | (strat (%opattrs-strat ast)) | |
| 197 | (memo (%opattrs-memo ast)) | |
| 198 | (constr (%opattrs-constr ast)) | |
| 199 | (coherent (%opattrs-coherent ast))) | |
| 200 | (format stream "~&attributes : ") | |
| 194 | (assoc (%opattrs-assoc ast)) | |
| 195 | (prec (%opattrs-prec ast)) | |
| 196 | (strat (%opattrs-strat ast)) | |
| 197 | (memo (%opattrs-memo ast)) | |
| 198 | (constr (%opattrs-constr ast)) | |
| 199 | (coherent (%opattrs-coherent ast))) | |
| 200 | (format stream "~%attributes : ") | |
| 201 | 201 | (when theory |
| 202 | 202 | (format stream "~& - theory ~a" theory)) |
| 203 | 203 | (when assoc |
| 218 | 218 | ;;;----------------------------------------------------------------------------- |
| 219 | 219 | (defun print-var-decl (ast &optional (stream *standard-output*)) |
| 220 | 220 | (let* ((*standard-output* stream) |
| 221 | (names (%var-decl-names ast)) | |
| 222 | (sort-ref (%var-decl-sort ast)) | |
| 223 | (sort-name (%sort-ref-name sort-ref)) | |
| 224 | (sort-qual (%sort-ref-qualifier sort-ref))) | |
| 225 | (format t "~&Variable declaration : names =~{ ~a~}" names) | |
| 221 | (names (%var-decl-names ast)) | |
| 222 | (sort-ref (%var-decl-sort ast)) | |
| 223 | (sort-name (%sort-ref-name sort-ref)) | |
| 224 | (sort-qual (%sort-ref-qualifier sort-ref))) | |
| 225 | (format t "~%Variable declaration : names =~{ ~a~}" names) | |
| 226 | 226 | (format t "~& Sort = ~a" sort-name) |
| 227 | 227 | (when sort-qual |
| 228 | 228 | (princ ".") |
| 230 | 230 | |
| 231 | 231 | (defun print-pvar-decl (ast &optional (stream *standard-output*)) |
| 232 | 232 | (let* ((*standard-output* stream) |
| 233 | (names (%pvar-decl-names ast)) | |
| 234 | (sort-ref (%pvar-decl-sort ast)) | |
| 235 | (sort-name (%sort-ref-name sort-ref)) | |
| 236 | (sort-qual (%sort-ref-qualifier sort-ref))) | |
| 237 | (format t "~&Pseud variable declaration : names =~{ ~a~}" names) | |
| 233 | (names (%pvar-decl-names ast)) | |
| 234 | (sort-ref (%pvar-decl-sort ast)) | |
| 235 | (sort-name (%sort-ref-name sort-ref)) | |
| 236 | (sort-qual (%sort-ref-qualifier sort-ref))) | |
| 237 | (format t "~%On-the-fly constant declaration : names =~{ ~a~}" names) | |
| 238 | 238 | (format t "~& Sort = ~a" sort-name) |
| 239 | 239 | (when sort-qual |
| 240 | 240 | (princ ".") |
| 244 | 244 | ;;;----------------------------------------------------------------------------- |
| 245 | 245 | (defun print-let-decl (ast &optional (stream *standard-output*)) |
| 246 | 246 | (let ((sym (%let-sym ast)) |
| 247 | (value (%let-value ast))) | |
| 248 | (format stream "~&let declaration: ") | |
| 247 | (value (%let-value ast))) | |
| 248 | (format stream "~%let declaration: ") | |
| 249 | 249 | (format stream "~& symbol = ~a" sym) |
| 250 | 250 | (format stream "~& value = ~a" value))) |
| 251 | 251 | |
| 253 | 253 | ;;;----------------------------------------------------------------------------- |
| 254 | 254 | (defun print-macro-decl (ast &optional (stream *standard-output*)) |
| 255 | 255 | (let ((lhs (%macro-lhs ast)) |
| 256 | (rhs (%macro-rhs ast))) | |
| 257 | (format stream "~¯o declaration:") | |
| 256 | (rhs (%macro-rhs ast))) | |
| 257 | (format stream "~%macro declaration:") | |
| 258 | 258 | (format stream "~% LHS = ~a" lhs) |
| 259 | 259 | (format stream "~% RHS = ~a" rhs))) |
| 260 | 260 | |
| 262 | 262 | ;;;----------------------------------------------------------------------------- |
| 263 | 263 | (defun print-axiom-decl-form (ast &optional (stream *standard-output*)) |
| 264 | 264 | (let ((type (%axiom-decl-type ast)) |
| 265 | (labels (%axiom-decl-labels ast)) | |
| 266 | (lhs (%axiom-decl-lhs ast)) | |
| 267 | (rhs (%axiom-decl-rhs ast)) | |
| 268 | (cond (%axiom-decl-cond ast))) | |
| 269 | (format stream "~&axiom declaration(~a): " type) | |
| 265 | (labels (%axiom-decl-labels ast)) | |
| 266 | (lhs (%axiom-decl-lhs ast)) | |
| 267 | (rhs (%axiom-decl-rhs ast)) | |
| 268 | (cond (%axiom-decl-cond ast))) | |
| 269 | (format stream "~%axiom declaration(~a): " type) | |
| 270 | 270 | (if labels |
| 271 | (format stream " labels =~{~a ~}" labels)) | |
| 271 | (format stream " labels =~{~a ~}" labels)) | |
| 272 | 272 | (format stream "~& lhs = ~a" lhs) |
| 273 | 273 | (format stream "~& rhs = ~a" rhs) |
| 274 | 274 | (if cond |
| 275 | (format stream "~& condition = ~a" cond)))) | |
| 275 | (format stream "~& condition = ~a" cond)))) | |
| 276 | 276 | |
| 277 | 277 | ;;; IMPORT-DECLARATION |
| 278 | 278 | ;;;----------------------------------------------------------------------------- |
| 279 | 279 | (defun print-import-decl (ast &optional (stream *standard-output*)) |
| 280 | 280 | (let ((mode (%import-mode ast)) |
| 281 | (mod (%import-module ast)) | |
| 282 | (as (%import-alias ast))) | |
| 281 | (mod (%import-module ast)) | |
| 282 | (as (%import-alias ast))) | |
| 283 | 283 | (format stream "import declaration : ") |
| 284 | 284 | (format stream "mode = ~a, " mode) |
| 285 | 285 | (when as |
| 297 | 297 | |
| 298 | 298 | ;;; top level modexp printer --------------------------------------------------- |
| 299 | 299 | |
| 300 | #|| | |
| 301 | 300 | (defun get-context-name (obj) |
| 302 | (let ((context-mod (object-context-mod obj))) | |
| 301 | (let ((context-mod (get-object-context obj))) | |
| 303 | 302 | (if context-mod |
| 304 | (with-output-to-string (str) | |
| 305 | (print-mod-name context-mod str t)) | |
| 303 | (get-module-print-name context-mod) | |
| 306 | 304 | nil))) |
| 307 | ||# | |
| 308 | ||
| 309 | (defun get-context-name (obj) | |
| 310 | (let ((context-mod (object-context-mod obj))) | |
| 311 | (if context-mod | |
| 312 | (get-module-print-name context-mod) | |
| 313 | nil))) | |
| 314 | ||
| 315 | (defun get-context-name-extended (obj &optional (context *current-module*)) | |
| 305 | ||
| 306 | (defun get-context-name-extended (obj &optional (context (get-context-module))) | |
| 316 | 307 | (let ((cmod (object-context-mod obj))) |
| 308 | (declare (type (or null module) cmod)) | |
| 317 | 309 | (unless cmod (return-from get-context-name-extended nil)) |
| 318 | ;; | |
| 319 | (when context | |
| 320 | (let ((als (assoc cmod (module-alias context)))) | |
| 321 | (when als | |
| 322 | (return-from get-context-name-extended (cdr als))))) | |
| 323 | ;; | |
| 310 | (let ((als (assoc cmod (module-alias context)))) | |
| 311 | (when als | |
| 312 | (return-from get-context-name-extended (cdr als)))) | |
| 324 | 313 | (let ((name (get-module-print-name cmod))) |
| 325 | 314 | (unless (module-is-parameter-theory cmod) |
| 326 | (cond ((modexp-is-simple-name name) | |
| 327 | (return-from get-context-name-extended name)) | |
| 328 | (t (return-from get-context-name-extended | |
| 329 | (with-output-to-string (str) | |
| 330 | (print-modexp-simple name str)))))) | |
| 315 | (cond ((modexp-is-simple-name name) | |
| 316 | (return-from get-context-name-extended name)) | |
| 317 | (t (return-from get-context-name-extended | |
| 318 | (with-output-to-string (str) | |
| 319 | (print-modexp-simple name str)))))) | |
| 331 | 320 | ;; parameter |
| 332 | 321 | (format nil "parameter ~A of module ~A" |
| 333 | (car name) | |
| 334 | (get-module-print-name (fourth name)))))) | |
| 322 | (car name) | |
| 323 | (get-module-print-name (fourth name)))))) | |
| 335 | 324 | |
| 336 | 325 | (defun print-modexp (me &optional |
| 337 | (stream *standard-output*) | |
| 338 | (simple t) | |
| 339 | (no-param nil)) | |
| 326 | (stream *standard-output*) | |
| 327 | (simple t) | |
| 328 | (no-param nil)) | |
| 340 | 329 | (let ((.file-col. .file-col.) |
| 341 | (*standard-output* stream)) | |
| 330 | (*standard-output* stream)) | |
| 342 | 331 | (if me |
| 343 | (cond | |
| 344 | ;; | |
| 345 | ;; The modexp internal.. | |
| 346 | ((int-plus-p me) (pr-int-plus me stream simple no-param)) | |
| 347 | ((int-rename-p me) (pr-int-rename me stream simple no-param)) | |
| 348 | ((int-instantiation-p me) | |
| 349 | (pr-int-instantiation me stream simple no-param)) | |
| 350 | ;; simple module expr | |
| 351 | ((stringp me) (princ me stream) | |
| 352 | (print-check .file-col. 0 stream)) | |
| 353 | ((module-p me) (print-mod-name me stream simple no-param) | |
| 354 | (print-check .file-col. 0 stream)) | |
| 355 | ;; view structure | |
| 356 | ((view-struct-p me) | |
| 357 | (if simple | |
| 358 | (if (eq (view-name me) :anon-view) | |
| 359 | (print-modexp (view-source me) stream simple no-param) | |
| 360 | (progn (princ (view-name me) stream) | |
| 361 | (print-check .file-col. 0 stream))) | |
| 362 | (print-view me stream simple no-param))) | |
| 363 | ;; special expressions used internally, not defined as AST but | |
| 364 | ;; is generated on the fly. | |
| 365 | ;; what is this? => '("ModuleName"). I'm not sure this can really happen, | |
| 366 | ;; but our reader routine tends to consing an atom. | |
| 367 | ;; anyway, the cost is not so high. | |
| 368 | ((and (consp me) | |
| 369 | (stringp (car me)) | |
| 370 | (null (cdr me))) | |
| 371 | (print-modexp (car me) stream simple no-param)) | |
| 372 | ((modexp-is-error me) | |
| 373 | (princ "(") | |
| 374 | (incf .file-col.) | |
| 375 | (print-simple-princ-open (cdr me) stream) | |
| 376 | (princ ")") | |
| 377 | (decf .file-col.)) | |
| 378 | ((modexp-is-?name? me) | |
| 379 | (print-modexp (?name-name me) stream simple no-param)) | |
| 380 | ((modexp-is-parameter-theory me) | |
| 381 | (let ((cntxt (fourth me))) | |
| 382 | (princ (car me)) | |
| 383 | (when (and cntxt (not (eq *current-module* cntxt))) | |
| 384 | (princ ".") | |
| 385 | (print-mod-name cntxt stream t t) | |
| 386 | (print-check .file-col. 0 stream)))) | |
| 387 | ((%is-modexp me) | |
| 388 | (print-modexp (%modexp-value me) stream simple no-param)) | |
| 389 | ||
| 390 | ;; modexp or other ast in general. | |
| 391 | ((chaos-ast? me) | |
| 392 | (let* ((type (ast-type me)) | |
| 393 | (printer (get type ':print))) | |
| 394 | (if printer | |
| 395 | (if (memq (ast-type me) '(%rmap %ren-sort %ren-op %ren-var | |
| 396 | %ren-param %+ %* %*view %! %view | |
| 397 | %prim-view %view-under %view-from | |
| 398 | %view-mapping)) | |
| 399 | (funcall printer me stream simple no-param) | |
| 400 | (funcall printer me stream)) | |
| 401 | (print-chaos-object me stream)))) | |
| 402 | (t ; ??? | |
| 403 | (print-chaos-object me stream))) | |
| 332 | (cond | |
| 333 | ;; | |
| 334 | ;; The modexp internal.. | |
| 335 | ((int-plus-p me) (pr-int-plus me stream simple no-param)) | |
| 336 | ((int-rename-p me) (pr-int-rename me stream simple no-param)) | |
| 337 | ((int-instantiation-p me) | |
| 338 | (pr-int-instantiation me stream simple no-param)) | |
| 339 | ;; simple module expr | |
| 340 | ((stringp me) (princ me stream) | |
| 341 | (print-check .file-col. 0 stream)) | |
| 342 | ((module-p me) (print-mod-name me stream simple no-param) | |
| 343 | (print-check .file-col. 0 stream)) | |
| 344 | ;; view structure | |
| 345 | ((view-struct-p me) | |
| 346 | (if simple | |
| 347 | (if (eq (view-name me) :anon-view) | |
| 348 | (print-modexp (view-source me) stream simple no-param) | |
| 349 | (progn (princ (view-name me) stream) | |
| 350 | (print-check .file-col. 0 stream))) | |
| 351 | (print-view me stream simple no-param))) | |
| 352 | ;; special expressions used internally, not defined as AST but | |
| 353 | ;; is generated on the fly. | |
| 354 | ;; what is this? => '("ModuleName"). I'm not sure this can really happen, | |
| 355 | ;; but our reader routine tends to consing an atom. | |
| 356 | ;; anyway, the cost is not so high. | |
| 357 | ((and (consp me) | |
| 358 | (stringp (car me)) | |
| 359 | (null (cdr me))) | |
| 360 | (print-modexp (car me) stream simple no-param)) | |
| 361 | ((modexp-is-error me) | |
| 362 | (princ "(") | |
| 363 | (incf .file-col.) | |
| 364 | (print-simple-princ-open (cdr me) stream) | |
| 365 | (princ ")") | |
| 366 | (decf .file-col.)) | |
| 367 | ((modexp-is-?name? me) | |
| 368 | (print-modexp (?name-name me) stream simple no-param)) | |
| 369 | ((modexp-is-parameter-theory me) | |
| 370 | (let ((cntxt (fourth me))) | |
| 371 | (princ (car me)) | |
| 372 | (when (and cntxt (not (eq *current-module* cntxt))) | |
| 373 | (princ ".") | |
| 374 | (print-mod-name cntxt stream t t) | |
| 375 | (print-check .file-col. 0 stream)))) | |
| 376 | ((%is-modexp me) | |
| 377 | (print-modexp (%modexp-value me) stream simple no-param)) | |
| 378 | ||
| 379 | ;; modexp or other ast in general. | |
| 380 | ((chaos-ast? me) | |
| 381 | (let* ((type (ast-type me)) | |
| 382 | (printer (get type ':print))) | |
| 383 | (if printer | |
| 384 | (if (memq (ast-type me) '(%rmap %ren-sort %ren-op %ren-var | |
| 385 | %ren-param %+ %* %*view %! %view | |
| 386 | %prim-view %view-under %view-from | |
| 387 | %view-mapping)) | |
| 388 | (funcall printer me stream simple no-param) | |
| 389 | (funcall printer me stream)) | |
| 390 | (print-chaos-object me stream)))) | |
| 391 | (t ; ??? | |
| 392 | (print-chaos-object me stream))) | |
| 404 | 393 | (princ "None.")))) |
| 405 | 394 | |
| 406 | 395 | ;;; specific Modexp printers --------------------------------------------------- |
| 410 | 399 | (defun print-plus-modexp (me &optional stream simple no-param) |
| 411 | 400 | (let ((flg nil)) |
| 412 | 401 | (do* ((args (reverse (%plus-args me)) (cddr args)) |
| 413 | (l (car args) (car args)) | |
| 414 | (r (cadr args) (cadr args))) | |
| 415 | ((null args)) | |
| 402 | (l (car args) (car args)) | |
| 403 | (r (cadr args) (cadr args))) | |
| 404 | ((null args)) | |
| 416 | 405 | (when flg |
| 417 | (princ " + " stream) | |
| 418 | (print-check .file-col. 0 stream)) | |
| 406 | (princ " + " stream) | |
| 407 | (print-check .file-col. 0 stream)) | |
| 419 | 408 | (print-modexp l stream simple no-param) |
| 420 | 409 | (when r |
| 421 | (setq .file-col. (1- (file-column stream))) | |
| 422 | (princ " + " stream) | |
| 423 | (setq flg t) | |
| 424 | (if (%is-plus r) | |
| 425 | (progn (princ "(" stream) | |
| 426 | (incf .file-col.) | |
| 427 | (print-modexp r stream simple no-param) | |
| 428 | (princ ")" stream) | |
| 429 | (decf .file-col.)) | |
| 430 | (print-modexp r stream simple no-param)))))) | |
| 410 | (setq .file-col. (1- (file-column stream))) | |
| 411 | (princ " + " stream) | |
| 412 | (setq flg t) | |
| 413 | (if (%is-plus r) | |
| 414 | (progn (princ "(" stream) | |
| 415 | (incf .file-col.) | |
| 416 | (print-modexp r stream simple no-param) | |
| 417 | (princ ")" stream) | |
| 418 | (decf .file-col.)) | |
| 419 | (print-modexp r stream simple no-param)))))) | |
| 431 | 420 | |
| 432 | 421 | ;;; *** RENAME *** |
| 433 | 422 | |
| 458 | 447 | |
| 459 | 448 | (defun print-instantiation-modexp (me &optional stream simple no-param) |
| 460 | 449 | (if (or (stringp (%instantiation-module me)) |
| 461 | (and (module-p (%instantiation-module me)) | |
| 462 | (stringp (module-name (%instantiation-module me))))) | |
| 450 | (and (module-p (%instantiation-module me)) | |
| 451 | (stringp (module-name (%instantiation-module me))))) | |
| 463 | 452 | (progn |
| 464 | (print-modexp (%instantiation-module me) stream simple no-param)) | |
| 453 | (print-modexp (%instantiation-module me) stream simple no-param)) | |
| 465 | 454 | (progn |
| 466 | ;; (princ "(" stream) | |
| 467 | (print-modexp (%instantiation-module me) stream simple no-param) | |
| 468 | ;; (princ ")" stream) | |
| 469 | )) | |
| 455 | ;; (princ "(" stream) | |
| 456 | (print-modexp (%instantiation-module me) stream simple no-param) | |
| 457 | ;; (princ ")" stream) | |
| 458 | )) | |
| 470 | 459 | ;; (princ "[" stream) |
| 471 | 460 | (princ "(" stream) |
| 472 | 461 | (incf .file-col.) |
| 473 | 462 | (let ((flg nil) |
| 474 | (pos-arg nil)) | |
| 463 | (pos-arg nil)) | |
| 475 | 464 | (dolist (arg (%instantiation-args me)) |
| 476 | 465 | (let ((arg-name (%!arg-name arg)) |
| 477 | (view (%!arg-view arg))) | |
| 478 | (if flg | |
| 479 | (progn (princ ", " stream) | |
| 480 | (print-check .file-col. 0 stream)) | |
| 481 | (setq flg t)) | |
| 482 | ;; | |
| 483 | (cond ((stringp arg-name) (princ arg-name stream)) | |
| 484 | ((and (consp arg-name) (cdr arg-name)) | |
| 485 | ;; (format t "~a@" (car arg-name)) | |
| 486 | (format t "~a." (car arg-name)) | |
| 487 | (print-chaos-object (cdr arg-name) stream)) | |
| 488 | ((consp arg-name) (princ (car arg-name) stream)) | |
| 489 | (t (let ((na (get-module-nth-arg-name | |
| 490 | (%instantiation-module me) | |
| 491 | arg-name))) | |
| 492 | (setq pos-arg t) | |
| 493 | (when na | |
| 494 | (setq pos-arg nil) | |
| 495 | (princ na stream))))) | |
| 496 | ;; | |
| 497 | (unless pos-arg | |
| 498 | (princ " <= " stream)) | |
| 499 | (print-view-modexp-abbrev view stream simple)))) | |
| 466 | (view (%!arg-view arg))) | |
| 467 | (if flg | |
| 468 | (progn (princ ", " stream) | |
| 469 | (print-check .file-col. 0 stream)) | |
| 470 | (setq flg t)) | |
| 471 | ;; | |
| 472 | (cond ((stringp arg-name) (princ arg-name stream)) | |
| 473 | ((and (consp arg-name) (cdr arg-name)) | |
| 474 | ;; (format t "~a@" (car arg-name)) | |
| 475 | (format t "~a." (car arg-name)) | |
| 476 | (print-chaos-object (cdr arg-name) stream)) | |
| 477 | ((consp arg-name) (princ (car arg-name) stream)) | |
| 478 | (t (let ((na (get-module-nth-arg-name | |
| 479 | (%instantiation-module me) | |
| 480 | arg-name))) | |
| 481 | (setq pos-arg t) | |
| 482 | (when na | |
| 483 | (setq pos-arg nil) | |
| 484 | (princ na stream))))) | |
| 485 | ;; | |
| 486 | (unless pos-arg | |
| 487 | (princ " <= " stream)) | |
| 488 | (print-view-modexp-abbrev view stream simple)))) | |
| 500 | 489 | ;; (princ "]" stream) |
| 501 | 490 | (princ ")" stream) |
| 502 | 491 | (decf .file-col.) |
| 506 | 495 | |
| 507 | 496 | (defun print-ren-sort (ast &optional (stream *standard-output*) pretty) |
| 508 | 497 | (let ((*standard-output* stream) |
| 509 | (p-flg nil)) | |
| 498 | (p-flg nil)) | |
| 510 | 499 | (dolist (elt (%ren-sort-maps ast)) |
| 511 | 500 | (if p-flg |
| 512 | (progn (princ ",") | |
| 513 | (print-check .file-col. 0 stream)) | |
| 514 | (setq p-flg t)) | |
| 501 | (progn (princ ",") | |
| 502 | (print-check .file-col. 0 stream)) | |
| 503 | (setq p-flg t)) | |
| 515 | 504 | (when pretty (print-next)) |
| 516 | 505 | (princ "sort ") |
| 517 | 506 | (print-sort-ref (car elt)) |
| 523 | 512 | |
| 524 | 513 | (defun print-ren-op (ast &optional (stream *standard-output*) pretty) |
| 525 | 514 | (let ((*standard-output* stream) |
| 526 | (p-flg nil)) | |
| 515 | (p-flg nil)) | |
| 527 | 516 | (dolist (elt (%ren-op-maps ast)) |
| 528 | 517 | (if p-flg (princ ",") (setq p-flg t)) |
| 529 | 518 | (when pretty (print-next)) |
| 530 | 519 | (princ "op ") |
| 531 | 520 | (if (%is-opref (car elt)) |
| 532 | (print-opref-simple (car elt)) | |
| 533 | (print-simple-princ-open (car elt))) | |
| 521 | (print-opref-simple (car elt)) | |
| 522 | (print-simple-princ-open (car elt))) | |
| 534 | 523 | (print-check .file-col. 0 stream) |
| 535 | 524 | (princ " -> ") |
| 536 | 525 | (if (%is-opref (cadr elt)) |
| 537 | (print-opref-simple (cadr elt)) | |
| 538 | (print-simple-princ-open (cadr elt)))))) | |
| 526 | (print-opref-simple (cadr elt)) | |
| 527 | (print-simple-princ-open (cadr elt)))))) | |
| 539 | 528 | |
| 540 | 529 | ;;; Parameter renaming |
| 541 | 530 | |
| 542 | 531 | (defun print-ren-param (ast &optional (stream *standard-output*)) |
| 543 | 532 | (let ((*standard-output* stream) |
| 544 | source | |
| 545 | target) | |
| 533 | source | |
| 534 | target) | |
| 546 | 535 | (dolist (elt (%ren-param-maps ast)) |
| 547 | 536 | (setq source (car elt)) |
| 548 | 537 | (setq target (cadr elt)) |
| 556 | 545 | (let ((p-flg nil)) |
| 557 | 546 | (dolist (elt (%vars-elements ast)) |
| 558 | 547 | (let ((var-names (car elt)) |
| 559 | (sort (cadr elt))) | |
| 560 | (when pretty (print-next)) | |
| 561 | (if p-flg (princ ",") (setq p-flg t)) | |
| 562 | (if (cdr var-names) | |
| 563 | (princ "vars" stream) | |
| 564 | (princ "var" stream)) | |
| 565 | (format stream "~{~^ ~a~} : " var-names) | |
| 566 | (print-sort-ref sort stream))))) | |
| 548 | (sort (cadr elt))) | |
| 549 | (when pretty (print-next)) | |
| 550 | (if p-flg (princ ",") (setq p-flg t)) | |
| 551 | (if (cdr var-names) | |
| 552 | (princ "vars" stream) | |
| 553 | (princ "var" stream)) | |
| 554 | (format stream "~{~^ ~a~} : " var-names) | |
| 555 | (print-sort-ref sort stream))))) | |
| 567 | 556 | |
| 568 | 557 | ;;; *** RENAME MAP *** |
| 569 | 558 | |
| 571 | 560 | (declare (ignore simple no-param)) |
| 572 | 561 | (let ((*standard-output* stream)) |
| 573 | 562 | (cond ((null rn) (princ " ## EMPTY RENAME MAP ##")) ; for debugging. |
| 574 | ((%is-rmap rn) | |
| 575 | (let ((flg nil)) | |
| 576 | (dolist (re (%rmap-map rn)) | |
| 577 | (if flg | |
| 578 | (progn (princ ", ") | |
| 579 | (print-check .file-col. 0 stream)) | |
| 580 | (setq flg t)) | |
| 581 | (when pretty (print-next)) | |
| 582 | (print-ast re)))) | |
| 583 | (t (break "print-rename-map, not yet."))))) | |
| 563 | ((%is-rmap rn) | |
| 564 | (let ((flg nil)) | |
| 565 | (dolist (re (%rmap-map rn)) | |
| 566 | (if flg | |
| 567 | (progn (princ ", ") | |
| 568 | (print-check .file-col. 0 stream)) | |
| 569 | (setq flg t)) | |
| 570 | (when pretty (print-next)) | |
| 571 | (print-ast re)))) | |
| 572 | (t (break "print-rename-map, not yet."))))) | |
| 584 | 573 | |
| 585 | 574 | ;;;----------------------------------------------------------------------------- |
| 586 | 575 | ;;; PRINTERS of INTERNAL MODEXP |
| 599 | 588 | (princ " *{ " stream) |
| 600 | 589 | (incf .file-col. 2) |
| 601 | 590 | (if simple |
| 602 | (princ " ... " stream) | |
| 603 | (let ((*print-indent* (+ *print-indent* 4)) | |
| 604 | (sort-maps (int-rename-sort-maps obj)) | |
| 605 | (op-maps (int-rename-op-maps obj))) | |
| 606 | (print-next) | |
| 607 | (let ((flg nil)) | |
| 608 | (dolist (smap sort-maps) | |
| 609 | (if flg (progn (princ ",") (print-check .file-col. 0 stream)) | |
| 610 | (setq flg t)) | |
| 611 | (print-sort-name (car smap)) | |
| 612 | (princ " -> ") | |
| 613 | (print-sort-name (cdr smap)))) | |
| 614 | (let ((flg nil)) | |
| 615 | (dolist (omap op-maps) | |
| 616 | ;; (method :simple . method) | |
| 617 | (if flg (progn (princ ",") | |
| 618 | (print-check .file-col. 0 stream)) | |
| 619 | (setq flg t)) | |
| 620 | (princ "(") (print-chaos-object (car omap)) (princ ")") | |
| 621 | (princ " -> ") | |
| 622 | (princ "(") (print-chaos-object (cdr (last omap))) (princ ")"))) | |
| 623 | )) | |
| 591 | (princ " ... " stream) | |
| 592 | (let ((*print-indent* (+ *print-indent* 4)) | |
| 593 | (sort-maps (int-rename-sort-maps obj)) | |
| 594 | (op-maps (int-rename-op-maps obj))) | |
| 595 | (print-next) | |
| 596 | (let ((flg nil)) | |
| 597 | (dolist (smap sort-maps) | |
| 598 | (if flg (progn (princ ",") (print-check .file-col. 0 stream)) | |
| 599 | (setq flg t)) | |
| 600 | (print-sort-name (car smap)) | |
| 601 | (princ " -> ") | |
| 602 | (print-sort-name (cdr smap)))) | |
| 603 | (let ((flg nil)) | |
| 604 | (dolist (omap op-maps) | |
| 605 | ;; (method :simple . method) | |
| 606 | (if flg (progn (princ ",") | |
| 607 | (print-check .file-col. 0 stream)) | |
| 608 | (setq flg t)) | |
| 609 | (princ "(") (print-chaos-object (car omap)) (princ ")") | |
| 610 | (princ " -> ") | |
| 611 | (princ "(") (print-chaos-object (cdr (last omap))) (princ ")"))) | |
| 612 | )) | |
| 624 | 613 | (if simple |
| 625 | (princ " }") | |
| 626 | (princ " } )")))) | |
| 627 | ||
| 614 | (princ " }") | |
| 615 | (princ " } )")))) | |
| 616 | ||
| 628 | 617 | ;;; PLUS |
| 629 | 618 | (defun pr-int-plus (obj &optional (stream *standard-output*) simple no-param) |
| 630 | 619 | (declare (ignore simple no-param)) |
| 634 | 623 | (format t "(%++ ")) |
| 635 | 624 | ||# |
| 636 | 625 | (let ((*print-indent* (+ *print-indent* 4)) |
| 637 | (flg nil)) | |
| 626 | (flg nil)) | |
| 638 | 627 | (dolist (mod (int-plus-args obj)) |
| 639 | (print-check) | |
| 640 | (when flg (princ " + ")) | |
| 641 | ;; (print-modexp mod stream simple no-param) | |
| 642 | (print-modexp mod stream t t) | |
| 643 | (setq flg t)) | |
| 628 | (print-check) | |
| 629 | (when flg (princ " + ")) | |
| 630 | ;; (print-modexp mod stream simple no-param) | |
| 631 | (print-modexp mod stream t t) | |
| 632 | (setq flg t)) | |
| 644 | 633 | #|| |
| 645 | 634 | (unless simple |
| 646 | (princ " )")) | |
| 635 | (princ " )")) | |
| 647 | 636 | ||# |
| 648 | 637 | ))) |
| 649 | 638 | |
| 650 | 639 | ;;; INSTATIATION |
| 651 | 640 | (defun pr-int-instantiation (obj &optional |
| 652 | (stream *standard-output*) | |
| 653 | simple no-param) | |
| 641 | (stream *standard-output*) | |
| 642 | simple no-param) | |
| 654 | 643 | (declare (ignore simple no-param)) |
| 655 | 644 | (let ((*standard-output* stream)) |
| 656 | 645 | #|| |
| 663 | 652 | ;; (princ "[ ") |
| 664 | 653 | (princ "(") |
| 665 | 654 | (let ((flg nil)) |
| 666 | (dolist (arg (int-instantiation-args obj)) | |
| 667 | (if flg (progn (princ ",") (print-next)) (setq flg t)) | |
| 668 | (let ((arg-name (%!arg-name arg)) | |
| 669 | (pos-arg nil)) | |
| 670 | (cond ((stringp arg-name) (princ arg-name stream)) | |
| 671 | ((and (consp arg-name) (cdr arg-name)) | |
| 672 | ;; (format t "~a@" (car arg-name)) | |
| 673 | (format t "~a." (car arg-name)) | |
| 674 | (print-chaos-object (cdr arg-name) stream)) | |
| 675 | ((consp arg-name) (princ (car arg-name) stream)) | |
| 676 | (t (let ((na (get-module-nth-arg-name | |
| 677 | (int-instantiation-module obj) | |
| 678 | arg-name))) | |
| 679 | (if na | |
| 680 | (progn | |
| 681 | (setq pos-arg nil) | |
| 682 | (princ na stream)) | |
| 683 | (progn | |
| 684 | (setq pos-arg t)))))) | |
| 685 | (unless pos-arg | |
| 686 | (princ " <= ")) | |
| 687 | (let ((*print-indent* (+ *print-indent* 4))) | |
| 688 | ;; (print-view (%!arg-view arg) stream simple no-param) | |
| 689 | (print-view (%!arg-view arg) stream t t) | |
| 690 | )) | |
| 691 | (print-check))) | |
| 655 | (dolist (arg (int-instantiation-args obj)) | |
| 656 | (if flg (progn (princ ",") (print-next)) (setq flg t)) | |
| 657 | (let ((arg-name (%!arg-name arg)) | |
| 658 | (pos-arg nil)) | |
| 659 | (cond ((stringp arg-name) (princ arg-name stream)) | |
| 660 | ((and (consp arg-name) (cdr arg-name)) | |
| 661 | ;; (format t "~a@" (car arg-name)) | |
| 662 | (format t "~a." (car arg-name)) | |
| 663 | (print-chaos-object (cdr arg-name) stream)) | |
| 664 | ((consp arg-name) (princ (car arg-name) stream)) | |
| 665 | (t (let ((na (get-module-nth-arg-name | |
| 666 | (int-instantiation-module obj) | |
| 667 | arg-name))) | |
| 668 | (if na | |
| 669 | (progn | |
| 670 | (setq pos-arg nil) | |
| 671 | (princ na stream)) | |
| 672 | (progn | |
| 673 | (setq pos-arg t)))))) | |
| 674 | (unless pos-arg | |
| 675 | (princ " <= ")) | |
| 676 | (let ((*print-indent* (+ *print-indent* 4))) | |
| 677 | ;; (print-view (%!arg-view arg) stream simple no-param) | |
| 678 | (print-view (%!arg-view arg) stream t t) | |
| 679 | )) | |
| 680 | (print-check))) | |
| 692 | 681 | ;; (princ " ]") |
| 693 | 682 | (princ ")") |
| 694 | 683 | ))) |
| 702 | 691 | (print-view vw stream)) |
| 703 | 692 | |
| 704 | 693 | (defun print-view (vw &optional (stream *standard-output*) simple no-param |
| 705 | (syntax *show-mode*)) | |
| 694 | (syntax *show-mode*)) | |
| 706 | 695 | (if (eq syntax :cafeobj) |
| 707 | 696 | (print-view-in-cafeobj-mode vw |
| 708 | stream simple | |
| 709 | no-param) | |
| 697 | stream simple | |
| 698 | no-param) | |
| 710 | 699 | (print-view-in-chaos-mode vw |
| 711 | stream | |
| 712 | simple | |
| 713 | no-param))) | |
| 700 | stream | |
| 701 | simple | |
| 702 | no-param))) | |
| 714 | 703 | |
| 715 | 704 | (defun print-view-in-cafeobj-mode (vw stream simple no-param) |
| 716 | 705 | (cond ((and (not (stringp vw)) |
| 717 | (chaos-ast? vw) | |
| 706 | (chaos-ast? vw) | |
| 718 | 707 | (memq (ast-type vw) |
| 719 | 708 | '(%view %view-from %prim-view %view-from %view-mapping))) |
| 720 | (let ((printer (get (ast-type vw) ':print))) | |
| 721 | (if printer | |
| 722 | (funcall printer vw stream simple) | |
| 723 | (print-chaos-object vw stream))) | |
| 724 | ) | |
| 725 | ((view-p vw) | |
| 726 | (let ((name (view-name vw)) | |
| 727 | (decl-form (view-decl-form vw))) | |
| 728 | (if simple | |
| 729 | (if (eq name :anon-view) | |
| 730 | (print-modexp (view-source vw) stream t t) | |
| 731 | (princ name stream)) | |
| 732 | (progn | |
| 733 | (let ((*standard-output* stream) | |
| 734 | (*print-indent* (+ 2 *print-indent*))) | |
| 735 | (print-check) | |
| 736 | (format stream "view ~a " name) | |
| 737 | (princ "from ") | |
| 738 | (if decl-form | |
| 739 | (print-modexp (%view-module decl-form) stream simple no-param) | |
| 740 | (print-modexp (view-src vw) stream simple no-param)) | |
| 741 | (princ " to ") | |
| 742 | (if decl-form | |
| 743 | (print-modexp (%view-target decl-form) stream simple no-param) | |
| 744 | (print-modexp (view-target vw) stream simple no-param)) | |
| 745 | (princ " {") | |
| 746 | (if decl-form | |
| 747 | (print-abs-view-mapping (%view-map decl-form) stream simple no-param t) | |
| 748 | (print-view-struct-maps vw stream simple no-param))) | |
| 749 | (print-next) | |
| 750 | (princ " }"))))) | |
| 751 | ;; | |
| 752 | ;; AGGGHHHH! | |
| 753 | ;; | |
| 754 | ((and (consp vw) (stringp (car vw))) (princ vw stream)) | |
| 709 | (let ((printer (get (ast-type vw) ':print))) | |
| 710 | (if printer | |
| 711 | (funcall printer vw stream simple) | |
| 712 | (print-chaos-object vw stream))) | |
| 713 | ) | |
| 714 | ((view-p vw) | |
| 715 | (let ((name (view-name vw)) | |
| 716 | (decl-form (view-decl-form vw))) | |
| 717 | (if simple | |
| 718 | (if (eq name :anon-view) | |
| 719 | (print-modexp (view-source vw) stream t t) | |
| 720 | (princ name stream)) | |
| 721 | (progn | |
| 722 | (let ((*standard-output* stream) | |
| 723 | (*print-indent* (+ 2 *print-indent*))) | |
| 724 | (print-check) | |
| 725 | (format stream "view ~a " name) | |
| 726 | (princ "from ") | |
| 727 | (if decl-form | |
| 728 | (print-modexp (%view-module decl-form) stream simple no-param) | |
| 729 | (print-modexp (view-src vw) stream simple no-param)) | |
| 730 | (princ " to ") | |
| 731 | (if decl-form | |
| 732 | (print-modexp (%view-target decl-form) stream simple no-param) | |
| 733 | (print-modexp (view-target vw) stream simple no-param)) | |
| 734 | (princ " {") | |
| 735 | (if decl-form | |
| 736 | (print-abs-view-mapping (%view-map decl-form) stream simple no-param t) | |
| 737 | (print-view-struct-maps vw stream simple no-param))) | |
| 738 | (print-next) | |
| 739 | (princ " }"))))) | |
| 740 | ;; | |
| 741 | ;; AGGGHHHH! | |
| 742 | ;; | |
| 743 | ((and (consp vw) (stringp (car vw))) (princ vw stream)) | |
| 755 | 744 | ((atom vw) (princ vw stream)) |
| 756 | (t (print-modexp vw stream simple no-param)) | |
| 757 | )) | |
| 745 | (t (print-modexp vw stream simple no-param)) | |
| 746 | )) | |
| 758 | 747 | |
| 759 | 748 | (defun print-view-in-chaos-mode (vw stream &rest ignore) |
| 760 | 749 | (declare (ignore ignore)) |
| 761 | 750 | (let ((*print-pretty* t)) |
| 762 | (format stream "~&~s" (object-decl-form vw)))) | |
| 751 | (format stream "~%~s" (object-decl-form vw)))) | |
| 763 | 752 | |
| 764 | 753 | (defun print-view-struct-maps (view stream &rest ignore) |
| 765 | 754 | (declare (ignore ignore)) |
| 766 | 755 | (let ((*print-indent* (+ *print-indent* 2)) |
| 767 | (sort-maps (view-sort-maps view)) | |
| 768 | (op-maps (view-op-maps view)) | |
| 769 | (*standard-output* stream) | |
| 770 | (flg nil)) | |
| 756 | (sort-maps (view-sort-maps view)) | |
| 757 | (op-maps (view-op-maps view)) | |
| 758 | (*standard-output* stream) | |
| 759 | (flg nil)) | |
| 771 | 760 | (dolist (sm sort-maps) |
| 772 | 761 | (if flg (print-next) (setq flg t)) |
| 773 | 762 | (if (and (sort-struct-p (car sm)) |
| 774 | (sort-is-hidden (car sm))) | |
| 775 | (princ "hsort ") | |
| 776 | (princ "sort ")) | |
| 763 | (sort-is-hidden (car sm))) | |
| 764 | (princ "hsort ") | |
| 765 | (princ "sort ")) | |
| 777 | 766 | (print-chaos-object (car sm)) |
| 778 | 767 | (princ " -> ") |
| 779 | 768 | (print-chaos-object (cdr sm))) |
| 780 | 769 | (dolist (pm op-maps) |
| 781 | 770 | (if flg (print-next) (setq flg t)) |
| 782 | 771 | (if (method-is-behavioural (term-head (car pm))) |
| 783 | (princ "bop ") | |
| 784 | (princ "op ")) | |
| 772 | (princ "bop ") | |
| 773 | (princ "op ")) | |
| 785 | 774 | (princ "(")(print-chaos-object (term-head (car pm)))(princ ")") |
| 786 | 775 | (princ " -> ") |
| 787 | 776 | (princ "(")(print-chaos-object (term-head (cadr pm)))(princ ")") |
| 791 | 780 | (declare (ignore simple no-param)) |
| 792 | 781 | (unless map (return-from print-abs-view-mapping nil)) |
| 793 | 782 | (let ((rmap (if (%is-rmap map) |
| 794 | (%rmap-map map) | |
| 795 | map))) | |
| 783 | (%rmap-map map) | |
| 784 | map))) | |
| 796 | 785 | (let ((smaps (assq '%ren-sort rmap)) |
| 797 | (opmaps (assq '%ren-op rmap)) | |
| 798 | (vars (assq '%vars rmap)) | |
| 799 | (p-flg nil)) | |
| 786 | (opmaps (assq '%ren-op rmap)) | |
| 787 | (vars (assq '%vars rmap)) | |
| 788 | (p-flg nil)) | |
| 800 | 789 | (when vars (print-vars-ast vars stream pretty) (setq p-flg t)) |
| 801 | 790 | (when smaps |
| 802 | (when p-flg (princ "," stream)) | |
| 803 | (print-ren-sort smaps stream pretty) (setq p-flg t)) | |
| 791 | (when p-flg (princ "," stream)) | |
| 792 | (print-ren-sort smaps stream pretty) (setq p-flg t)) | |
| 804 | 793 | (when opmaps |
| 805 | (when p-flg (princ "," stream)) | |
| 806 | (print-ren-op opmaps stream pretty))))) | |
| 794 | (when p-flg (princ "," stream)) | |
| 795 | (print-ren-op opmaps stream pretty))))) | |
| 807 | 796 | |
| 808 | 797 | (defun print-view-modexp (me &optional (stream *standard-output*) simple no-param) |
| 809 | 798 | ;; (print-modexp (%view-target me) stream simple no-param) |
| 810 | 799 | (when (%view-map me) |
| 811 | 800 | (if simple |
| 812 | (princ "{ ... }" stream) | |
| 813 | (let ((*standard-output* stream)) | |
| 814 | (print-check) | |
| 815 | (princ "view") | |
| 816 | (print-check) | |
| 817 | (unless (eq 'none (%view-module me)) | |
| 818 | (princ " from ") | |
| 819 | (print-modexp (%view-module me) stream simple no-param)) | |
| 820 | (princ " to ") (print-modexp (%view-target me) stream simple no-param) | |
| 821 | (print-check) | |
| 822 | (princ " {") | |
| 823 | (let ((*print-indent* (+ 2 *print-indent*))) | |
| 824 | (print-view-mapping (%view-map me) stream simple no-param)) | |
| 825 | (print-next) | |
| 826 | (princ " }"))))) | |
| 801 | (princ "{ ... }" stream) | |
| 802 | (let ((*standard-output* stream)) | |
| 803 | (print-check) | |
| 804 | (princ "view") | |
| 805 | (print-check) | |
| 806 | (unless (eq 'none (%view-module me)) | |
| 807 | (princ " from ") | |
| 808 | (print-modexp (%view-module me) stream simple no-param)) | |
| 809 | (princ " to ") (print-modexp (%view-target me) stream simple no-param) | |
| 810 | (print-check) | |
| 811 | (princ " {") | |
| 812 | (let ((*print-indent* (+ 2 *print-indent*))) | |
| 813 | (print-view-mapping (%view-map me) stream simple no-param)) | |
| 814 | (print-next) | |
| 815 | (princ " }"))))) | |
| 827 | 816 | |
| 828 | 817 | (defun print-view-modexp-abbrev (me &optional |
| 829 | (stream *standard-output*) simple no-param) | |
| 818 | (stream *standard-output*) simple no-param) | |
| 830 | 819 | (let ((target (if (view-p me) |
| 831 | (view-target me) | |
| 832 | (if (modexp-is-view me) | |
| 833 | (%view-target me))))) | |
| 820 | (view-target me) | |
| 821 | (if (modexp-is-view me) | |
| 822 | (%view-target me))))) | |
| 834 | 823 | (if target |
| 835 | (print-modexp target stream simple no-param) | |
| 836 | (if (stringp me) | |
| 837 | (princ me) | |
| 838 | (with-output-panic-message () | |
| 839 | (format t "print-view, given invalid view : ") | |
| 840 | (prin1 me)))) | |
| 841 | ;; (chaos-error 'invalid-view)))) | |
| 824 | (print-modexp target stream simple no-param) | |
| 825 | (if (stringp me) | |
| 826 | (princ me) | |
| 827 | (with-output-panic-message () | |
| 828 | (format t "print-view, given invalid view : ") | |
| 829 | (prin1 me)))) | |
| 830 | ;; (chaos-error 'invalid-view)))) | |
| 842 | 831 | (when (stringp me) |
| 843 | (return-from print-view-modexp-abbrev nil)) | |
| 832 | (return-from print-view-modexp-abbrev nil)) | |
| 844 | 833 | (when (and (not (view-p me)) (%view-map me)) |
| 845 | (if simple | |
| 846 | (princ "{ ... }" stream) | |
| 847 | (let ((*standard-output* stream)) | |
| 848 | (print-check) | |
| 849 | (princ "{") | |
| 850 | (print-check) | |
| 851 | (print-view-mapping (%view-map me) stream) | |
| 852 | (print-check) | |
| 853 | (princ " }")) | |
| 854 | )))) | |
| 834 | (if simple | |
| 835 | (princ "{ ... }" stream) | |
| 836 | (let ((*standard-output* stream)) | |
| 837 | (print-check) | |
| 838 | (princ "{") | |
| 839 | (print-check) | |
| 840 | (print-view-mapping (%view-map me) stream) | |
| 841 | (print-check) | |
| 842 | (princ " }")) | |
| 843 | )))) | |
| 855 | 844 | |
| 856 | 845 | (defun print-view-mapping (vwmap &optional |
| 857 | (stream *standard-output*) simple no-param | |
| 858 | pretty) | |
| 846 | (stream *standard-output*) simple no-param | |
| 847 | pretty) | |
| 859 | 848 | (unless vwmap (return-from print-view-mapping nil)) |
| 860 | 849 | (print-rename-map vwmap stream simple no-param pretty)) |
| 861 | 850 | |
| 867 | 856 | |
| 868 | 857 | (defun print-operator-internal (op &optional (stream *standard-output*)) |
| 869 | 858 | (format stream "~a/~a." |
| 870 | (operator-symbol op) | |
| 871 | (operator-num-args op)) | |
| 859 | (operator-symbol op) | |
| 860 | (operator-num-args op)) | |
| 872 | 861 | (print-mod-name (operator-module op) stream)) |
| 873 | ||
| 862 | ||
| 874 | 863 | (defun print-op-name (op) |
| 875 | 864 | (format t "~a/~a" (operator-symbol op) (operator-num-args op))) |
| 876 | 865 | |
| 878 | 867 | |
| 879 | 868 | (defun print-sort-internal (sort &optional (stream *standard-output*) ignore) |
| 880 | 869 | (declare (ignore ignore)) |
| 881 | (print-sort-name sort (or *current-module* *last-module*) stream)) | |
| 870 | (print-sort-name sort (get-object-context sort) stream)) | |
| 882 | 871 | |
| 883 | 872 | (defun print-record-internal (sort &optional (stream *standard-output*) ignore) |
| 884 | 873 | (declare (ignore ignore)) |
| 885 | (print-sort-name sort (or *current-module* *last-module*) stream)) | |
| 874 | (print-sort-name sort (get-object-context sort) stream)) | |
| 886 | 875 | |
| 887 | 876 | (defun print-class-internal (sort &optional (stream *standard-output*) ignore) |
| 888 | 877 | (declare (ignore ignore)) |
| 889 | (print-sort-name sort (or *current-module* *last-module*) stream)) | |
| 878 | (print-sort-name sort (get-object-context sort) stream)) | |
| 890 | 879 | |
| 891 | 880 | (defun print-bsort-internal (sort &optional (stream *standard-output*) ignore) |
| 892 | 881 | (declare (ignore ignore)) |
| 893 | (print-sort-name sort (or *current-module* *last-module*) stream)) | |
| 882 | (print-sort-name sort (get-object-context sort) stream)) | |
| 894 | 883 | |
| 895 | 884 | (defun print-and-sort-internal (sort &optional (stream *standard-output*) ignore) |
| 896 | 885 | (declare (ignore ignore)) |
| 897 | (print-sort-name sort (or *current-module* *last-module*) stream)) | |
| 886 | (print-sort-name sort (get-object-context sort) stream)) | |
| 898 | 887 | |
| 899 | 888 | (defun print-or-sort-internal (sort &optional (stream *standard-output*) ignore) |
| 900 | 889 | (declare (ignore ignore)) |
| 901 | (print-sort-name sort (or *current-module* *last-module*) stream)) | |
| 890 | (print-sort-name sort (get-object-context sort) stream)) | |
| 902 | 891 | |
| 903 | 892 | (defun print-err-sort-internal (sort &optional (stream *standard-output*) ignore) |
| 904 | 893 | (declare (ignore ignore)) |
| 905 | (print-sort-name sort (or *current-module* *last-module*) stream)) | |
| 894 | (print-sort-name sort (get-object-context sort) stream)) | |
| 906 | 895 | |
| 907 | 896 | ;;; MODULE ************ |
| 908 | ||
| 909 | ;;; (defun print-module-internal (module &optional (stream *standard-output*)) | |
| 910 | ;;; (print-mod-name module stream t t)) | |
| 911 | 897 | |
| 912 | 898 | (defun print-module-internal (module &optional (stream *standard-output*) ignore) |
| 913 | 899 | (declare (ignore ignore)) |
| 923 | 909 | (defun print-rule-internal (rule &optional (stream *standard-output*) ignore) |
| 924 | 910 | (declare (ignore ignore)) |
| 925 | 911 | (let ((cnd (not (term-is-similar? *BOOL-true* (rule-condition rule)))) |
| 926 | (.printed-vars-so-far. nil)) | |
| 912 | (.printed-vars-so-far. nil)) | |
| 927 | 913 | (when (rule-labels rule) |
| 928 | 914 | (print-rule-labels rule) |
| 929 | 915 | (princ " ")) |
| 930 | 916 | (let ((.file-col. (file-column stream))) |
| 931 | 917 | ;; LHS |
| 932 | 918 | (setq .printed-vars-so-far. |
| 933 | (term-print (rule-lhs rule) stream)) | |
| 919 | (term-print (rule-lhs rule) stream)) | |
| 934 | 920 | (setq .file-col. (file-column stream)) |
| 935 | 921 | (print-check 0 .file-col.) |
| 936 | 922 | (princ " --> ") |
| 939 | 925 | (term-print (rule-rhs rule) stream) |
| 940 | 926 | ;; CONDITION |
| 941 | 927 | (when (or cnd (rule-id-condition rule)) |
| 942 | (setq .file-col. (file-column stream)) | |
| 943 | (print-check 0 .file-col.) | |
| 944 | (princ " if ") | |
| 945 | (setq .file-col. (+ 4 .file-col.)) | |
| 946 | (when cnd | |
| 947 | (term-print (rule-condition rule) stream)) | |
| 948 | (when (and cnd (rule-id-condition rule)) | |
| 949 | (print-check) | |
| 950 | (princ " and ") | |
| 951 | (print-check)) | |
| 952 | (when (rule-id-condition rule) | |
| 953 | (print-id-condition (rule-id-condition rule) stream))) | |
| 954 | ))) | |
| 928 | (setq .file-col. (file-column stream)) | |
| 929 | (print-check 0 .file-col.) | |
| 930 | (princ " if ") | |
| 931 | (setq .file-col. (+ 4 .file-col.)) | |
| 932 | (when cnd | |
| 933 | (term-print (rule-condition rule) stream)) | |
| 934 | (when (and cnd (rule-id-condition rule)) | |
| 935 | (print-check) | |
| 936 | (princ " and ") | |
| 937 | (print-check)) | |
| 938 | (when (rule-id-condition rule) | |
| 939 | (print-id-condition (rule-id-condition rule) stream))) | |
| 940 | ))) | |
| 955 | 941 | |
| 956 | 942 | ;;; METHOD ************ |
| 957 | 943 | |
| 958 | 944 | (defun print-method-internal (meth &optional (stream *standard-output*) ignore) |
| 959 | 945 | (declare (ignore ignore)) |
| 960 | (let ((mod (or *current-module* *last-module*)) | |
| 961 | (.file-col. .file-col.)) | |
| 946 | (let ((mod (get-object-context meth)) | |
| 947 | (.file-col. .file-col.)) | |
| 962 | 948 | (format stream "~{~A~} :" (method-symbol meth)) |
| 963 | 949 | (setq .file-col. (file-column stream)) |
| 964 | 950 | (mapc #'(lambda (x) |
| 965 | (princ " " stream) | |
| 966 | (print-sort-name x mod stream) | |
| 967 | (print-check .file-col. 0 stream)) | |
| 968 | (method-arity meth)) | |
| 951 | (princ " " stream) | |
| 952 | (print-sort-name x mod stream) | |
| 953 | (print-check .file-col. 0 stream)) | |
| 954 | (method-arity meth)) | |
| 969 | 955 | (print-check .file-col. 4 stream) |
| 970 | 956 | (princ " -> ") |
| 971 | 957 | (print-check .file-col. 0 stream) |
| 978 | 964 | ;;;----------------------------------------------------------------------------- |
| 979 | 965 | |
| 980 | 966 | (defun print-modmorph (mppg) |
| 981 | (format t "~&Module morphism:") | |
| 967 | (format t "~%Module morphism:") | |
| 982 | 968 | (format t "~& name: ") (print-chaos-object (modmorph-name mppg)) |
| 983 | 969 | (format t "~& sort: ") |
| 984 | 970 | (dolist (i (modmorph-sort mppg)) |
| 1005 | 991 | (unless (module-p module) (break "internal error, get-module-print-name")) |
| 1006 | 992 | (let ((name (module-name module))) |
| 1007 | 993 | (if (modexp-is-simple-name name) |
| 1008 | name | |
| 1009 | (or (module-decl-form module) name)))) | |
| 994 | name | |
| 995 | (or (module-decl-form module) name)))) | |
| 1010 | 996 | |
| 1011 | 997 | (defun make-module-print-name (mod &optional (abbrev t)) |
| 1012 | 998 | (with-output-to-string (name-string) |
| 1014 | 1000 | name-string)) |
| 1015 | 1001 | |
| 1016 | 1002 | (defun print-mod-name (arg &optional |
| 1017 | (stream *standard-output*) | |
| 1018 | (abbrev nil) | |
| 1019 | (no-param nil)) | |
| 1003 | (stream *standard-output*) | |
| 1004 | (abbrev nil) | |
| 1005 | (no-param nil)) | |
| 1020 | 1006 | (declare (values t)) |
| 1021 | 1007 | (let ((*standard-output* stream)) |
| 1022 | 1008 | (if (module-p arg) |
| 1023 | (let ((modname (get-module-print-name arg))) | |
| 1024 | (if (is-dummy-module arg) | |
| 1025 | (let ((info (getf (module-infos arg) 'rename-mod))) | |
| 1026 | (print-mod-name (car info) stream abbrev no-param) | |
| 1027 | (princ "*DUMMY")) | |
| 1028 | (print-mod-name-internal modname abbrev t)) | |
| 1029 | (let ((params (get-module-parameters arg))) | |
| 1030 | (when (and params (not no-param)) | |
| 1031 | (let ((flg nil)) | |
| 1032 | ;; (princ "[") | |
| 1033 | (princ "(") | |
| 1034 | (dolist (param params) | |
| 1035 | (let ((theory (get-parameter-theory | |
| 1036 | (parameter-theory-module param)))) | |
| 1037 | (declare (ignore theory)) | |
| 1038 | (if flg (princ ", ")) | |
| 1039 | (if (or (null (parameter-context param)) | |
| 1040 | (eq arg (parameter-context param))) | |
| 1041 | (princ (parameter-arg-name param)) | |
| 1042 | (progn | |
| 1043 | ;; (format t "~a@" (parameter-arg-name param)) | |
| 1044 | (format t "~a." (parameter-arg-name param)) | |
| 1045 | (print-mod-name (parameter-context param) | |
| 1046 | stream | |
| 1047 | abbrev | |
| 1048 | t))) | |
| 1049 | ;; patch-begin | |
| 1050 | ;; (princ "::") | |
| 1051 | ;; (print-mod-name theory stream abbrev t) | |
| 1052 | ;; patch-end | |
| 1053 | (setq flg t))) | |
| 1054 | ;; (princ "]") | |
| 1055 | (princ ")") | |
| 1056 | )))) | |
| 1057 | (print-chaos-object arg) | |
| 1058 | ))) | |
| 1009 | (let ((modname (get-module-print-name arg))) | |
| 1010 | (if (is-dummy-module arg) | |
| 1011 | (let ((info (getf (module-infos arg) 'rename-mod))) | |
| 1012 | (print-mod-name (car info) stream abbrev no-param) | |
| 1013 | (princ "*DUMMY")) | |
| 1014 | (print-mod-name-internal modname abbrev t)) | |
| 1015 | (let ((params (get-module-parameters arg))) | |
| 1016 | (when (and params (not no-param)) | |
| 1017 | (let ((flg nil)) | |
| 1018 | ;; (princ "[") | |
| 1019 | (princ "(") | |
| 1020 | (dolist (param params) | |
| 1021 | (let ((theory (get-parameter-theory | |
| 1022 | (parameter-theory-module param)))) | |
| 1023 | (declare (ignore theory)) | |
| 1024 | (if flg (princ ", ")) | |
| 1025 | (if (or (null (parameter-context param)) | |
| 1026 | (eq arg (parameter-context param))) | |
| 1027 | (princ (parameter-arg-name param)) | |
| 1028 | (progn | |
| 1029 | ;; (format t "~a@" (parameter-arg-name param)) | |
| 1030 | (format t "~a." (parameter-arg-name param)) | |
| 1031 | (print-mod-name (parameter-context param) | |
| 1032 | stream | |
| 1033 | abbrev | |
| 1034 | t))) | |
| 1035 | ;; patch-begin | |
| 1036 | ;; (princ "::") | |
| 1037 | ;; (print-mod-name theory stream abbrev t) | |
| 1038 | ;; patch-end | |
| 1039 | (setq flg t))) | |
| 1040 | ;; (princ "]") | |
| 1041 | (princ ")") | |
| 1042 | )))) | |
| 1043 | (print-chaos-object arg) | |
| 1044 | ))) | |
| 1059 | 1045 | |
| 1060 | 1046 | (defun print-mod-name-internal (val abbrev |
| 1061 | &optional | |
| 1062 | (no-param nil)) | |
| 1047 | &optional | |
| 1048 | (no-param nil)) | |
| 1063 | 1049 | (declare (values t)) |
| 1064 | 1050 | (if (stringp val) |
| 1065 | 1051 | (princ val) |
| 1066 | 1052 | (if (and (consp val) (not (chaos-ast? val))) |
| 1067 | (if (modexp-is-parameter-theory val) | |
| 1068 | ;; (equal "::" (cadr val)) | |
| 1069 | ;; parameter theory | |
| 1070 | (if abbrev | |
| 1071 | (progn | |
| 1072 | (format t "~a" (car val)) | |
| 1073 | (princ ".") | |
| 1074 | (print-mod-name (car (last val)) | |
| 1075 | *standard-output* | |
| 1076 | abbrev | |
| 1077 | no-param) | |
| 1078 | ) | |
| 1079 | ;; | |
| 1080 | (let ((cntxt (fourth val))) | |
| 1081 | (if (and cntxt | |
| 1082 | (not (eq *current-module* cntxt))) | |
| 1083 | (progn (format t "~a." (car val)) | |
| 1084 | (print-mod-name cntxt *standard-output* t t) | |
| 1085 | (princ " :: ")) | |
| 1086 | (format t "~a :: " (car val))) | |
| 1087 | (print-mod-name (caddr val) *standard-output* nil t))) | |
| 1088 | (print-chaos-object val)) | |
| 1089 | (print-modexp val *standard-output* abbrev no-param)))) | |
| 1053 | (if (modexp-is-parameter-theory val) | |
| 1054 | ;; (equal "::" (cadr val)) | |
| 1055 | ;; parameter theory | |
| 1056 | (if abbrev | |
| 1057 | (progn | |
| 1058 | (format t "~a" (car val)) | |
| 1059 | (princ ".") | |
| 1060 | (print-mod-name (car (last val)) | |
| 1061 | *standard-output* | |
| 1062 | abbrev | |
| 1063 | no-param) | |
| 1064 | ) | |
| 1065 | ;; | |
| 1066 | (let ((cntxt (fourth val))) | |
| 1067 | (if (and cntxt | |
| 1068 | (not (eq *current-module* cntxt))) | |
| 1069 | (progn (format t "~a." (car val)) | |
| 1070 | (print-mod-name cntxt *standard-output* t t) | |
| 1071 | (princ " :: ")) | |
| 1072 | (format t "~a :: " (car val))) | |
| 1073 | (print-mod-name (caddr val) *standard-output* nil t))) | |
| 1074 | (print-chaos-object val)) | |
| 1075 | (print-modexp val *standard-output* abbrev no-param)))) | |
| 1090 | 1076 | |
| 1091 | 1077 | (defun print-simple-mod-name (module &optional (stream *standard-output*)) |
| 1092 | 1078 | (if (and *open-module* |
| 1093 | (equal "%" (get-module-print-name module))) | |
| 1079 | (equal "%" (get-module-print-name module))) | |
| 1094 | 1080 | (progn |
| 1095 | (princ "%" stream) | |
| 1096 | (print-mod-name *open-module* stream t nil)) | |
| 1081 | (princ "%" stream) | |
| 1082 | (print-mod-name *open-module* stream t nil)) | |
| 1097 | 1083 | (print-mod-name module stream t nil))) |
| 1098 | 1084 | |
| 1099 | 1085 | (defun make-module-print-name2 (mod) |
| 1102 | 1088 | name-string)) |
| 1103 | 1089 | |
| 1104 | 1090 | (defun print-mod-name2 (arg &optional |
| 1105 | (stream *standard-output*) | |
| 1106 | (no-param nil)) | |
| 1091 | (stream *standard-output*) | |
| 1092 | (no-param nil)) | |
| 1107 | 1093 | (let ((*standard-output* stream)) |
| 1108 | 1094 | (if (module-p arg) |
| 1109 | (let ((modname (get-module-print-name arg))) | |
| 1110 | (if (is-dummy-module arg) | |
| 1111 | (let ((info (getf (module-infos arg) 'rename-mod))) | |
| 1112 | (print-mod-name2 (car info) stream no-param) | |
| 1113 | (princ "*DUMMY")) | |
| 1114 | (print-mod-name-internal2 modname no-param)) | |
| 1115 | (let ((params (get-module-parameters arg))) | |
| 1116 | (when (and params (not no-param)) | |
| 1117 | (let ((flg nil)) | |
| 1118 | (princ "(") | |
| 1119 | (dolist (param params) | |
| 1120 | (let ((real-theory (parameter-theory-module param))) | |
| 1121 | (declare (ignore real-theory)) ; *** | |
| 1122 | (if flg (princ ", ")) | |
| 1123 | (if (eq arg (parameter-context param)) | |
| 1124 | (princ (parameter-arg-name param)) | |
| 1125 | (progn | |
| 1126 | (format t "~a." (parameter-arg-name param)) | |
| 1127 | (print-mod-name2 (parameter-context param) | |
| 1128 | stream | |
| 1129 | t))) | |
| 1130 | (setq flg t))) | |
| 1131 | (princ ")") | |
| 1132 | )))) | |
| 1133 | ;; unknown object ... | |
| 1134 | (print-chaos-object arg) | |
| 1135 | ))) | |
| 1095 | (let ((modname (get-module-print-name arg))) | |
| 1096 | (if (is-dummy-module arg) | |
| 1097 | (let ((info (getf (module-infos arg) 'rename-mod))) | |
| 1098 | (print-mod-name2 (car info) stream no-param) | |
| 1099 | (princ "*DUMMY")) | |
| 1100 | (print-mod-name-internal2 modname no-param)) | |
| 1101 | (let ((params (get-module-parameters arg))) | |
| 1102 | (when (and params (not no-param)) | |
| 1103 | (let ((flg nil)) | |
| 1104 | (princ "(") | |
| 1105 | (dolist (param params) | |
| 1106 | (let ((real-theory (parameter-theory-module param))) | |
| 1107 | (declare (ignore real-theory)) ; *** | |
| 1108 | (if flg (princ ", ")) | |
| 1109 | (if (eq arg (parameter-context param)) | |
| 1110 | (princ (parameter-arg-name param)) | |
| 1111 | (progn | |
| 1112 | (format t "~a." (parameter-arg-name param)) | |
| 1113 | (print-mod-name2 (parameter-context param) | |
| 1114 | stream | |
| 1115 | t))) | |
| 1116 | (setq flg t))) | |
| 1117 | (princ ")") | |
| 1118 | )))) | |
| 1119 | ;; unknown object ... | |
| 1120 | (print-chaos-object arg) | |
| 1121 | ))) | |
| 1136 | 1122 | |
| 1137 | 1123 | (defun print-mod-name-internal2 (val &optional (no-param nil)) |
| 1138 | 1124 | (if (stringp val) |
| 1139 | 1125 | (princ val) |
| 1140 | 1126 | (if (and (consp val) (not (chaos-ast? val))) |
| 1141 | (if (equal "::" (cadr val)) | |
| 1142 | ;; parameter theory | |
| 1143 | (progn | |
| 1144 | (format t "~a." (car val)) | |
| 1145 | (print-mod-name2 (car (last val)) | |
| 1146 | *standard-output* | |
| 1147 | no-param)) | |
| 1148 | (print-chaos-object val)) | |
| 1149 | (print-modexp val *standard-output* nil no-param)))) | |
| 1127 | (if (equal "::" (cadr val)) | |
| 1128 | ;; parameter theory | |
| 1129 | (progn | |
| 1130 | (format t "~a." (car val)) | |
| 1131 | (print-mod-name2 (car (last val)) | |
| 1132 | *standard-output* | |
| 1133 | no-param)) | |
| 1134 | (print-chaos-object val)) | |
| 1135 | (print-modexp val *standard-output* nil no-param)))) | |
| 1150 | 1136 | |
| 1151 | 1137 | (defun get-parameter-theory (mod) |
| 1152 | 1138 | (cond ((module-p mod) |
| 1153 | (let ((mod-name (module-name mod))) | |
| 1154 | (cond ((%is-rename mod-name) | |
| 1155 | `(%* ,(get-parameter-theory (%rename-module mod-name)) | |
| 1156 | ,(%rename-map mod-name))) | |
| 1157 | ((int-rename-p mod-name) | |
| 1158 | (make-int-rename :module | |
| 1159 | (get-parameter-theory | |
| 1160 | (int-rename-module mod-name)) | |
| 1161 | :sort-maps | |
| 1162 | (int-rename-sort-maps mod-name) | |
| 1163 | :op-maps | |
| 1164 | (int-rename-op-maps mod-name))) | |
| 1165 | ((%is-instantiation mod-name) | |
| 1166 | `(%! ,(get-parameter-theory (%instantiation-module mod-name)) | |
| 1167 | ,(%instantiation-args mod-name))) | |
| 1168 | ((int-instantiation-p mod-name) | |
| 1169 | (make-int-instantiation :module | |
| 1170 | (get-parameter-theory mod-name) | |
| 1171 | :args | |
| 1172 | (int-instantiation-args mod-name))) | |
| 1173 | ((module-is-parameter-theory mod) | |
| 1174 | (caddr (module-name mod))) | |
| 1175 | (t (with-output-panic-message () | |
| 1176 | (princ "getting parameter theory, given invalid module.") | |
| 1177 | (print-mod-name mod)))))) | |
| 1178 | ((modexp-is-parameter-theory mod) | |
| 1179 | (caddr mod)) | |
| 1180 | (t (with-output-panic-message () | |
| 1181 | (princ "getting parameter theory, given invalid modexp: ") | |
| 1182 | (print-modexp mod))))) | |
| 1139 | (let ((mod-name (module-name mod))) | |
| 1140 | (cond ((%is-rename mod-name) | |
| 1141 | `(%* ,(get-parameter-theory (%rename-module mod-name)) | |
| 1142 | ,(%rename-map mod-name))) | |
| 1143 | ((int-rename-p mod-name) | |
| 1144 | (make-int-rename :module | |
| 1145 | (get-parameter-theory | |
| 1146 | (int-rename-module mod-name)) | |
| 1147 | :sort-maps | |
| 1148 | (int-rename-sort-maps mod-name) | |
| 1149 | :op-maps | |
| 1150 | (int-rename-op-maps mod-name))) | |
| 1151 | ((%is-instantiation mod-name) | |
| 1152 | `(%! ,(get-parameter-theory (%instantiation-module mod-name)) | |
| 1153 | ,(%instantiation-args mod-name))) | |
| 1154 | ((int-instantiation-p mod-name) | |
| 1155 | (make-int-instantiation :module | |
| 1156 | (get-parameter-theory mod-name) | |
| 1157 | :args | |
| 1158 | (int-instantiation-args mod-name))) | |
| 1159 | ((module-is-parameter-theory mod) | |
| 1160 | (caddr (module-name mod))) | |
| 1161 | (t (with-output-panic-message () | |
| 1162 | (princ "getting parameter theory, given invalid module.") | |
| 1163 | (print-mod-name mod)))))) | |
| 1164 | ((modexp-is-parameter-theory mod) | |
| 1165 | (caddr mod)) | |
| 1166 | (t (with-output-panic-message () | |
| 1167 | (princ "getting parameter theory, given invalid modexp: ") | |
| 1168 | (print-modexp mod))))) | |
| 1183 | 1169 | |
| 1184 | 1170 | (defun print-parameter-theory-name (mod &optional (stream *standard-output*) |
| 1185 | (abbrev t) | |
| 1186 | (no-param t)) | |
| 1171 | (abbrev t) | |
| 1172 | (no-param t)) | |
| 1187 | 1173 | (let ((theory (get-parameter-theory mod))) |
| 1188 | 1174 | (cond ((module-p theory) |
| 1189 | (print-mod-name theory stream abbrev no-param)) | |
| 1190 | (t (print-modexp theory stream abbrev no-param))))) | |
| 1175 | (print-mod-name theory stream abbrev no-param)) | |
| 1176 | (t (print-modexp theory stream abbrev no-param))))) | |
| 1191 | 1177 | |
| 1192 | 1178 | ;;;----------------------------------------------------------------------------- |
| 1193 | 1179 | ;;; SORT |
| 1195 | 1181 | |
| 1196 | 1182 | ;;; PRINT-SORT-NAME : sort &optional module stream -> Void |
| 1197 | 1183 | ;;; |
| 1198 | (defun print-sort-name (s &optional | |
| 1199 | (module (or *current-module* *last-module*)) | |
| 1200 | (stream *standard-output*)) | |
| 1184 | (defun print-sort-name (s &optional (module (get-object-context s)) | |
| 1185 | (stream *standard-output*)) | |
| 1201 | 1186 | (unless (sort-struct-p s) (break "print-sort-name: given non sort: ~s" s)) |
| 1202 | 1187 | (let ((*standard-output* stream) |
| 1203 | (mod-name (get-module-print-name (sort-module s)))) | |
| 1188 | (mod-name (get-module-print-name (sort-module s)))) | |
| 1204 | 1189 | (cond ((and module |
| 1205 | (sort-name-is-ambiguous (sort-id s) module)) | |
| 1206 | (if (modexp-is-parameter-theory mod-name) | |
| 1207 | (let ((cntxt (fourth mod-name))) | |
| 1208 | (format t "~a.~a" (string (sort-id s)) (car mod-name)) | |
| 1209 | (when (and cntxt (not (eq module cntxt))) | |
| 1210 | (princ ".") | |
| 1211 | (print-mod-name cntxt stream t t))) | |
| 1212 | (progn | |
| 1213 | (format t "~a." (string (sort-id s))) | |
| 1214 | ;; (print-simple-mod-name (sort-module s)) | |
| 1215 | (print-mod-name (sort-module s) stream t t)))) | |
| 1216 | (t (format t "~a" (string (sort-id s))))))) | |
| 1190 | (sort-name-is-ambiguous (sort-id s) module)) | |
| 1191 | (if (modexp-is-parameter-theory mod-name) | |
| 1192 | (let ((cntxt (fourth mod-name))) | |
| 1193 | (format t "~a.~a" (string (sort-id s)) (car mod-name)) | |
| 1194 | (when (and cntxt (not (eq module cntxt))) | |
| 1195 | (princ ".") | |
| 1196 | (print-mod-name cntxt stream t t))) | |
| 1197 | (progn | |
| 1198 | (format t "~a." (string (sort-id s))) | |
| 1199 | ;; (print-simple-mod-name (sort-module s)) | |
| 1200 | (print-mod-name (sort-module s) stream t t)))) | |
| 1201 | (t (format t "~a" (string (sort-id s))))))) | |
| 1217 | 1202 | |
| 1218 | 1203 | (defun sort-print-name (sort &optional (with-mod-qualifier)) |
| 1219 | 1204 | (with-output-to-string (str) |
| 1220 | 1205 | (let ((*standard-output* str)) |
| 1221 | 1206 | (if with-mod-qualifier |
| 1222 | (progn | |
| 1223 | (format t "~a" (string (sort-id sort))) | |
| 1224 | (print-simple-mod-name (sort-module sort))) | |
| 1225 | (format t "~a" (string (sort-id sort)))) | |
| 1207 | (progn | |
| 1208 | (format t "~a" (string (sort-id sort))) | |
| 1209 | (print-simple-mod-name (sort-module sort))) | |
| 1210 | (format t "~a" (string (sort-id sort)))) | |
| 1226 | 1211 | str))) |
| 1227 | 1212 | |
| 1228 | 1213 | ;;; PRINT-SORT-LIST |
| 1229 | 1214 | ;;; |
| 1230 | 1215 | (defun print-sort-list (lst &optional |
| 1231 | (module *current-module*) | |
| 1232 | (stream *standard-output*)) | |
| 1216 | (module *current-module*) | |
| 1217 | (stream *standard-output*)) | |
| 1233 | 1218 | (let ((*standard-output* stream)) |
| 1234 | 1219 | (let ((flag nil)) |
| 1235 | 1220 | (dolist (s lst) |
| 1236 | (print-check) | |
| 1237 | (if flag (princ " ") (setq flag t)) | |
| 1238 | (print-sort-name s module))))) | |
| 1221 | (print-check) | |
| 1222 | (if flag (princ " ") (setq flag t)) | |
| 1223 | (print-sort-name s module))))) | |
| 1239 | 1224 | |
| 1240 | 1225 | (defun print-sort-name2 (sort &optional (module *current-module*) |
| 1241 | (stream *standard-output*)) | |
| 1226 | (stream *standard-output*)) | |
| 1242 | 1227 | (let ((*standard-output* stream) |
| 1243 | (*current-sort-order* (module-sort-order module))) | |
| 1228 | (*current-sort-order* (module-sort-order module))) | |
| 1244 | 1229 | (let ((subs (subsorts sort)) |
| 1245 | (supers (supersorts-no-err sort))) | |
| 1230 | (supers (supersorts-no-err sort))) | |
| 1246 | 1231 | (when subs |
| 1247 | (print-sort-list subs) | |
| 1248 | (print-check) | |
| 1249 | (princ " < ")) | |
| 1232 | (print-sort-list subs) | |
| 1233 | (print-check) | |
| 1234 | (princ " < ")) | |
| 1250 | 1235 | (print-sort-name sort) |
| 1251 | 1236 | (when supers |
| 1252 | (print-check) | |
| 1253 | (princ " < ") | |
| 1254 | (print-sort-list supers) | |
| 1255 | )))) | |
| 1237 | (print-check) | |
| 1238 | (princ " < ") | |
| 1239 | (print-sort-list supers) | |
| 1240 | )))) | |
| 1256 | 1241 | |
| 1257 | 1242 | ;;; PRINT-QUAL-SORT-NAME |
| 1258 | 1243 | ;;; |
| 1259 | 1244 | (defun print-qual-sort-name (qs) |
| 1260 | 1245 | (if (and (consp qs) (eq 'qual (car qs))) |
| 1261 | 1246 | (let ((nm (cadr qs)) (mod (caddr qs))) |
| 1262 | (if (and (consp nm) (null (cdr nm))) | |
| 1263 | (print-simple-princ (car nm)) | |
| 1264 | (print-simple-princ nm)) | |
| 1265 | (princ ".") | |
| 1266 | (if (module-p mod) | |
| 1267 | (print-mod-name mod *standard-output* t t) | |
| 1268 | (print-modexp mod *standard-output* t t))) | |
| 1247 | (if (and (consp nm) (null (cdr nm))) | |
| 1248 | (print-simple-princ (car nm)) | |
| 1249 | (print-simple-princ nm)) | |
| 1250 | (princ ".") | |
| 1251 | (if (module-p mod) | |
| 1252 | (print-mod-name mod *standard-output* t t) | |
| 1253 | (print-modexp mod *standard-output* t t))) | |
| 1269 | 1254 | (print-simple-princ-open qs))) |
| 1270 | 1255 | |
| 1271 | 1256 | ;;;----------------------------------------------------------------------------- |
| 1275 | 1260 | (defun print-qual-op-name (qop) |
| 1276 | 1261 | (if (and (consp qop) (eq ':qual (car qop))) |
| 1277 | 1262 | (progn |
| 1278 | (print-simple-princ (cadr qop)) | |
| 1279 | (princ ".") | |
| 1280 | (print-qual-sort-name (caddr qop))) | |
| 1263 | (print-simple-princ (cadr qop)) | |
| 1264 | (princ ".") | |
| 1265 | (print-qual-sort-name (caddr qop))) | |
| 1281 | 1266 | (if (consp qop) |
| 1282 | 1267 | (let ((flag nil)) |
| 1283 | (dolist (x qop) | |
| 1284 | (if flag (princ " ") (setq flag t)) | |
| 1285 | (if (consp x) (print-qual-sort-name x) | |
| 1286 | (princ x)))) | |
| 1268 | (dolist (x qop) | |
| 1269 | (if flag (princ " ") (setq flag t)) | |
| 1270 | (if (consp x) (print-qual-sort-name x) | |
| 1271 | (princ x)))) | |
| 1287 | 1272 | (print-simple-princ-open qop)))) |
| 1288 | 1273 | |
| 1289 | 1274 | ;;; check if bu strategy: 1 2 3 .. n [ 0 ] |
| 1292 | 1277 | (defun print-check-bu (op l) |
| 1293 | 1278 | (let ((iota (make-list-1-n (operator-num-args op)))) |
| 1294 | 1279 | (or (equal l iota) |
| 1295 | (equal l (append iota '(0)))))) | |
| 1280 | (equal l (append iota '(0)))))) | |
| 1296 | 1281 | |
| 1297 | 1282 | (defun print-check-bu-meth (method l) |
| 1298 | 1283 | (let ((iota (make-list-1-n (length (method-arity method))))) |
| 1299 | 1284 | (or (equal l iota) |
| 1300 | (equal l (append iota '(0)))))) | |
| 1285 | (equal l (append iota '(0)))))) | |
| 1301 | 1286 | |
| 1302 | 1287 | (defun print-method-brief (meth) |
| 1303 | 1288 | (unless (method-p meth) |
| 1304 | 1289 | (format t "[print-method-brief]: Illegal method given ~a" meth) |
| 1305 | 1290 | (return-from print-method-brief nil)) |
| 1306 | 1291 | (let* ((*print-indent* (+ 4 *print-indent*)) |
| 1307 | (.file-col. *print-indent*) | |
| 1308 | (is-predicate (method-is-predicate meth))) | |
| 1292 | (.file-col. *print-indent*) | |
| 1293 | (is-predicate (method-is-predicate meth))) | |
| 1309 | 1294 | (if is-predicate |
| 1310 | (if (method-is-behavioural meth) | |
| 1311 | (princ "bpred ") | |
| 1312 | (princ "pred ")) | |
| 1295 | (if (method-is-behavioural meth) | |
| 1296 | (princ "bpred ") | |
| 1297 | (princ "pred ")) | |
| 1313 | 1298 | (if (method-is-behavioural meth) |
| 1314 | (princ "bop ") | |
| 1315 | (princ "op "))) | |
| 1299 | (princ "bop ") | |
| 1300 | (princ "op "))) | |
| 1316 | 1301 | (print-simple-princ-open (car (method-name meth))) |
| 1317 | 1302 | (princ " : ") |
| 1318 | 1303 | (setq .file-col. (1- (file-column *standard-output*))) |
| 1319 | 1304 | (when (method-arity meth) |
| 1320 | 1305 | (dolist (ar (method-arity meth)) |
| 1321 | (print-sort-name ar *current-module*) | |
| 1322 | (princ " ") | |
| 1323 | (print-check .file-col. 0))) | |
| 1306 | (print-sort-name ar *current-module*) | |
| 1307 | (princ " ") | |
| 1308 | (print-check .file-col. 0))) | |
| 1324 | 1309 | (unless is-predicate |
| 1325 | 1310 | (princ "-> ") |
| 1326 | 1311 | (print-sort-name (method-coarity meth) *current-module*)) |
| 1330 | 1315 | ;;; PRINT-OP-BRIEF operator |
| 1331 | 1316 | ;;; |
| 1332 | 1317 | (defun print-op-brief (op &optional (module *current-module*) |
| 1333 | (all t) | |
| 1334 | (every nil) | |
| 1335 | (show-context nil)) | |
| 1318 | (all t) | |
| 1319 | (every nil) | |
| 1320 | (show-context nil)) | |
| 1336 | 1321 | (let* ((*print-indent* *print-indent*) |
| 1337 | (opinfo (get-operator-info op (module-all-operators module))) | |
| 1338 | (methods (if all | |
| 1339 | (opinfo-methods opinfo) | |
| 1340 | (remove-if-not #'(lambda (x) | |
| 1341 | (eq (method-module x) | |
| 1342 | module)) | |
| 1343 | (opinfo-methods opinfo))))) | |
| 1322 | (opinfo (get-operator-info op (module-all-operators module))) | |
| 1323 | (methods (if all | |
| 1324 | (opinfo-methods opinfo) | |
| 1325 | (remove-if-not #'(lambda (x) | |
| 1326 | (eq (method-module x) | |
| 1327 | module)) | |
| 1328 | (opinfo-methods opinfo))))) | |
| 1344 | 1329 | (dolist (meth (reverse methods)) |
| 1345 | 1330 | (unless (and (not every) |
| 1346 | (null (method-arity meth)) | |
| 1347 | (sort= *sort-id-sort* (method-coarity meth))) | |
| 1348 | (when (or (not (method-is-error-method meth)) | |
| 1349 | (method-is-user-defined-error-method meth)) | |
| 1350 | (print-next) | |
| 1351 | (print-method-brief meth) | |
| 1352 | (when show-context | |
| 1353 | (let ((context-name (get-context-name-extended meth))) | |
| 1354 | (print-next) | |
| 1355 | (format t "-- declared in module ~a" context-name)))))))) | |
| 1331 | (null (method-arity meth)) | |
| 1332 | (sort= *sort-id-sort* (method-coarity meth))) | |
| 1333 | (when (or (not (method-is-error-method meth)) | |
| 1334 | (method-is-user-defined-error-method meth)) | |
| 1335 | (print-next) | |
| 1336 | (print-method-brief meth) | |
| 1337 | (when show-context | |
| 1338 | (let ((context-name (get-context-name-extended meth))) | |
| 1339 | (print-next) | |
| 1340 | (format t "-- declared in module ~a" context-name)))))))) | |
| 1356 | 1341 | |
| 1357 | 1342 | ;;; PRINT-OP-METH |
| 1358 | 1343 | ;;; |
| 1359 | 1344 | (defun print-op-meth (op-meth mod &optional (all t)) |
| 1360 | 1345 | (let ((op (car op-meth)) |
| 1361 | (methods (if all | |
| 1362 | (cadr op-meth) | |
| 1363 | (remove-if-not #'(lambda (x) | |
| 1364 | (eq (method-module x) mod)) | |
| 1365 | (cadr op-meth))))) | |
| 1346 | (methods (if all | |
| 1347 | (cadr op-meth) | |
| 1348 | (remove-if-not #'(lambda (x) | |
| 1349 | (eq (method-module x) mod)) | |
| 1350 | (cadr op-meth))))) | |
| 1366 | 1351 | (if (eq (operator-module op) mod) |
| 1367 | (print-op-brief op mod all) | |
| 1352 | (print-op-brief op mod all) | |
| 1368 | 1353 | (let ((*print-indent* *print-indent*)) |
| 1369 | (dolist (meth methods) | |
| 1370 | (unless (and (not all) | |
| 1371 | (null (method-arity meth)) | |
| 1372 | (sort= *sort-id-sort* | |
| 1373 | (method-coarity meth))) | |
| 1374 | (print-next) | |
| 1375 | (print-method-brief meth))))))) | |
| 1354 | (dolist (meth methods) | |
| 1355 | (unless (and (not all) | |
| 1356 | (null (method-arity meth)) | |
| 1357 | (sort= *sort-id-sort* | |
| 1358 | (method-coarity meth))) | |
| 1359 | (print-next) | |
| 1360 | (print-method-brief meth))))))) | |
| 1376 | 1361 | |
| 1377 | 1362 | (defun print-op-meth2 (op-meth mod &optional (all t)) |
| 1378 | 1363 | (with-in-module (mod) |
| 1379 | 1364 | (let ((op (car op-meth)) |
| 1380 | (methods (if all | |
| 1381 | (cadr op-meth) | |
| 1382 | (remove-if-not #'(lambda (x) | |
| 1383 | (eq (method-module x) mod)) | |
| 1384 | (cadr op-meth))))) | |
| 1365 | (methods (if all | |
| 1366 | (cadr op-meth) | |
| 1367 | (remove-if-not #'(lambda (x) | |
| 1368 | (eq (method-module x) mod)) | |
| 1369 | (cadr op-meth))))) | |
| 1385 | 1370 | (if (eq (operator-module op) mod) |
| 1386 | (print-op-brief op mod all) | |
| 1387 | (let ((ind *print-indent*)) | |
| 1388 | (dolist (meth methods) | |
| 1389 | (unless (and (null (method-arity meth)) | |
| 1390 | (sort= *sort-id-sort* | |
| 1391 | (method-coarity meth))) | |
| 1392 | (print-next) | |
| 1393 | (let ((*print-indent* (+ 4 ind))) | |
| 1394 | (print-simple-princ-open (operator-symbol op)) | |
| 1395 | (print-check) | |
| 1396 | (princ " : ") | |
| 1397 | (when (method-arity meth) | |
| 1398 | (print-sort-list (method-arity meth) mod) | |
| 1399 | (princ " ")) | |
| 1400 | (print-check) | |
| 1401 | (princ "-> ") | |
| 1402 | (print-sort-name (method-coarity meth) mod) | |
| 1403 | (print-check) | |
| 1404 | (print-method-attrs meth) | |
| 1405 | )))))))) | |
| 1371 | (print-op-brief op mod all) | |
| 1372 | (let ((ind *print-indent*)) | |
| 1373 | (dolist (meth methods) | |
| 1374 | (unless (and (null (method-arity meth)) | |
| 1375 | (sort= *sort-id-sort* | |
| 1376 | (method-coarity meth))) | |
| 1377 | (print-next) | |
| 1378 | (let ((*print-indent* (+ 4 ind))) | |
| 1379 | (print-simple-princ-open (operator-symbol op)) | |
| 1380 | (print-check) | |
| 1381 | (princ " : ") | |
| 1382 | (when (method-arity meth) | |
| 1383 | (print-sort-list (method-arity meth) mod) | |
| 1384 | (princ " ")) | |
| 1385 | (print-check) | |
| 1386 | (princ "-> ") | |
| 1387 | (print-sort-name (method-coarity meth) mod) | |
| 1388 | (print-check) | |
| 1389 | (print-method-attrs meth) | |
| 1390 | )))))))) | |
| 1406 | 1391 | |
| 1407 | 1392 | ;;; PRINT-TERM-METHOD : term module stream -> void |
| 1408 | 1393 | ;;; |
| 1409 | 1394 | (defun print-term-method (term &optional |
| 1410 | (module *current-module*) | |
| 1411 | (stream *standard-output*)) | |
| 1395 | (module *current-module*) | |
| 1396 | (stream *standard-output*)) | |
| 1412 | 1397 | (if (operator-method-p term) |
| 1413 | 1398 | (print-method term module stream) |
| 1414 | 1399 | (if (term-is-builtin-constant? term) |
| 1415 | (print-bi-constant-method term module stream) | |
| 1416 | (print-method (term-head term) module stream)))) | |
| 1400 | (print-bi-constant-method term module stream) | |
| 1401 | (print-method (term-head term) module stream)))) | |
| 1417 | 1402 | |
| 1418 | 1403 | ;;; PRINT-METHOD : method module stream -> void |
| 1419 | 1404 | ;;; |
| 1420 | 1405 | (defun print-method (method &optional |
| 1421 | (module *current-module*) | |
| 1422 | (stream *standard-output*)) | |
| 1406 | (module *current-module*) | |
| 1407 | (stream *standard-output*)) | |
| 1423 | 1408 | (format stream "~{~a~} : " (method-symbol method)) |
| 1424 | 1409 | (print-sort-list (method-arity method) module stream) |
| 1425 | 1410 | (princ " -> " stream) |
| 1435 | 1420 | ;;; PRINT-BI-CONSTANT-METHOD (term &optional module stream) |
| 1436 | 1421 | ;;; |
| 1437 | 1422 | (defun print-bi-constant-method (term &optional |
| 1438 | (module *current-module*) | |
| 1439 | (stream *standard-output*)) | |
| 1423 | (module *current-module*) | |
| 1424 | (stream *standard-output*)) | |
| 1440 | 1425 | (princ (term-builtin-value term) stream) |
| 1441 | 1426 | (princ " : -> ") |
| 1442 | 1427 | (print-sort-name (term-sort term) module stream)) |
| 1443 | ||
| 1428 | ||
| 1444 | 1429 | |
| 1445 | 1430 | ;;; BI-METHOD-PRINT-STRING (term &optional (module *current-module*)) |
| 1446 | 1431 | ;;; |
| 1456 | 1441 | ;; print "attributes" -- for the moment ignore purely syntactic |
| 1457 | 1442 | ;; -- i.e. precedence and associativity . |
| 1458 | 1443 | (let ((strat (let ((val (operator-strategy op))) |
| 1459 | (if (print-check-bu op val) nil val))) | |
| 1460 | (thy (operator-theory op)) | |
| 1461 | (prec (operator-precedence op))) | |
| 1444 | (if (print-check-bu op val) nil val))) | |
| 1445 | (thy (operator-theory op)) | |
| 1446 | (prec (operator-precedence op))) | |
| 1462 | 1447 | (when (and (eql (car (last strat)) 0) |
| 1463 | (member 0 (butlast strat))) | |
| 1448 | (member 0 (butlast strat))) | |
| 1464 | 1449 | (setq strat (butlast strat))) |
| 1465 | 1450 | (when (or strat prec (not (eq (theory-info thy) the-e-property))) |
| 1466 | 1451 | (let ((flag nil) |
| 1467 | (*print-indent* (1+ *print-indent*))) | |
| 1468 | (princ "attr ") | |
| 1469 | (print-simple-princ-open (operator-symbol op)) | |
| 1470 | (princ " { ") | |
| 1471 | (when (not (eq (theory-info thy) the-e-property)) | |
| 1472 | (setq flag t) | |
| 1473 | (print-theory-brief thy)) | |
| 1474 | (print-check) | |
| 1475 | (when strat | |
| 1476 | (if flag (princ " ") (setq flag t)) | |
| 1477 | (princ "strat: ") (print-simple strat)) | |
| 1478 | (print-check) | |
| 1479 | (when prec | |
| 1480 | (if flag (princ " ") (setq flag t)) | |
| 1481 | (princ "prec: ") (print-simple prec)) | |
| 1482 | ;; (print-check) | |
| 1483 | (princ " }"))))) | |
| 1452 | (*print-indent* (1+ *print-indent*))) | |
| 1453 | (princ "attr ") | |
| 1454 | (print-simple-princ-open (operator-symbol op)) | |
| 1455 | (princ " { ") | |
| 1456 | (when (not (eq (theory-info thy) the-e-property)) | |
| 1457 | (setq flag t) | |
| 1458 | (print-theory-brief thy)) | |
| 1459 | (print-check) | |
| 1460 | (when strat | |
| 1461 | (if flag (princ " ") (setq flag t)) | |
| 1462 | (princ "strat: ") (print-simple strat)) | |
| 1463 | (print-check) | |
| 1464 | (when prec | |
| 1465 | (if flag (princ " ") (setq flag t)) | |
| 1466 | (princ "prec: ") (print-simple prec)) | |
| 1467 | (princ " }"))))) | |
| 1484 | 1468 | |
| 1485 | 1469 | (defun print-method-attrs (method &optional header) |
| 1486 | 1470 | (let ((strat (let ((val (method-rewrite-strategy method))) |
| 1487 | (if (print-check-bu-meth method val) nil val))) | |
| 1488 | (constr (method-constructor method)) | |
| 1489 | (coherent (method-coherent method)) | |
| 1490 | (thy (method-theory method)) | |
| 1491 | (prec (or (method-precedence method) | |
| 1492 | (get-method-precedence method))) | |
| 1493 | (memo (method-has-memo method)) | |
| 1494 | (meta-demod (method-is-meta-demod method)) | |
| 1495 | (assoc (method-associativity method)) | |
| 1496 | (*print-line-limit* 100)) | |
| 1471 | (if (print-check-bu-meth method val) nil val))) | |
| 1472 | (constr (method-constructor method)) | |
| 1473 | (coherent (method-coherent method)) | |
| 1474 | (thy (method-theory method)) | |
| 1475 | (prec (or (method-precedence method) | |
| 1476 | (get-method-precedence method))) | |
| 1477 | (memo (method-has-memo method)) | |
| 1478 | (meta-demod (if *chaos-verbose* (method-is-meta-demod method) nil)) | |
| 1479 | (assoc (method-associativity method)) | |
| 1480 | (*print-line-limit* 100)) | |
| 1497 | 1481 | (when (and (eql 0 (car (last strat))) |
| 1498 | (member 0 (butlast strat))) | |
| 1482 | (member 0 (butlast strat))) | |
| 1499 | 1483 | (setq strat (butlast strat))) |
| 1500 | 1484 | (when (or constr coherent |
| 1501 | strat prec memo meta-demod assoc thy) | |
| 1485 | strat prec memo meta-demod assoc thy) | |
| 1502 | 1486 | (let ((flag nil) |
| 1503 | (outstr (make-array '(0) :element-type 'base-char | |
| 1504 | :fill-pointer 0 :adjustable t))) | |
| 1505 | (with-output-to-string (fs outstr) | |
| 1506 | (let ((*standard-output* fs)) | |
| 1507 | (when header (print-next) (princ header)) | |
| 1508 | ;; (print-check 0 3) | |
| 1509 | (princ " { ") | |
| 1510 | (setq .file-col. (1- (file-column *standard-output*))) | |
| 1511 | (when (and thy (not (eq (theory-info thy) the-e-property))) | |
| 1512 | (setq flag t) | |
| 1513 | (print-theory-brief thy) | |
| 1514 | (print-check .file-col. 7)) | |
| 1515 | (when constr | |
| 1516 | (if flag (princ " ") (setq flag t)) | |
| 1517 | (princ "constr") | |
| 1518 | (print-check .file-col. 7)) | |
| 1519 | (when coherent | |
| 1520 | (if flag (princ " ") (setq flag t)) | |
| 1521 | (princ "coherent") | |
| 1522 | (print-check .file-col. 7)) | |
| 1523 | (when strat | |
| 1524 | (if flag (princ " ") (setq flag t)) | |
| 1525 | (princ "strat: ") (print-simple strat) | |
| 1526 | (print-check .file-col. 7)) | |
| 1527 | (when memo | |
| 1528 | (if flag (princ " ") (setq flag t)) | |
| 1529 | (princ "memo") | |
| 1530 | (print-check .file-col. 7)) | |
| 1531 | (when meta-demod | |
| 1532 | (if flag (princ " ") (setq flag t)) | |
| 1533 | (princ "demod") | |
| 1534 | (print-check .file-col. 7)) | |
| 1535 | (when prec | |
| 1536 | (if flag (princ " ") (setq flag t)) | |
| 1537 | (princ "prec: ") (print-simple prec) | |
| 1538 | (print-check .file-col. 7)) | |
| 1539 | (when assoc | |
| 1540 | ;; (format t "!!~s" assoc) | |
| 1541 | (if flag (princ " ") (setq flag t)) | |
| 1542 | (if (eq :left assoc) | |
| 1543 | (princ "l-assoc") | |
| 1544 | (princ "r-assoc"))) | |
| 1545 | ;; (print-check .file-col.) | |
| 1546 | (princ " }"))) | |
| 1547 | (print-check 0 (length outstr)) | |
| 1548 | (princ outstr))))) | |
| 1487 | (outstr (make-array '(0) :element-type 'base-char | |
| 1488 | :fill-pointer 0 :adjustable t))) | |
| 1489 | (with-output-to-string (fs outstr) | |
| 1490 | (let ((*standard-output* fs)) | |
| 1491 | (when header (print-next) (princ header)) | |
| 1492 | (princ " { ") | |
| 1493 | (setq .file-col. (1- (file-column *standard-output*))) | |
| 1494 | (when (and thy (not (eq (theory-info thy) the-e-property))) | |
| 1495 | (setq flag t) | |
| 1496 | (print-theory-brief thy) | |
| 1497 | (print-check .file-col. 7)) | |
| 1498 | (when constr | |
| 1499 | (if flag (princ " ") (setq flag t)) | |
| 1500 | (princ "constr") | |
| 1501 | (print-check .file-col. 7)) | |
| 1502 | (when coherent | |
| 1503 | (if flag (princ " ") (setq flag t)) | |
| 1504 | (princ "coherent") | |
| 1505 | (print-check .file-col. 7)) | |
| 1506 | (when strat | |
| 1507 | (if flag (princ " ") (setq flag t)) | |
| 1508 | (princ "strat: ") (print-simple strat) | |
| 1509 | (print-check .file-col. 7)) | |
| 1510 | (when memo | |
| 1511 | (if flag (princ " ") (setq flag t)) | |
| 1512 | (princ "memo") | |
| 1513 | (print-check .file-col. 7)) | |
| 1514 | (when meta-demod | |
| 1515 | (if flag (princ " ") (setq flag t)) | |
| 1516 | (princ "demod") | |
| 1517 | (print-check .file-col. 7)) | |
| 1518 | (when prec | |
| 1519 | (if flag (princ " ") (setq flag t)) | |
| 1520 | (princ "prec: ") (print-simple prec) | |
| 1521 | (print-check .file-col. 7)) | |
| 1522 | (when assoc | |
| 1523 | ;; (format t "!!~s" assoc) | |
| 1524 | (if flag (princ " ") (setq flag t)) | |
| 1525 | (if (eq :left assoc) | |
| 1526 | (princ "l-assoc") | |
| 1527 | (princ "r-assoc"))) | |
| 1528 | ;; (print-check .file-col.) | |
| 1529 | (princ " }"))) | |
| 1530 | (print-check 0 (length outstr)) | |
| 1531 | (princ outstr))))) | |
| 1549 | 1532 | |
| 1550 | 1533 | ;;; AXIOMS, RULES |
| 1551 | 1534 | ;;;----------------------------------------------------------------------------- |
| 1565 | 1548 | (declare (type fixnum p)) |
| 1566 | 1549 | (let ((*standard-output* stream)) |
| 1567 | 1550 | (cond ((eq 'and (car x)) |
| 1568 | (let ((paren (< p 4))) | |
| 1569 | (when paren (princ "(")) | |
| 1570 | (print-id-cond-list " and " (cdr x) 4) | |
| 1571 | (when paren (princ ")")))) | |
| 1572 | ((eq 'not-equal (car x)) | |
| 1573 | (term-print (cadr x)) (princ " =/== ") (term-print (caddr x))) | |
| 1574 | ((eq 'equal (car x)) | |
| 1575 | (term-print (cadr x)) (princ " === ") (term-print (caddr x))) | |
| 1576 | ((eq 'or (car x)) | |
| 1577 | (let ((paren (< p 8))) | |
| 1578 | (when paren (princ "(")) | |
| 1579 | (print-id-cond-list " or " (cdr x) 8) | |
| 1580 | (when paren (princ ")")))) | |
| 1581 | ((eq 'xor (car x)) | |
| 1582 | (let ((paren (< p 6))) | |
| 1583 | (when paren (princ "(")) | |
| 1584 | (print-id-cond-list " xor " (cdr x) 6) | |
| 1585 | (when paren (princ ")")))) | |
| 1586 | ((eq 'not (car x)) | |
| 1587 | (let ((paren (< p 2))) | |
| 1588 | (when paren (princ "(")) | |
| 1589 | (princ "not ") | |
| 1590 | (print-id-cond (cadr x) 2) | |
| 1591 | (when paren (princ ")")))) | |
| 1592 | (t (break "print-id-cond illegal condition")) | |
| 1593 | ))) | |
| 1551 | (let ((paren (< p 4))) | |
| 1552 | (when paren (princ "(")) | |
| 1553 | (print-id-cond-list " and " (cdr x) 4) | |
| 1554 | (when paren (princ ")")))) | |
| 1555 | ((eq 'not-equal (car x)) | |
| 1556 | (term-print (cadr x)) (princ " =/== ") (term-print (caddr x))) | |
| 1557 | ((eq 'equal (car x)) | |
| 1558 | (term-print (cadr x)) (princ " === ") (term-print (caddr x))) | |
| 1559 | ((eq 'or (car x)) | |
| 1560 | (let ((paren (< p 8))) | |
| 1561 | (when paren (princ "(")) | |
| 1562 | (print-id-cond-list " or " (cdr x) 8) | |
| 1563 | (when paren (princ ")")))) | |
| 1564 | ((eq 'xor (car x)) | |
| 1565 | (let ((paren (< p 6))) | |
| 1566 | (when paren (princ "(")) | |
| 1567 | (print-id-cond-list " xor " (cdr x) 6) | |
| 1568 | (when paren (princ ")")))) | |
| 1569 | ((eq 'not (car x)) | |
| 1570 | (let ((paren (< p 2))) | |
| 1571 | (when paren (princ "(")) | |
| 1572 | (princ "not ") | |
| 1573 | (print-id-cond (cadr x) 2) | |
| 1574 | (when paren (princ ")")))) | |
| 1575 | (t (break "print-id-cond illegal condition"))))) | |
| 1594 | 1576 | |
| 1595 | 1577 | (defun print-id-cond-list (tok lst r) |
| 1596 | 1578 | (let ((flag nil)) |
| 1599 | 1581 | (print-id-cond c r)))) |
| 1600 | 1582 | |
| 1601 | 1583 | (defun print-rule-labels (rul) |
| 1602 | (princ "[") | |
| 1603 | (format t "~{~a~^ ~}" (mapcar #'string (axiom-labels rul))) | |
| 1604 | (princ "]:") | |
| 1605 | ) | |
| 1584 | (let ((labels (axiom-labels rul))) | |
| 1585 | (unless *chaos-verbose* | |
| 1586 | ;; (format t "~%~{~s~^ ~}" labels) | |
| 1587 | (setq labels (remove-if #'(lambda (x) (member x '(|:BDEMOD|))) labels))) | |
| 1588 | (when labels | |
| 1589 | (princ "[") | |
| 1590 | (format t "~{~a~^ ~}" (mapcar #'string labels)) | |
| 1591 | (princ "]:")))) | |
| 1606 | 1592 | |
| 1607 | 1593 | (defun print-axiom-brief (rul &optional (stream *standard-output*) |
| 1608 | (no-type nil) | |
| 1609 | (no-label nil) | |
| 1610 | (meta nil)) | |
| 1594 | (no-type nil) | |
| 1595 | (no-label nil) | |
| 1596 | (meta nil)) | |
| 1611 | 1597 | (declare (type axiom rul) |
| 1612 | (type stream stream) | |
| 1613 | (type (or null t) no-type no-label meta)) | |
| 1598 | (type stream stream) | |
| 1599 | (type (or null t) no-type no-label meta)) | |
| 1614 | 1600 | (let ((type (axiom-type rul)) |
| 1615 | (cnd (not (term-is-similar? *BOOL-true* (axiom-condition rul)))) | |
| 1616 | (.printed-vars-so-far. nil) | |
| 1617 | (*standard-output* stream) | |
| 1618 | (axiom-header "")) | |
| 1601 | (cnd (not (term-is-similar? *BOOL-true* (axiom-condition rul)))) | |
| 1602 | (.printed-vars-so-far. nil) | |
| 1603 | (*standard-output* stream) | |
| 1604 | (axiom-header "")) | |
| 1619 | 1605 | (declare (type symbol type) |
| 1620 | (type (or t null) cnd) | |
| 1621 | (type list .printed-vars-so-far.) | |
| 1622 | (type string axiom-header)) | |
| 1606 | (type (or t null) cnd) | |
| 1607 | (type list .printed-vars-so-far.) | |
| 1608 | (type string axiom-header)) | |
| 1623 | 1609 | (unless no-type |
| 1624 | 1610 | (case type |
| 1625 | (:equation | |
| 1626 | (if cnd | |
| 1627 | (if (axiom-is-behavioural rul) | |
| 1628 | (if meta | |
| 1629 | (setq axiom-header ":bceq[") | |
| 1630 | (setq axiom-header "bceq ")) | |
| 1631 | (if meta | |
| 1632 | (setq axiom-header ":ceq[") | |
| 1633 | (setq axiom-header "ceq "))) | |
| 1634 | (if (axiom-is-behavioural rul) | |
| 1635 | (if meta | |
| 1636 | (setq axiom-header ":beq[") | |
| 1637 | (setq axiom-header "beq ")) | |
| 1638 | (if meta | |
| 1639 | (setq axiom-header ":eq[ ") | |
| 1640 | (setq axiom-header "eq "))))) | |
| 1641 | (:rule | |
| 1642 | (if cnd | |
| 1643 | (if (axiom-is-behavioural rul) | |
| 1644 | (if meta | |
| 1645 | (setq axiom-header ":bctrans[") | |
| 1646 | (setq axiom-header "bctrans ")) | |
| 1647 | (if meta | |
| 1648 | (setq axiom-header ":ctrans[") | |
| 1649 | (setq axiom-header "ctrans "))) | |
| 1650 | (if (axiom-is-behavioural rul) | |
| 1651 | (if meta | |
| 1652 | (setq axiom-header ":btrans[") | |
| 1653 | (setq axiom-header "btrans ")) | |
| 1654 | (if meta | |
| 1655 | (setq axiom-header ":trans[") | |
| 1656 | (setq axiom-header "trans "))))) | |
| 1657 | (:pignose-axiom | |
| 1658 | (if (axiom-is-behavioural rul) | |
| 1659 | (setq axiom-header "bax ") | |
| 1660 | (setq axiom-header "ax "))) | |
| 1661 | (:pignose-goal | |
| 1662 | (if (axiom-is-behavioural rul) | |
| 1663 | (setq axiom-header "bgoal ") | |
| 1664 | (setq axiom-header "goal "))))) | |
| 1611 | (:equation | |
| 1612 | (if cnd | |
| 1613 | (if (axiom-is-behavioural rul) | |
| 1614 | (if meta | |
| 1615 | (setq axiom-header ":bceq[") | |
| 1616 | (setq axiom-header "bceq ")) | |
| 1617 | (if meta | |
| 1618 | (setq axiom-header ":ceq[") | |
| 1619 | (setq axiom-header "ceq "))) | |
| 1620 | (if (axiom-is-behavioural rul) | |
| 1621 | (if meta | |
| 1622 | (setq axiom-header ":beq[") | |
| 1623 | (setq axiom-header "beq ")) | |
| 1624 | (if meta | |
| 1625 | (setq axiom-header ":eq[ ") | |
| 1626 | (setq axiom-header "eq "))))) | |
| 1627 | (:rule | |
| 1628 | (if cnd | |
| 1629 | (if (axiom-is-behavioural rul) | |
| 1630 | (if meta | |
| 1631 | (setq axiom-header ":bctrans[") | |
| 1632 | (setq axiom-header "bctrans ")) | |
| 1633 | (if meta | |
| 1634 | (setq axiom-header ":ctrans[") | |
| 1635 | (setq axiom-header "ctrans "))) | |
| 1636 | (if (axiom-is-behavioural rul) | |
| 1637 | (if meta | |
| 1638 | (setq axiom-header ":btrans[") | |
| 1639 | (setq axiom-header "btrans ")) | |
| 1640 | (if meta | |
| 1641 | (setq axiom-header ":trans[") | |
| 1642 | (setq axiom-header "trans "))))) | |
| 1643 | (:pignose-axiom | |
| 1644 | (if (axiom-is-behavioural rul) | |
| 1645 | (setq axiom-header "bax ") | |
| 1646 | (setq axiom-header "ax "))) | |
| 1647 | (:pignose-goal | |
| 1648 | (if (axiom-is-behavioural rul) | |
| 1649 | (setq axiom-header "bgoal ") | |
| 1650 | (setq axiom-header "goal "))))) | |
| 1665 | 1651 | ;; |
| 1666 | 1652 | (princ axiom-header) |
| 1667 | 1653 | (when (and (axiom-labels rul) (not no-label)) |
| 1668 | 1654 | (print-rule-labels rul) |
| 1669 | 1655 | (princ " ")) |
| 1670 | 1656 | (let ((.file-col. (file-column *standard-output*)) |
| 1671 | (*print-indent* (+ *print-indent* (length axiom-header))) | |
| 1672 | (mml (and (eq *print-xmode* :fancy) | |
| 1673 | (eq (term-head (axiom-lhs rul)) *eql-op*)))) | |
| 1657 | (*print-indent* (+ *print-indent* (length axiom-header)))) | |
| 1674 | 1658 | ;; LHS |
| 1675 | (when mml (princ "(")) | |
| 1676 | 1659 | (setq .printed-vars-so-far. |
| 1677 | (term-print (axiom-lhs rul))) | |
| 1678 | (when mml (princ ")")) | |
| 1660 | (term-print (axiom-lhs rul))) | |
| 1679 | 1661 | (unless (memq type '(:pignose-axiom :pignose-goal)) |
| 1680 | (setq .file-col. (file-column *standard-output*)) | |
| 1681 | (print-check 0 .file-col.) | |
| 1682 | (if (eq type ':rule) | |
| 1683 | (princ " => ") | |
| 1684 | (princ " = ")) | |
| 1685 | (setq .file-col. (file-column *standard-output*)) | |
| 1686 | ;; RHS | |
| 1687 | (term-print (axiom-rhs rul)))) | |
| 1662 | (setq .file-col. (file-column *standard-output*)) | |
| 1663 | (print-check 0 .file-col.) | |
| 1664 | (if (eq type ':rule) | |
| 1665 | (princ " => ") | |
| 1666 | (princ " = ")) | |
| 1667 | (setq .file-col. (file-column *standard-output*)) | |
| 1668 | ;; RHS | |
| 1669 | (term-print (axiom-rhs rul)))) | |
| 1688 | 1670 | (let ((.file-col. (file-column *standard-output*))) |
| 1689 | 1671 | ;; CONDITION |
| 1690 | 1672 | (when (or cnd |
| 1691 | (and *chaos-verbose* (axiom-id-condition rul))) | |
| 1692 | (print-next) | |
| 1693 | (princ " ") | |
| 1694 | (if meta | |
| 1695 | (princ " :if ") | |
| 1696 | (princ " if ")) | |
| 1697 | (setq .file-col. (+ 4 .file-col.)) | |
| 1698 | (let ((*print-indent* (+ 5 *print-indent*))) | |
| 1699 | (when cnd | |
| 1700 | (term-print (axiom-condition rul))) | |
| 1701 | (when meta | |
| 1702 | (princ "]")) | |
| 1703 | (when (and *chaos-verbose* (not meta)) | |
| 1704 | (when (and cnd (axiom-id-condition rul)) (princ " and ")) | |
| 1705 | (when (axiom-id-condition rul) | |
| 1706 | (print-id-condition (axiom-id-condition rul) | |
| 1707 | *standard-output*)))))))) | |
| 1673 | (and *chaos-verbose* (axiom-id-condition rul))) | |
| 1674 | (print-next) | |
| 1675 | (princ " ") | |
| 1676 | (if meta | |
| 1677 | (princ " :if ") | |
| 1678 | (princ " if ")) | |
| 1679 | (setq .file-col. (+ 4 .file-col.)) | |
| 1680 | (let ((*print-indent* (+ 5 *print-indent*))) | |
| 1681 | (when cnd | |
| 1682 | (term-print (axiom-condition rul))) | |
| 1683 | (when meta | |
| 1684 | (princ "]")) | |
| 1685 | (when (and *chaos-verbose* (not meta)) | |
| 1686 | (when (and cnd (axiom-id-condition rul)) (princ " and ")) | |
| 1687 | (when (axiom-id-condition rul) | |
| 1688 | (print-id-condition (axiom-id-condition rul) | |
| 1689 | *standard-output*)))))))) | |
| 1708 | 1690 | |
| 1709 | 1691 | (eval-when (:execute :load-toplevel) |
| 1710 | 1692 | (setf (symbol-function 'print-rule-brief) |
| 1711 | (symbol-function 'print-axiom-brief))) ; synonim | |
| 1693 | (symbol-function 'print-axiom-brief))) ; synonim | |
| 1712 | 1694 | |
| 1713 | 1695 | (defun print-rule-id-inf (x) |
| 1714 | 1696 | (print-axiom-brief (nth 0 x)) (terpri) |
| 1718 | 1700 | |
| 1719 | 1701 | (defun print-rule (rul) |
| 1720 | 1702 | (let ((type (axiom-type rul)) |
| 1721 | (cond (not (term-is-similar? *bool-true* (axiom-condition rul)))) | |
| 1722 | (rul-rhs (axiom-rhs rul)) | |
| 1723 | (*print-with-sort* t)) | |
| 1703 | (cond (not (term-is-similar? *bool-true* (axiom-condition rul)))) | |
| 1704 | (rul-rhs (axiom-rhs rul)) | |
| 1705 | (*print-with-sort* t)) | |
| 1724 | 1706 | (case type |
| 1725 | 1707 | (:equation |
| 1726 | 1708 | (if cond |
| 1727 | (if (axiom-is-behavioural rul) | |
| 1728 | (princ "- conditional behavioural equation ") | |
| 1729 | (princ "- conditional equation ")) | |
| 1730 | (if (axiom-is-behavioural rul) | |
| 1731 | (princ "- behavioural equation ") | |
| 1732 | (princ "- equation ")))) | |
| 1709 | (if (axiom-is-behavioural rul) | |
| 1710 | (princ "- conditional behavioural equation ") | |
| 1711 | (princ "- conditional equation ")) | |
| 1712 | (if (axiom-is-behavioural rul) | |
| 1713 | (princ "- behavioural equation ") | |
| 1714 | (princ "- equation ")))) | |
| 1733 | 1715 | (:rule |
| 1734 | 1716 | (if cond |
| 1735 | (if (axiom-is-behavioural rul) | |
| 1736 | (princ "- conditional behavioural transition ") | |
| 1737 | (princ "- conditional transition ")) | |
| 1738 | (if (axiom-is-behavioural rul) | |
| 1739 | (princ "- behavioural transition ") | |
| 1740 | (princ "- transition ")))) | |
| 1717 | (if (axiom-is-behavioural rul) | |
| 1718 | (princ "- conditional behavioural transition ") | |
| 1719 | (princ "- conditional transition ")) | |
| 1720 | (if (axiom-is-behavioural rul) | |
| 1721 | (princ "- behavioural transition ") | |
| 1722 | (princ "- transition ")))) | |
| 1741 | 1723 | (:pignose-axiom |
| 1742 | 1724 | (if (axiom-is-behavioural rul) |
| 1743 | (princ "- behavioural FOPL axiom ") | |
| 1744 | (princ "- FOPL axiom "))) | |
| 1725 | (princ "- behavioural FOPL axiom ") | |
| 1726 | (princ "- FOPL axiom "))) | |
| 1745 | 1727 | (:pignose-goal |
| 1746 | 1728 | (if (axiom-is-behavioural rul) |
| 1747 | (princ "- bahvioural FOPL goal ") | |
| 1748 | (princ "- FOPL goal "))) | |
| 1729 | (princ "- bahvioural FOPL goal ") | |
| 1730 | (princ "- FOPL goal "))) | |
| 1749 | 1731 | ) |
| 1750 | 1732 | (when (axiom-labels rul) |
| 1751 | 1733 | (print-rule-labels rul) |
| 1755 | 1737 | (print-next) |
| 1756 | 1738 | (princ "lhs : ") |
| 1757 | 1739 | (let ((*print-indent* (+ *print-indent* 4))) |
| 1758 | (term-print (axiom-lhs rul))) | |
| 1740 | (term-print (axiom-lhs rul))) | |
| 1759 | 1741 | (print-next) |
| 1760 | 1742 | ;; RHS |
| 1761 | 1743 | (princ "rhs : ") |
| 1762 | 1744 | (let ((*print-indent* (+ *print-indent* 4))) |
| 1763 | (term-print rul-rhs)) | |
| 1745 | (term-print rul-rhs)) | |
| 1764 | 1746 | ;; CONDITION |
| 1765 | 1747 | (when cond |
| 1766 | (print-next) | |
| 1767 | (princ "condition : ") | |
| 1768 | (let ((*print-indent* (+ *print-indent* 4))) | |
| 1769 | (term-print (axiom-condition rul)))) | |
| 1748 | (print-next) | |
| 1749 | (princ "condition : ") | |
| 1750 | (let ((*print-indent* (+ *print-indent* 4))) | |
| 1751 | (term-print (axiom-condition rul)))) | |
| 1770 | 1752 | ;; TOP-OPERATOR/ID CONDITION |
| 1771 | 1753 | (let ((*print-indent* *print-indent*) |
| 1772 | (lhs (axiom-lhs rul))) | |
| 1773 | ;; | |
| 1774 | (cond ((term-is-variable? lhs) | |
| 1775 | (print-next) | |
| 1776 | (princ "* lhs is a variable.")) | |
| 1777 | (t | |
| 1778 | (let ((head (term-head lhs))) | |
| 1779 | (print-next) | |
| 1780 | (princ "top operator : ") | |
| 1781 | (when (method-arity head) | |
| 1782 | (print-sort-list (method-arity head) *current-module*) | |
| 1783 | (princ " ")) | |
| 1784 | (princ "-> ") | |
| 1785 | (print-sort-name (method-coarity head) *current-module*))) | |
| 1786 | ) | |
| 1787 | ;; | |
| 1788 | (when (axiom-id-condition rul) | |
| 1789 | (print-next) | |
| 1790 | (princ "id condition : ") | |
| 1791 | (print-id-condition (axiom-id-condition rul) | |
| 1792 | *standard-output*)) | |
| 1793 | ;; KIND | |
| 1794 | (when (axiom-kind rul) | |
| 1795 | (print-next) | |
| 1796 | (princ "axiom kind : ") | |
| 1797 | (case (axiom-kind rul) | |
| 1798 | (:id-theorem (princ "identity")) | |
| 1799 | (:id-completion (princ "id completion")) | |
| 1800 | (:id-ext-theory (princ "extended identity")) | |
| 1801 | (:a-left-theory (princ "left associativity")) | |
| 1802 | (:a-right-theory (princ "right associativity")) | |
| 1803 | (:a-middle-thoery (princ "associativity")) | |
| 1804 | (:ac-theory (princ "associative+commutative")) | |
| 1805 | (:idem-theory (princ "idempotency")) | |
| 1806 | (:bad-rule (princ "illegal as rewrite rule")) | |
| 1807 | (:bad-beh (princ "non coherent beh axiom")) | |
| 1808 | )) | |
| 1809 | ;; METHOD | |
| 1810 | (when (or *on-debug* *chaos-verbose*) | |
| 1811 | (when (axiom-first-match-method rul) | |
| 1812 | (print-next) | |
| 1813 | (princ "* first match : ") | |
| 1814 | (print-simple (axiom-first-match-method rul))) | |
| 1815 | (when (axiom-next-match-method rul) | |
| 1816 | (print-next) | |
| 1817 | (princ "* next match : ") | |
| 1818 | (print-simple (axiom-next-match-method rul)))) | |
| 1819 | ;; Extensions | |
| 1820 | (let ((exts (axiom-extensions rul))) | |
| 1821 | (when exts | |
| 1822 | (when (and (= (length exts) 1) | |
| 1823 | (not (equal '(nil) exts))) | |
| 1824 | (print-next) | |
| 1825 | (princ "* AC extension: ") | |
| 1826 | (let ((*print-indent* (- *print-indent* 2))) | |
| 1827 | (print-rule (car exts)))) | |
| 1828 | (when (and (= (length exts) 3) | |
| 1829 | (not (equal exts '(nil nil nil)))) | |
| 1830 | (dolist (r exts) | |
| 1831 | (print-next) | |
| 1832 | (princ "* A extension : ") | |
| 1833 | (let ((*print-indent* (- *print-indent* 2))) | |
| 1834 | (print-rule r)))))) | |
| 1835 | )))) | |
| 1754 | (lhs (axiom-lhs rul))) | |
| 1755 | ;; | |
| 1756 | (cond ((term-is-variable? lhs) | |
| 1757 | (print-next) | |
| 1758 | (princ "* lhs is a variable.")) | |
| 1759 | (t | |
| 1760 | (let ((head (term-head lhs))) | |
| 1761 | (print-next) | |
| 1762 | (princ "top operator : ") | |
| 1763 | (when (method-arity head) | |
| 1764 | (print-sort-list (method-arity head) *current-module*) | |
| 1765 | (princ " ")) | |
| 1766 | (princ "-> ") | |
| 1767 | (print-sort-name (method-coarity head) *current-module*))) | |
| 1768 | ) | |
| 1769 | ;; | |
| 1770 | (when (axiom-id-condition rul) | |
| 1771 | (print-next) | |
| 1772 | (princ "id condition : ") | |
| 1773 | (print-id-condition (axiom-id-condition rul) | |
| 1774 | *standard-output*)) | |
| 1775 | ;; KIND | |
| 1776 | (when (axiom-kind rul) | |
| 1777 | (print-next) | |
| 1778 | (princ "axiom kind : ") | |
| 1779 | (case (axiom-kind rul) | |
| 1780 | (:id-theorem (princ "identity")) | |
| 1781 | (:id-completion (princ "id completion")) | |
| 1782 | (:id-ext-theory (princ "extended identity")) | |
| 1783 | (:a-left-theory (princ "left associativity")) | |
| 1784 | (:a-right-theory (princ "right associativity")) | |
| 1785 | (:a-middle-thoery (princ "associativity")) | |
| 1786 | (:ac-theory (princ "associative+commutative")) | |
| 1787 | (:idem-theory (princ "idempotency")) | |
| 1788 | (:bad-rule (princ "illegal as rewrite rule")) | |
| 1789 | (:bad-beh (princ "non coherent beh axiom")) | |
| 1790 | )) | |
| 1791 | ;; METHOD | |
| 1792 | (when (or *on-debug* *chaos-verbose*) | |
| 1793 | (when (axiom-first-match-method rul) | |
| 1794 | (print-next) | |
| 1795 | (princ "* first match : ") | |
| 1796 | (print-simple (axiom-first-match-method rul))) | |
| 1797 | (when (axiom-next-match-method rul) | |
| 1798 | (print-next) | |
| 1799 | (princ "* next match : ") | |
| 1800 | (print-simple (axiom-next-match-method rul)))) | |
| 1801 | ;; Extensions | |
| 1802 | (let ((exts (axiom-extensions rul))) | |
| 1803 | (when exts | |
| 1804 | (when (and (= (length exts) 1) | |
| 1805 | (not (equal '(nil) exts))) | |
| 1806 | (print-next) | |
| 1807 | (princ "* AC extension: ") | |
| 1808 | (let ((*print-indent* (- *print-indent* 2))) | |
| 1809 | (print-rule (car exts)))) | |
| 1810 | (when (and (= (length exts) 3) | |
| 1811 | (not (equal exts '(nil nil nil)))) | |
| 1812 | (dolist (r exts) | |
| 1813 | (print-next) | |
| 1814 | (princ "* A extension : ") | |
| 1815 | (let ((*print-indent* (- *print-indent* 2))) | |
| 1816 | (print-rule r)))))) | |
| 1817 | )))) | |
| 1836 | 1818 | |
| 1837 | 1819 | (defun print-axiom (ax) (print-rule ax)) |
| 1838 | 1820 | |
| 1849 | 1831 | |
| 1850 | 1832 | (defun print-mapping (mppg &optional (stream *standard-output*)) |
| 1851 | 1833 | (let ((*standard-output* stream) |
| 1852 | (*print-indent* (1+ *print-indent*)) | |
| 1853 | (*print-array* nil) | |
| 1854 | (*print-circle* nil)) | |
| 1834 | (*print-indent* (1+ *print-indent*)) | |
| 1835 | (*print-array* nil) | |
| 1836 | (*print-circle* nil)) | |
| 1855 | 1837 | (print-next) |
| 1856 | 1838 | (princ "name: ") |
| 1857 | 1839 | (print-modexp (modmorph-name mppg) stream t t) |
| 1876 | 1858 | (print-next) |
| 1877 | 1859 | (print-method (car i)) (princ "(") |
| 1878 | 1860 | (print-mod-name (method-module (car i)) |
| 1879 | *standard-output* | |
| 1880 | t t) | |
| 1861 | *standard-output* | |
| 1862 | t t) | |
| 1881 | 1863 | (princ ")") |
| 1882 | 1864 | (print-next) |
| 1883 | 1865 | (princ "--> ") |
| 1884 | 1866 | (if (eq :simple-map (cadr i)) |
| 1885 | (let ((tm (cdr (last i)))) | |
| 1886 | (print-method tm) | |
| 1887 | (princ ":simple-map(") | |
| 1888 | (print-mod-name (method-module tm) | |
| 1889 | *standard-output* | |
| 1890 | t t) | |
| 1891 | (princ ")")) | |
| 1892 | (let ((head (term-head (cadddr i)))) | |
| 1893 | (print-method head) | |
| 1894 | (princ ":replacement(") | |
| 1895 | (print-mod-name (method-module head) | |
| 1896 | *standard-output* | |
| 1897 | t t) | |
| 1898 | (princ ")"))) | |
| 1867 | (let ((tm (cdr (last i)))) | |
| 1868 | (print-method tm) | |
| 1869 | (princ ":simple-map(") | |
| 1870 | (print-mod-name (method-module tm) | |
| 1871 | *standard-output* | |
| 1872 | t t) | |
| 1873 | (princ ")")) | |
| 1874 | (let ((head (term-head (cadddr i)))) | |
| 1875 | (print-method head) | |
| 1876 | (princ ":replacement(") | |
| 1877 | (print-mod-name (method-module head) | |
| 1878 | *standard-output* | |
| 1879 | t t) | |
| 1880 | (princ ")"))) | |
| 1899 | 1881 | ) |
| 1900 | 1882 | (decf *print-indent* 2) |
| 1901 | 1883 | (print-next) |
| 1929 | 1911 | (defun print-substitution (subst &optional (stream *standard-output*)) |
| 1930 | 1912 | (let ((.file-col. .file-col.)) |
| 1931 | 1913 | (if (or (substitution-is-empty subst) |
| 1932 | (null (car subst))) | |
| 1933 | (princ "{}" stream) | |
| 1914 | (null (car subst))) | |
| 1915 | (princ "{}" stream) | |
| 1934 | 1916 | (let ((s (substitution-list-of-pairs subst))) |
| 1935 | (princ "{ " stream) | |
| 1936 | (setq .file-col. (file-column stream)) | |
| 1937 | (term-print (caar s) stream) | |
| 1938 | (print-check .file-col. 0 stream) | |
| 1939 | (princ " |-> " stream) | |
| 1940 | (term-print (cdar s)) | |
| 1941 | (dolist (m (cdr s)) | |
| 1942 | (princ ", " stream) | |
| 1943 | (print-check .file-col. 0 stream) | |
| 1944 | (let ((src (car m))) | |
| 1945 | (term-print src stream) | |
| 1946 | (print-check .file-col. 0 stream) | |
| 1947 | (princ " |-> " stream) | |
| 1948 | (term-print (cdr m) stream))) | |
| 1949 | (princ " }" stream))))) | |
| 1917 | (princ "{ " stream) | |
| 1918 | (setq .file-col. (file-column stream)) | |
| 1919 | (term-print (caar s) stream) | |
| 1920 | (print-check .file-col. 0 stream) | |
| 1921 | (princ " |-> " stream) | |
| 1922 | (term-print (cdar s)) | |
| 1923 | (dolist (m (cdr s)) | |
| 1924 | (princ ", " stream) | |
| 1925 | (print-check .file-col. 0 stream) | |
| 1926 | (let ((src (car m))) | |
| 1927 | (term-print src stream) | |
| 1928 | (print-check .file-col. 0 stream) | |
| 1929 | (princ " |-> " stream) | |
| 1930 | (term-print (cdr m) stream))) | |
| 1931 | (princ " }" stream))))) | |
| 1950 | 1932 | |
| 1951 | 1933 | ;;; PARSE DICTIONARY |
| 1952 | 1934 | |
| 1953 | 1935 | (defun show-parse-dict (dict) |
| 1954 | 1936 | (format t "~%Parse Dictionary:") |
| 1955 | 1937 | (maphash #'(lambda (key val) |
| 1956 | (format t "~% -- key = ~s" key) | |
| 1957 | (format t "~% value = ") (print-chaos-object val)) | |
| 1958 | (dictionary-table dict)) | |
| 1938 | (format t "~% -- key = ~s" key) | |
| 1939 | (format t "~% value = ") (print-chaos-object val)) | |
| 1940 | (dictionary-table dict)) | |
| 1959 | 1941 | (format t "~% Juxtapositions : ") |
| 1960 | 1942 | (let ((*print-indent* (+ *print-indent* 2))) |
| 1961 | 1943 | (dolist (jux (dictionary-juxtaposition dict)) |
| 1972 | 1954 | |
| 1973 | 1955 | (defun pp-sort-order (&optional (sort-order *current-sort-order*)) |
| 1974 | 1956 | (maphash #'(lambda (sort sort-rel) |
| 1975 | (format t "~%[Sort : ~A](~a)" (sort-print-name sort) sort) | |
| 1976 | (format t "~% Subsorts : ~{ ~A~}(~{ ~a~})" | |
| 1977 | (mapcar #'sort-print-name (_subsorts sort-rel)) | |
| 1978 | (_subsorts sort-rel)) | |
| 1979 | (format t "~% Supersorts : ~{ ~A~}(~{ ~a~})" | |
| 1980 | (mapcar #'sort-print-name (_supersorts sort-rel)) | |
| 1981 | (_supersorts sort-rel)) | |
| 1982 | (if (_err-sort sort-rel) | |
| 1983 | (format t "~% Errorsort : ~A(~a)" (sort-print-name | |
| 1984 | (_err-sort sort-rel)) | |
| 1985 | (_err-sort sort-rel)))) | |
| 1986 | sort-order)) | |
| 1957 | (format t "~%[Sort : ~A](~a)" (sort-print-name sort) sort) | |
| 1958 | (format t "~% Subsorts : ~{ ~A~}(~{ ~a~})" | |
| 1959 | (mapcar #'sort-print-name (_subsorts sort-rel)) | |
| 1960 | (_subsorts sort-rel)) | |
| 1961 | (format t "~% Supersorts : ~{ ~A~}(~{ ~a~})" | |
| 1962 | (mapcar #'sort-print-name (_supersorts sort-rel)) | |
| 1963 | (_supersorts sort-rel)) | |
| 1964 | (if (_err-sort sort-rel) | |
| 1965 | (format t "~% Errorsort : ~A(~a)" (sort-print-name | |
| 1966 | (_err-sort sort-rel)) | |
| 1967 | (_err-sort sort-rel)))) | |
| 1968 | sort-order)) | |
| 1987 | 1969 | |
| 1988 | 1970 | (defun pp-sort-order-raw (module &optional |
| 1989 | (sort-order (module-sort-order module))) | |
| 1971 | (sort-order (module-sort-order module))) | |
| 1990 | 1972 | (with-in-module (module) |
| 1991 | 1973 | (maphash #'(lambda (sort sort-rel) |
| 1992 | (format t "~%[Sort : ~A](~a)" (sort-print-name sort) sort) | |
| 1993 | (format t "~% Subsorts : ~{ ~A~}(~{ ~a~})" | |
| 1994 | (mapcar #'sort-print-name (_subsorts sort-rel)) | |
| 1995 | (_subsorts sort-rel)) | |
| 1996 | (format t "~% Supersorts : ~{ ~A~}(~{ ~a~})" | |
| 1997 | (mapcar #'sort-print-name (_supersorts sort-rel)) | |
| 1998 | (_supersorts sort-rel)) | |
| 1999 | (if (_err-sort sort-rel) | |
| 2000 | (format t "~% Errorsort : ~A(~a)" (sort-print-name | |
| 2001 | (_err-sort sort-rel)) | |
| 2002 | (_err-sort sort-rel)))) | |
| 2003 | sort-order))) | |
| 1974 | (format t "~%[Sort : ~A](~a)" (sort-print-name sort) sort) | |
| 1975 | (format t "~% Subsorts : ~{ ~A~}(~{ ~a~})" | |
| 1976 | (mapcar #'sort-print-name (_subsorts sort-rel)) | |
| 1977 | (_subsorts sort-rel)) | |
| 1978 | (format t "~% Supersorts : ~{ ~A~}(~{ ~a~})" | |
| 1979 | (mapcar #'sort-print-name (_supersorts sort-rel)) | |
| 1980 | (_supersorts sort-rel)) | |
| 1981 | (if (_err-sort sort-rel) | |
| 1982 | (format t "~% Errorsort : ~A(~a)" (sort-print-name | |
| 1983 | (_err-sort sort-rel)) | |
| 1984 | (_err-sort sort-rel)))) | |
| 1985 | sort-order))) | |
| 2004 | 1986 | |
| 2005 | 1987 | ;;; MODULE INSTANCE DB |
| 2006 | 1988 | |
| 2007 | 1989 | (defun print-instance-db (&optional (module *current-module*)) |
| 2008 | 1990 | (let ((db (module-instance-db module))) |
| 2009 | 1991 | (unless db |
| 2010 | (format t "~&module ") | |
| 1992 | (format t "~%module ") | |
| 2011 | 1993 | (print-chaos-object module) |
| 2012 | 1994 | (format t " has no instance database.")) |
| 2013 | 1995 | (format t "~&Contents of instance DB") |
| 2014 | 1996 | (maphash #'(lambda (key val) |
| 2015 | (format t "~&---------------------------------") | |
| 2016 | (format t "~&Key = ") (print-chaos-object key) | |
| 2017 | (format t "~&Value = ") (print-chaos-object val)) | |
| 2018 | db))) | |
| 1997 | (format t "~%---------------------------------") | |
| 1998 | (format t "~&Key = ") (print-chaos-object key) | |
| 1999 | (format t "~&Value = ") (print-chaos-object val)) | |
| 2000 | db))) | |
| 2019 | 2001 | |
| 2020 | 2002 | ;;; EOF |
| 0 | 0 | ;;;-*- Mode:LISP; Package:CHAOS; Base:10; Syntax:Common-lisp -*- |
| 1 | 1 | ;;; |
| 2 | ;;; Copyright (c) 2000-2014, Toshimi Sawada. All rights reserved. | |
| 2 | ;;; Copyright (c) 2000-2015, Toshimi Sawada. All rights reserved. | |
| 3 | 3 | ;;; |
| 4 | 4 | ;;; Redistribution and use in source and binary forms, with or without |
| 5 | 5 | ;;; modification, are permitted provided that the following conditions |
| 27 | 27 | ;;; |
| 28 | 28 | (in-package :chaos) |
| 29 | 29 | #|============================================================================== |
| 30 | System: CHAOS | |
| 31 | Module: primitives | |
| 32 | File: script.lisp | |
| 30 | System: CHAOS | |
| 31 | Module: primitives | |
| 32 | File: script.lisp | |
| 33 | 33 | ==============================================================================|# |
| 34 | 34 | #-:chaos-debug |
| 35 | 35 | (declaim (optimize (speed 3) (safety 0) #-GCL (debug 0))) |
| 57 | 57 | ;;; ERROR : represents error status |
| 58 | 58 | ;;; ***** |
| 59 | 59 | (defterm error (%script) |
| 60 | :visible (type ; one of :warn, :error, :fatal? | |
| 61 | message) ; string | |
| 60 | :visible (type ; one of :warn, :error, :fatal? | |
| 61 | message) ; string | |
| 62 | 62 | :eval process-error) |
| 63 | 63 | |
| 64 | 64 | ;;; ********* |
| 82 | 82 | |
| 83 | 83 | (defterm reduce (%script) |
| 84 | 84 | :visible (term &optional (module *current-module*) |
| 85 | (mode :red) return-text) | |
| 85 | (mode :red) return-text) | |
| 86 | 86 | :eval perform-reduction) |
| 87 | 87 | |
| 88 | 88 | ;;; *********** |
| 90 | 90 | ;;; *********** |
| 91 | 91 | (defterm test-reduce (%script) |
| 92 | 92 | :visible (term expect &optional (module *current-module*) |
| 93 | (mode :red) return-text) | |
| 93 | (mode :red) return-text) | |
| 94 | 94 | :eval perform-test-reduction) |
| 95 | 95 | |
| 96 | 96 | ;;; ***** |
| 98 | 98 | ;;; ***** |
| 99 | 99 | (defterm parse (%script) |
| 100 | 100 | :visible (term &optional (module *current-module*) |
| 101 | return-text) | |
| 101 | return-text) | |
| 102 | 102 | :eval do-parse-term) |
| 103 | 103 | |
| 104 | 104 | ;;; ***** |
| 106 | 106 | ;;; ***** |
| 107 | 107 | (defterm input (%script) |
| 108 | 108 | :visible (file-name |
| 109 | &optional (load-path *chaos-libpath*) | |
| 110 | (proc 'process-cafeobj-input) | |
| 111 | (suffixes '(".bin" ".cafe" ".mod")) | |
| 112 | args) | |
| 109 | &optional (load-path *chaos-libpath*) | |
| 110 | (proc 'process-cafeobj-input) | |
| 111 | (suffixes '(".bin" ".cafe" ".mod")) | |
| 112 | args) | |
| 113 | 113 | :eval eval-input-file) |
| 114 | 114 | |
| 115 | 115 | ;;; ***************** |
| 182 | 182 | ;;; ************ |
| 183 | 183 | (defterm load-prelude (%script) |
| 184 | 184 | :visible (file &optional |
| 185 | (processor 'process-cafeobj-input)) | |
| 185 | (processor 'process-cafeobj-input)) | |
| 186 | 186 | :eval eval-load-prelude) |
| 187 | 187 | |
| 188 | 188 | ;;; * Follwing two (start, apply) are defined in |
| 194 | 194 | ;;; START |
| 195 | 195 | ;;; ***** |
| 196 | 196 | (defterm start (%script) |
| 197 | :visible (target) ; terget term | |
| 197 | :visible (target) ; terget term | |
| 198 | 198 | :eval eval-start-th |
| 199 | 199 | ) |
| 200 | 200 | |
| 202 | 202 | ;;; APPLY |
| 203 | 203 | ;;; ***** |
| 204 | 204 | (defterm apply (%script) |
| 205 | :visible (action ; action to be performed, one-of | |
| 206 | ; :apply, :reduce, :print, :help. | |
| 207 | rule ; rule specifier to be applied. | |
| 208 | bindings ; list of variable bindings. | |
| 209 | at ; one of :at, :within. | |
| 210 | selectors) ; list of selectors. | |
| 205 | :visible (action ; action to be performed, one-of | |
| 206 | ; :apply, :reduce, :print, :help. | |
| 207 | rule ; rule specifier to be applied. | |
| 208 | bindings ; list of variable bindings. | |
| 209 | at ; one of :at, :within. | |
| 210 | selectors) ; list of selectors. | |
| 211 | 211 | :eval eval-apply-command) |
| 212 | 212 | |# |
| 213 | 213 | |
| 215 | 215 | ;;; PROVIDE |
| 216 | 216 | ;;; ******* |
| 217 | 217 | (defterm provide (%script) |
| 218 | :visible (feature) ; feature to be provided. | |
| 218 | :visible (feature) ; feature to be provided. | |
| 219 | 219 | :eval eval-provide-command) |
| 220 | 220 | |
| 221 | 221 | ;;; ******* |
| 222 | 222 | ;;; REQUIRE |
| 223 | 223 | ;;; ******* |
| 224 | 224 | (defterm require (%script) |
| 225 | :visible (feature ; required feature | |
| 226 | &optional | |
| 227 | (proc 'process-cafeobj-input) ; process to evaluating fomrs. | |
| 228 | file ; filename | |
| 229 | ) | |
| 225 | :visible (feature ; required feature | |
| 226 | &optional | |
| 227 | (proc 'process-cafeobj-input) ; process to evaluating fomrs. | |
| 228 | file ; filename | |
| 229 | ) | |
| 230 | 230 | :eval eval-require-command) |
| 231 | 231 | |
| 232 | 232 | ;;; ************* |
| 233 | 233 | ;;; REWRITE-COUNT |
| 234 | 234 | ;;; ************* |
| 235 | 235 | (defterm rewrite-count (%script) |
| 236 | :visible (limit) ; limitation | |
| 236 | :visible (limit) ; limitation | |
| 237 | 237 | :eval eval-rewrite-count-limit) |
| 238 | 238 | |
| 239 | 239 | ;;; ******* |
| 247 | 247 | ;;; PROTECT-MODULE |
| 248 | 248 | ;;; ************** |
| 249 | 249 | (defterm protect (%script) |
| 250 | :visible (module ; module to be set protect mode | |
| 251 | mode ; mode = :set | :unset | |
| 252 | ) | |
| 250 | :visible (module ; module to be set protect mode | |
| 251 | mode ; mode = :set | :unset | |
| 252 | ) | |
| 253 | 253 | :eval eval-protect) |
| 254 | 254 | |
| 255 | 255 | ;;; ******* |
| 264 | 264 | ;;; ********** |
| 265 | 265 | (defterm save-chaos (%script) |
| 266 | 266 | :visible (top |
| 267 | file) | |
| 267 | file) | |
| 268 | 268 | :eval eval-save-chaos) |
| 269 | 269 | |
| 270 | 270 | ;;; ** |
| 340 | 340 | ;;; *** |
| 341 | 341 | (defterm set (%script) |
| 342 | 342 | :visible (switch |
| 343 | value) | |
| 343 | value) | |
| 344 | 344 | :eval eval-set) |
| 345 | 345 | |
| 346 | 346 | ;;; ********** |
| 355 | 355 | ;;; ***** |
| 356 | 356 | (defterm check (%script) |
| 357 | 357 | :visible (what |
| 358 | args) | |
| 358 | args) | |
| 359 | 359 | :eval eval-check) |
| 360 | 360 | |
| 361 | 361 | ;;; ************* |
| 363 | 363 | ;;; ************* |
| 364 | 364 | (defterm tram (%script) |
| 365 | 365 | :visible (command |
| 366 | modexp | |
| 367 | term | |
| 368 | debug) | |
| 366 | modexp | |
| 367 | term | |
| 368 | debug) | |
| 369 | 369 | :eval eval-tram) |
| 370 | 370 | |
| 371 | 371 | ;;; ********* |
| 373 | 373 | ;;; ********* |
| 374 | 374 | (defterm autoload (%script) |
| 375 | 375 | :visible (mod-name |
| 376 | file) | |
| 376 | file) | |
| 377 | 377 | :eval eval-autoload) |
| 378 | ||
| 379 | ;;; *********** | |
| 380 | ;;; NO AUTOLOAD | |
| 381 | ;;; *********** | |
| 382 | (defterm no-autoload (%script) | |
| 383 | :visible (mod-name) | |
| 384 | :eval eval-no-autoload) | |
| 378 | 385 | |
| 379 | 386 | ;;; ****************************** |
| 380 | 387 | ;;; CIRCULAR COINDUCTIVE REWRITING |
| 382 | 389 | |
| 383 | 390 | (defterm cbred (%script) |
| 384 | 391 | :visible (module |
| 385 | lhs | |
| 386 | rhs) | |
| 392 | lhs | |
| 393 | rhs) | |
| 387 | 394 | :eval eval-cbred) |
| 388 | 395 | |
| 389 | 396 | ;;; ********************** |
| 429 | 436 | ;;; ********* |
| 430 | 437 | (defterm delimiter (%script) |
| 431 | 438 | :visible (operation |
| 432 | char-list) | |
| 439 | char-list) | |
| 433 | 440 | :eval eval-delimiter) |
| 434 | ||
| 441 | ||
| 435 | 442 | ;;; **** |
| 436 | 443 | ;;; CASE |
| 437 | 444 | ;;; case (<Term>) on (<Modexp>) as (<Name>) : <GoalTerm> . |
| 0 | 0 | ;;;-*- Mode:LISP; Package:CHAOS; Base:10; Syntax:Common-lisp -*- |
| 1 | 1 | ;;; |
| 2 | ;;; Copyright (c) 2000-2014, Toshimi Sawada. All rights reserved. | |
| 2 | ;;; Copyright (c) 2000-2015, Toshimi Sawada. All rights reserved. | |
| 3 | 3 | ;;; |
| 4 | 4 | ;;; Redistribution and use in source and binary forms, with or without |
| 5 | 5 | ;;; modification, are permitted provided that the following conditions |
| 27 | 27 | ;;; |
| 28 | 28 | (in-package :chaos) |
| 29 | 29 | #|============================================================================== |
| 30 | System: Chaos | |
| 31 | Module: primitives | |
| 32 | File: substitution.lisp | |
| 30 | System: Chaos | |
| 31 | Module: primitives | |
| 32 | File: substitution.lisp | |
| 33 | 33 | ==============================================================================|# |
| 34 | 34 | #-:chaos-debug |
| 35 | 35 | (declaim (optimize (speed 3) (safety 0) #-GCL (debug 0))) |
| 37 | 37 | (declaim (optimize (speed 1) (safety 3) #-GCL (debug 3))) |
| 38 | 38 | |
| 39 | 39 | #| |
| 40 | SUBSTITUTION | |
| 40 | SUBSTITUTION | |
| 41 | 41 | -------------------------------------------------------------------------------- |
| 42 | 42 | A substitution is a map from variables to terms. Any mapping \sigma of variables |
| 43 | 43 | to terms extends to a substitution by defining \sigma(f(t1,...,tn)) to be |
| 71 | 71 | ;;; |
| 72 | 72 | (defmacro substitution-copy (_sigma) |
| 73 | 73 | ` (mapcar #'(lambda (map) |
| 74 | (cons (car map) (cdr map))) | |
| 75 | ,_sigma)) | |
| 74 | (cons (car map) (cdr map))) | |
| 75 | ,_sigma)) | |
| 76 | 76 | |
| 77 | 77 | ;;; SUBSTITUTION-IS-EMPTY sigma |
| 78 | 78 | ;;; Returns t iff \sigma is an empty substitution- |
| 114 | 114 | (defmacro substitution-delete (sigma!_ variable!_) |
| 115 | 115 | (once-only (sigma!_) |
| 116 | 116 | ` (progn (setf ,sigma!_ |
| 117 | (delete ,variable!_ ,sigma!_ :test #'variable-eq)) | |
| 118 | ,sigma!_))) | |
| 117 | (delete ,variable!_ ,sigma!_ :test #'variable-eq)) | |
| 118 | ,sigma!_))) | |
| 119 | 119 | |
| 120 | 120 | ;;; SUBSTITUTION-CHANGE sigma variable term |
| 121 | 121 | ;;; change the mapping of variable to term. |
| 125 | 125 | (defmacro substitution-change (?__sigma ?__variable ?__term) |
| 126 | 126 | (once-only (?__sigma ?__variable ?__term) |
| 127 | 127 | ` (let ((binding (assoc-in-substitution ,?__variable ,?__sigma))) |
| 128 | (if binding | |
| 129 | (setf (cdr binding) ,?__term) | |
| 130 | (push (cons variable ,?__term) ?__sigma)) | |
| 131 | ,?__sigma))) | |
| 128 | (if binding | |
| 129 | (setf (cdr binding) ,?__term) | |
| 130 | (push (cons variable ,?__term) ?__sigma)) | |
| 131 | ,?__sigma))) | |
| 132 | 132 | |
| 133 | 133 | ;;; SUBSTITUTION-SET sigma variable term |
| 134 | 134 | ;;; Changes sigma to map v to term. |
| 137 | 137 | (once-only (?_?sigma ?_?v ?_?term) |
| 138 | 138 | `(progn |
| 139 | 139 | (if (variable-eq ,?_?v ,?_?term) |
| 140 | (substitution-delete ,?_?sigma ,?_?v) | |
| 141 | (substitution-change ,?_?sigma ,?_?v ,?_?term)) | |
| 140 | (substitution-delete ,?_?sigma ,?_?v) | |
| 141 | (substitution-change ,?_?sigma ,?_?v ,?_?term)) | |
| 142 | 142 | ,?_?sigma))) |
| 143 | 143 | |
| 144 | 144 | ;;; CANONICALIZE-SUBSTITUTION : substitution -> substitution |
| 145 | 145 | ;;; |
| 146 | 146 | (defun canonicalize-substitution (s) |
| 147 | 147 | (declare (type list s) |
| 148 | (values list)) | |
| 149 | (sort (copy-list s) ; (substitution-copy s) | |
| 150 | #'(lambda (x y) ; two substitution items (var . term) | |
| 151 | (string< (the simple-string (string (variable-name (car x)))) | |
| 152 | (the simple-string (string (variable-name (car y)))))))) | |
| 148 | (values list)) | |
| 149 | (sort (copy-list s) ; (substitution-copy s) | |
| 150 | #'(lambda (x y) ; two substitution items (var . term) | |
| 151 | (string< (the simple-string (string (variable-name (car x)))) | |
| 152 | (the simple-string (string (variable-name (car y)))))))) | |
| 153 | 153 | |
| 154 | 154 | |
| 155 | 155 | ;;; SUBSTITUTION-EQUAL : substitution1 substitution2 -> Bool |
| 156 | 156 | ;;; |
| 157 | 157 | (defun substitution-equal (s1 s2) |
| 158 | 158 | (declare (type list s1 s2) |
| 159 | (values (or null t))) | |
| 159 | (values (or null t))) | |
| 160 | 160 | (every2len #'(lambda (x y) |
| 161 | (and (variable= (the term (car x)) (the term (car y))) | |
| 162 | (term-is-similar? (the term (cdr x)) (the term (cdr y))))) | |
| 163 | s1 s2)) | |
| 161 | (and (variable= (the term (car x)) (the term (car y))) | |
| 162 | (term-is-similar? (the term (cdr x)) (the term (cdr y))))) | |
| 163 | s1 s2)) | |
| 164 | 164 | |
| 165 | 165 | ;;; SUBSTITUTION-RESTRICT : list-of-variables substitution -> substitution |
| 166 | 166 | ;;; |
| 167 | 167 | (defun substitution-restrict (vars sub) |
| 168 | 168 | (declare (type list vars sub) |
| 169 | (values list)) | |
| 169 | (values list)) | |
| 170 | 170 | (let ((res nil)) |
| 171 | 171 | (dolist (s sub) |
| 172 | 172 | (when (member (car s) vars) |
| 173 | (push s res))) | |
| 173 | (push s res))) | |
| 174 | 174 | res)) |
| 175 | 175 | |
| 176 | 176 | ;;; SUBSTITUTION-SUBSET substitution-1 substitution-2 : -> bool |
| 180 | 180 | (defun substitution-subset (s1 s2) |
| 181 | 181 | (declare (type list s1 s2)) |
| 182 | 182 | (substitution-subset-list (substitution-list-of-pairs s1) |
| 183 | (substitution-list-of-pairs s2))) | |
| 183 | (substitution-list-of-pairs s2))) | |
| 184 | 184 | (defun substitution-subset-list (s1 s2) |
| 185 | 185 | (declare (type list s1 s2) |
| 186 | (values (or null t))) | |
| 186 | (values (or null t))) | |
| 187 | 187 | (let ((s1x s1) |
| 188 | (s2x s2) | |
| 189 | (res t)) | |
| 188 | (s2x s2) | |
| 189 | (res t)) | |
| 190 | 190 | (loop (when (null s1x) (return)) |
| 191 | (let ((v1 (the term (caar s1x))) | |
| 192 | (t1 (the term (cdar s1x)))) | |
| 193 | (loop (when (null s2x) (setq res nil) (return)) | |
| 194 | (when (variable-eq v1 (caar s2x)) | |
| 195 | (if (term-is-similar? t1 (cdar s2x)) | |
| 196 | (progn (setq s2x (cdr s2x)) (return)) | |
| 197 | (progn (setq res nil) (return)))) | |
| 198 | (setq s2x (cdr s2x))) | |
| 199 | (when (null res) (return)) | |
| 200 | (setq s1x (cdr s1x)))) | |
| 191 | (let ((v1 (the term (caar s1x))) | |
| 192 | (t1 (the term (cdar s1x)))) | |
| 193 | (loop (when (null s2x) (setq res nil) (return)) | |
| 194 | (when (variable-eq v1 (caar s2x)) | |
| 195 | (if (term-is-similar? t1 (cdar s2x)) | |
| 196 | (progn (setq s2x (cdr s2x)) (return)) | |
| 197 | (progn (setq res nil) (return)))) | |
| 198 | (setq s2x (cdr s2x))) | |
| 199 | (when (null res) (return)) | |
| 200 | (setq s1x (cdr s1x)))) | |
| 201 | 201 | res)) |
| 202 | 202 | |
| 203 | 203 | |
| 247 | 247 | ;;; |
| 248 | 248 | (defun substitution-image (sigma term) |
| 249 | 249 | (declare (type list sigma) |
| 250 | (type term term)) | |
| 250 | (type term term)) | |
| 251 | 251 | (let ((*consider-object* t)) |
| 252 | 252 | (cond ((term-is-variable? term) |
| 253 | (let ((im (variable-image sigma term))) | |
| 254 | (if im;; i.e. im = sigma(term) | |
| 255 | (values im nil) | |
| 256 | (values term t)))) | |
| 257 | ((term-is-lisp-form? term) | |
| 258 | (multiple-value-bind (new-term success) | |
| 259 | (funcall (lisp-form-function term) sigma) | |
| 260 | (if success | |
| 261 | new-term | |
| 262 | (throw 'rule-failure :fail-builtin)))) | |
| 263 | ((term-is-chaos-expr? term) | |
| 264 | (multiple-value-bind (new-term success) | |
| 265 | (funcall (chaos-form-expr term) sigma) | |
| 266 | (if success | |
| 267 | new-term | |
| 268 | (throw 'fule-failure :fail-builtin)))) | |
| 269 | ((term-is-builtin-constant? term) | |
| 270 | term) ; shold we copy? | |
| 271 | (t (let ((l-result nil) | |
| 272 | (modif-sort nil)) | |
| 273 | (dolist (s-t (term-subterms term)) | |
| 274 | (multiple-value-bind (image-s-t same-sort) | |
| 275 | (substitution-image sigma s-t) | |
| 276 | (unless same-sort (setq modif-sort t)) | |
| 277 | (push image-s-t l-result))) | |
| 278 | (setq l-result (nreverse l-result)) | |
| 279 | (if modif-sort | |
| 280 | (let ((term-image (make-term-with-sort-check (term-head term) | |
| 281 | l-result))) | |
| 282 | (values term-image | |
| 283 | (sort= (term-sort term) | |
| 284 | (term-sort term-image)))) | |
| 285 | (values (make-applform (term-sort term) | |
| 286 | (term-head term) | |
| 287 | l-result) | |
| 288 | t))))))) | |
| 253 | (let ((im (variable-image sigma term))) | |
| 254 | (if im;; i.e. im = sigma(term) | |
| 255 | (values im nil) | |
| 256 | (values term t)))) | |
| 257 | ((term-is-lisp-form? term) | |
| 258 | (multiple-value-bind (new-term success) | |
| 259 | (funcall (lisp-form-function term) sigma) | |
| 260 | (if success | |
| 261 | new-term | |
| 262 | (throw 'rule-failure :fail-builtin)))) | |
| 263 | ((term-is-chaos-expr? term) | |
| 264 | (multiple-value-bind (new-term success) | |
| 265 | (funcall (chaos-form-expr term) sigma) | |
| 266 | (if success | |
| 267 | new-term | |
| 268 | (throw 'fule-failure :fail-builtin)))) | |
| 269 | ((term-is-builtin-constant? term) | |
| 270 | term) ; shold we copy? | |
| 271 | (t (let ((l-result nil) | |
| 272 | (modif-sort nil)) | |
| 273 | (dolist (s-t (term-subterms term)) | |
| 274 | (multiple-value-bind (image-s-t same-sort) | |
| 275 | (substitution-image sigma s-t) | |
| 276 | (unless same-sort (setq modif-sort t)) | |
| 277 | (push image-s-t l-result))) | |
| 278 | (setq l-result (nreverse l-result)) | |
| 279 | (if modif-sort | |
| 280 | (let ((term-image (make-term-with-sort-check (term-head term) | |
| 281 | l-result))) | |
| 282 | (values term-image | |
| 283 | (sort= (term-sort term) | |
| 284 | (term-sort term-image)))) | |
| 285 | (values (make-applform (term-sort term) | |
| 286 | (term-head term) | |
| 287 | l-result) | |
| 288 | t))))))) | |
| 289 | 289 | |
| 290 | 290 | (defun substitution-image! (sigma term) |
| 291 | 291 | (declare (type list sigma) |
| 292 | (type term term)) | |
| 292 | (type term term)) | |
| 293 | 293 | (let ((*consider-object* t)) |
| 294 | 294 | (cond ((term-is-variable? term) |
| 295 | (let ((im (variable-image-slow sigma term))) | |
| 296 | (if im;; i.e. im = sigma(term) | |
| 297 | (values im nil) | |
| 298 | (values term t)))) | |
| 299 | ((term-is-lisp-form? term) | |
| 300 | (multiple-value-bind (new-term success) | |
| 301 | (funcall (lisp-form-function term) sigma) | |
| 302 | (if success | |
| 303 | new-term | |
| 304 | (throw 'rule-failure :fail-builtin)))) | |
| 305 | ((term-is-chaos-expr? term) | |
| 306 | (multiple-value-bind (new-term success) | |
| 307 | (funcall (chaos-form-expr term) sigma) | |
| 308 | (if success | |
| 309 | new-term | |
| 310 | (throw 'fule-failure :fail-builtin)))) | |
| 311 | ((term-is-builtin-constant? term) term) ; shold we copy? | |
| 312 | (t (let ((l-result nil) | |
| 313 | (modif-sort nil)) | |
| 314 | (dolist (s-t (term-subterms term)) | |
| 315 | (multiple-value-bind (image-s-t same-sort) | |
| 316 | (substitution-image! sigma s-t) | |
| 317 | (unless same-sort (setq modif-sort t)) | |
| 318 | (push image-s-t l-result))) | |
| 319 | (setq l-result (nreverse l-result)) | |
| 320 | (if modif-sort | |
| 321 | (let ((term-image (make-term-with-sort-check (term-head term) | |
| 322 | l-result))) | |
| 323 | (values term-image | |
| 324 | (sort= (term-sort term) | |
| 325 | (term-sort term-image)))) | |
| 326 | (values (make-applform (term-sort term) | |
| 327 | (term-head term) | |
| 328 | l-result) | |
| 329 | t))))))) | |
| 295 | (let ((im (variable-image-slow sigma term))) | |
| 296 | (if im;; i.e. im = sigma(term) | |
| 297 | (values im nil) | |
| 298 | (values term t)))) | |
| 299 | ((term-is-lisp-form? term) | |
| 300 | (multiple-value-bind (new-term success) | |
| 301 | (funcall (lisp-form-function term) sigma) | |
| 302 | (if success | |
| 303 | new-term | |
| 304 | (throw 'rule-failure :fail-builtin)))) | |
| 305 | ((term-is-chaos-expr? term) | |
| 306 | (multiple-value-bind (new-term success) | |
| 307 | (funcall (chaos-form-expr term) sigma) | |
| 308 | (if success | |
| 309 | new-term | |
| 310 | (throw 'fule-failure :fail-builtin)))) | |
| 311 | ((term-is-builtin-constant? term) term) ; shold we copy? | |
| 312 | (t (let ((l-result nil) | |
| 313 | (modif-sort nil)) | |
| 314 | (dolist (s-t (term-subterms term)) | |
| 315 | (multiple-value-bind (image-s-t same-sort) | |
| 316 | (substitution-image! sigma s-t) | |
| 317 | (unless same-sort (setq modif-sort t)) | |
| 318 | (push image-s-t l-result))) | |
| 319 | (setq l-result (nreverse l-result)) | |
| 320 | (if modif-sort | |
| 321 | (let ((term-image (make-term-with-sort-check (term-head term) | |
| 322 | l-result))) | |
| 323 | (values term-image | |
| 324 | (sort= (term-sort term) | |
| 325 | (term-sort term-image)))) | |
| 326 | (values (make-applform (term-sort term) | |
| 327 | (term-head term) | |
| 328 | l-result) | |
| 329 | t))))))) | |
| 330 | 330 | |
| 331 | 331 | (defun substitution-image-cp (sigma term) |
| 332 | 332 | (declare (type list sigma) |
| 333 | (type term term)) | |
| 333 | (type term term)) | |
| 334 | 334 | (let ((*consider-object* t)) |
| 335 | 335 | (cond ((term-is-variable? term) |
| 336 | (let ((im (variable-image sigma term))) | |
| 337 | (if im;; i.e. im = sigma(term) | |
| 338 | ;; (values (simple-copy-term im) nil) | |
| 339 | (values im nil) | |
| 340 | (values term t)))) | |
| 341 | ((term-is-lisp-form? term) | |
| 342 | (multiple-value-bind (new-term success) | |
| 343 | (funcall (lisp-form-function term) sigma) | |
| 344 | (if success | |
| 345 | new-term | |
| 346 | (throw 'rule-failure :fail-builtin)))) | |
| 347 | ((term-is-chaos-expr? term) | |
| 348 | (multiple-value-bind (new-term success) | |
| 349 | (funcall (chaos-form-expr term) sigma) | |
| 350 | (if success | |
| 351 | new-term | |
| 352 | (throw 'fule-failure :fail-builtin)))) | |
| 353 | ((term-is-builtin-constant? term) term) ; shold we copy? | |
| 354 | (t (let ((l-result nil) | |
| 355 | (modif-sort nil)) | |
| 356 | (dolist (s-t (term-subterms term)) | |
| 357 | (multiple-value-bind (image-s-t same-sort) | |
| 358 | (substitution-image-cp sigma s-t) | |
| 359 | (unless same-sort (setq modif-sort t)) | |
| 360 | (push image-s-t l-result))) | |
| 361 | (setq l-result (nreverse l-result)) | |
| 362 | (if modif-sort | |
| 363 | (let ((term-image (make-term-with-sort-check (term-head term) | |
| 364 | l-result))) | |
| 365 | (values term-image | |
| 366 | (sort= (term-sort term) | |
| 367 | (term-sort term-image)))) | |
| 368 | (values (make-applform (term-sort term) | |
| 369 | (term-head term) | |
| 370 | l-result) | |
| 371 | t))))))) | |
| 336 | (let ((im (variable-image sigma term))) | |
| 337 | (if im;; i.e. im = sigma(term) | |
| 338 | ;; (values (simple-copy-term im) nil) | |
| 339 | (values im nil) | |
| 340 | (values term t)))) | |
| 341 | ((term-is-lisp-form? term) | |
| 342 | (multiple-value-bind (new-term success) | |
| 343 | (funcall (lisp-form-function term) sigma) | |
| 344 | (if success | |
| 345 | new-term | |
| 346 | (throw 'rule-failure :fail-builtin)))) | |
| 347 | ((term-is-chaos-expr? term) | |
| 348 | (multiple-value-bind (new-term success) | |
| 349 | (funcall (chaos-form-expr term) sigma) | |
| 350 | (if success | |
| 351 | new-term | |
| 352 | (throw 'fule-failure :fail-builtin)))) | |
| 353 | ((term-is-builtin-constant? term) term) ; shold we copy? | |
| 354 | (t (let ((l-result nil) | |
| 355 | (modif-sort nil)) | |
| 356 | (dolist (s-t (term-subterms term)) | |
| 357 | (multiple-value-bind (image-s-t same-sort) | |
| 358 | (substitution-image-cp sigma s-t) | |
| 359 | (unless same-sort (setq modif-sort t)) | |
| 360 | (push image-s-t l-result))) | |
| 361 | (setq l-result (nreverse l-result)) | |
| 362 | (if modif-sort | |
| 363 | (let ((term-image (make-term-with-sort-check (term-head term) | |
| 364 | l-result))) | |
| 365 | (values term-image | |
| 366 | (sort= (term-sort term) | |
| 367 | (term-sort term-image)))) | |
| 368 | (values (make-applform (term-sort term) | |
| 369 | (term-head term) | |
| 370 | l-result) | |
| 371 | t))))))) | |
| 372 | 372 | |
| 373 | 373 | (defun substitution-check-built-in (trm) trm) |
| 374 | 374 | |
| 377 | 377 | (defun substitution-compose (teta lisp-term) |
| 378 | 378 | (declare (type list teta lisp-term)) |
| 379 | 379 | (let ((fcn (lisp-form-function lisp-term)) |
| 380 | (new-fun nil) | |
| 381 | (new-term nil)) | |
| 380 | (new-fun nil) | |
| 381 | (new-term nil)) | |
| 382 | 382 | (if (or #-CMU(typep fcn 'compiled-function) |
| 383 | #+CMU(typep fcn 'function) | |
| 384 | (not (and (consp fcn) (eq 'lambda (car fcn)) | |
| 385 | (equal '(compn) (cadr fcn))))) | |
| 386 | (setf new-fun | |
| 387 | `(lambda (compn) (funcall ',fcn (append ',teta compn)))) | |
| 388 | (let ((oldteta (cadr (nth 1 (nth 2 (nth 2 fcn))))) | |
| 389 | (realfcn (cadr (nth 1 (nth 2 fcn))))) | |
| 390 | (setf new-fun | |
| 391 | `(lambda (compn) | |
| 392 | (funcall ',realfcn (append ',(append teta oldteta) compn)))))) | |
| 383 | #+CMU(typep fcn 'function) | |
| 384 | (not (and (consp fcn) (eq 'lambda (car fcn)) | |
| 385 | (equal '(compn) (cadr fcn))))) | |
| 386 | (setf new-fun | |
| 387 | `(lambda (compn) (funcall ',fcn (append ',teta compn)))) | |
| 388 | (let ((oldteta (cadr (nth 1 (nth 2 (nth 2 fcn))))) | |
| 389 | (realfcn (cadr (nth 1 (nth 2 fcn))))) | |
| 390 | (setf new-fun | |
| 391 | `(lambda (compn) | |
| 392 | (funcall ',realfcn (append ',(append teta oldteta) compn)))))) | |
| 393 | 393 | (if (term-is-simple-lisp-form? lisp-term) |
| 394 | (setf new-term (make-simple-lisp-form-term (lisp-form-original-form lisp-term))) | |
| 395 | (setf new-term (make-general-lisp-form-term (lisp-form-original-form lisp-term)))) | |
| 394 | (setf new-term (make-simple-lisp-form-term (lisp-form-original-form lisp-term))) | |
| 395 | (setf new-term (make-general-lisp-form-term (lisp-form-original-form lisp-term)))) | |
| 396 | 396 | (setf (lisp-form-function new-term) new-fun) |
| 397 | 397 | new-term)) |
| 398 | 398 | |
| 399 | 399 | (defun substitution-compose-chaos (teta chaos-expr) |
| 400 | 400 | (declare (type list teta chaos-expr)) |
| 401 | 401 | (let ((fcn (chaos-form-expr chaos-expr)) |
| 402 | (new-fun nil) | |
| 403 | (new-term nil)) | |
| 402 | (new-fun nil) | |
| 403 | (new-term nil)) | |
| 404 | 404 | (if (or #-CMU(typep fcn 'compiled-function) |
| 405 | #+CMU(typep fcn 'function) | |
| 406 | (not (and (consp fcn) (eq 'lambda (car fcn)) | |
| 407 | (equal '(compn) (cadr fcn))))) | |
| 408 | (setf new-fun | |
| 409 | `(lambda (compn) (funcall ',fcn (append ',teta compn)))) | |
| 405 | #+CMU(typep fcn 'function) | |
| 406 | (not (and (consp fcn) (eq 'lambda (car fcn)) | |
| 407 | (equal '(compn) (cadr fcn))))) | |
| 408 | (setf new-fun | |
| 409 | `(lambda (compn) (funcall ',fcn (append ',teta compn)))) | |
| 410 | 410 | (let ((oldteta (cadr (nth 1 (nth 2 (nth 2 fcn))))) |
| 411 | (realfcn (cadr (nth 1 (nth 2 fcn))))) | |
| 412 | (setf new-fun | |
| 413 | `(lambda (compn) | |
| 414 | (funcall ',realfcn (append ',(append teta oldteta) compn)))))) | |
| 411 | (realfcn (cadr (nth 1 (nth 2 fcn))))) | |
| 412 | (setf new-fun | |
| 413 | `(lambda (compn) | |
| 414 | (funcall ',realfcn (append ',(append teta oldteta) compn)))))) | |
| 415 | 415 | (setf new-term (make-bconst-term *chaos-value-sort* |
| 416 | (list '|%Chaos| | |
| 417 | new-fun | |
| 418 | (chaos-original-expr chaos-expr)))) | |
| 416 | (list '|%Chaos| | |
| 417 | new-fun | |
| 418 | (chaos-original-expr chaos-expr)))) | |
| 419 | 419 | new-term)) |
| 420 | 420 | |
| 421 | 421 | ;;; SUBSTITUTION-IMAGE* sigma term |
| 431 | 431 | ;; NO COPY of Term is done. |
| 432 | 432 | (defun substitution-image-no-copy (sigma term) |
| 433 | 433 | (declare (type list sigma) |
| 434 | (type term term) | |
| 435 | (values t)) | |
| 434 | (type term term) | |
| 435 | (values t)) | |
| 436 | 436 | (let ((im nil)) |
| 437 | 437 | (cond ((term-is-variable? term) |
| 438 | (when (setq im (variable-image sigma term)) | |
| 439 | (term-replace term im))) | |
| 440 | ((term-is-constant? term) ) ;; do nothing | |
| 441 | (t (dolist (s-t (term-subterms term)) | |
| 442 | (substitution-image-no-copy sigma s-t)))))) | |
| 438 | (when (setq im (variable-image sigma term)) | |
| 439 | (term-replace term im))) | |
| 440 | ((term-is-constant? term) ) ;; do nothing | |
| 441 | (t (dolist (s-t (term-subterms term)) | |
| 442 | (substitution-image-no-copy sigma s-t)))))) | |
| 443 | 443 | |
| 444 | 444 | (defun substitution-partial-image (sigma term) |
| 445 | 445 | (declare (type list sigma) |
| 446 | (type term term)) | |
| 446 | (type term term)) | |
| 447 | 447 | (let ((*consider-object* t)) |
| 448 | 448 | (cond ((term-is-variable? term) |
| 449 | (let ((im (variable-image sigma term))) | |
| 450 | (if im | |
| 451 | (values im nil) | |
| 452 | (values term t)))) | |
| 453 | ((term-is-lisp-form? term) | |
| 454 | (substitution-compose sigma term) | |
| 455 | ) | |
| 456 | ((term-is-chaos-expr? term) | |
| 457 | (substitution-compose-chaos sigma term)) | |
| 458 | ((term-is-builtin-constant? term) term) | |
| 459 | ((term-is-applform? term) | |
| 460 | (let ((l-result nil) (modif-sort nil)) | |
| 461 | (dolist (s-t (term-subterms term)) | |
| 462 | (multiple-value-bind (image-s-t same-sort) | |
| 463 | (substitution-partial-image sigma s-t) | |
| 464 | (unless same-sort (setq modif-sort t)) | |
| 465 | (push image-s-t l-result))) | |
| 466 | (setq l-result (nreverse l-result)) | |
| 467 | (if modif-sort | |
| 468 | (let ((term-image (make-term-with-sort-check | |
| 469 | (term-head term) | |
| 470 | l-result))) | |
| 471 | (values term-image | |
| 472 | (sort= (term-sort term) | |
| 473 | (term-sort term-image)))) | |
| 474 | (values (make-applform (term-sort term) (term-head term) l-result) | |
| 475 | t)))) | |
| 476 | (t (break "substution-partial-image : not implemented ~s" term)) | |
| 477 | ))) | |
| 449 | (let ((im (variable-image sigma term))) | |
| 450 | (if im | |
| 451 | (values im nil) | |
| 452 | (values term t)))) | |
| 453 | ((term-is-lisp-form? term) | |
| 454 | (substitution-compose sigma term) | |
| 455 | ) | |
| 456 | ((term-is-chaos-expr? term) | |
| 457 | (substitution-compose-chaos sigma term)) | |
| 458 | ((term-is-builtin-constant? term) term) | |
| 459 | ((term-is-applform? term) | |
| 460 | (let ((l-result nil) (modif-sort nil)) | |
| 461 | (dolist (s-t (term-subterms term)) | |
| 462 | (multiple-value-bind (image-s-t same-sort) | |
| 463 | (substitution-partial-image sigma s-t) | |
| 464 | (unless same-sort (setq modif-sort t)) | |
| 465 | (push image-s-t l-result))) | |
| 466 | (setq l-result (nreverse l-result)) | |
| 467 | (if modif-sort | |
| 468 | (let ((term-image (make-term-with-sort-check | |
| 469 | (term-head term) | |
| 470 | l-result))) | |
| 471 | (values term-image | |
| 472 | (sort= (term-sort term) | |
| 473 | (term-sort term-image)))) | |
| 474 | (values (make-applform (term-sort term) (term-head term) l-result) | |
| 475 | t)))) | |
| 476 | (t (break "substution-partial-image : not implemented ~s" term)) | |
| 477 | ))) | |
| 478 | 478 | |
| 479 | 479 | (defun substitution-image-simplifying (sigma term &optional (cp nil) (slow-map nil)) |
| 480 | 480 | (declare (type list sigma) |
| 481 | (type term)) | |
| 481 | (type term)) | |
| 482 | 482 | (let ((*consider-object* t)) |
| 483 | 483 | ;; (setq subst-debug-term term) |
| 484 | 484 | (cond ((term-is-variable? term) |
| 485 | (let ((im (if slow-map | |
| 486 | (variable-image-slow sigma term) | |
| 487 | (variable-image sigma term)))) | |
| 488 | (if im | |
| 489 | (values (if cp | |
| 490 | (progn | |
| 491 | ;; debug | |
| 492 | ;; (format t "~©ing " (term-print im)) | |
| 493 | (simple-copy-term im)) | |
| 494 | im) | |
| 495 | (sort= (variable-sort term) | |
| 496 | (term-sort im))) | |
| 497 | (values term t)))) | |
| 498 | ((term-is-chaos-expr? term) | |
| 499 | (when *rewrite-debug* | |
| 500 | (format t "CHAOS: ~S" (chaos-form-expr term))) | |
| 501 | (multiple-value-bind (new-term success) | |
| 502 | (funcall (chaos-form-expr term) sigma) | |
| 503 | (if success | |
| 504 | new-term | |
| 505 | (throw 'fule-failure :fail-builtin)))) | |
| 506 | ((term-is-builtin-constant? term) term) | |
| 507 | ((term-is-lisp-form? term) | |
| 508 | (multiple-value-bind (new success) | |
| 509 | (funcall (lisp-form-function term) sigma) | |
| 510 | (if success | |
| 511 | new | |
| 512 | (throw 'rule-failure :fail-builtin)))) | |
| 513 | ((term-is-applform? term) | |
| 514 | (let ((l-result nil) | |
| 515 | (modif-sort nil)) | |
| 516 | (dolist (s-t (term-subterms term)) | |
| 517 | (multiple-value-bind (image-s-t same-sort) | |
| 518 | (substitution-image-simplifying sigma s-t cp) | |
| 519 | (unless same-sort (setq modif-sort t)) | |
| 520 | (push image-s-t l-result))) | |
| 521 | (setq l-result (nreverse l-result)) | |
| 522 | (let ((method (term-head term))) | |
| 523 | (if (and (cdr l-result) | |
| 524 | (null (cddr l-result)) | |
| 525 | (method-is-identity method)) | |
| 526 | ;; head operator is binary & has identity theory | |
| 527 | (if (term-is-zero-for-method (car l-result) method) | |
| 528 | ;; ID * X --> X | |
| 529 | ;; simplify for left identity. | |
| 530 | (values (cadr l-result) | |
| 531 | (sort= (term-sort term) | |
| 532 | (term-sort (cadr l-result)))) | |
| 533 | ;; X * ID --> X | |
| 534 | (if (term-is-zero-for-method (cadr l-result) method) | |
| 535 | (values (car l-result) | |
| 536 | (sort= (term-sort term) | |
| 537 | (term-sort (car l-result)))) | |
| 538 | ;; X * Y | |
| 539 | (if modif-sort | |
| 540 | (let ((term-image (make-term-with-sort-check | |
| 541 | method l-result))) | |
| 542 | (values term-image | |
| 543 | (sort= (term-sort term) | |
| 544 | (term-sort term-image)))) | |
| 545 | (values (make-applform (term-sort term) | |
| 546 | method l-result) | |
| 547 | t) ; sort not changed | |
| 548 | ))) ; done for zero cases | |
| 549 | ;; This is the same as the previous bit of code | |
| 550 | (if modif-sort | |
| 551 | (let ((term-image (make-term-with-sort-check method | |
| 552 | l-result))) | |
| 553 | (values term-image | |
| 554 | (sort= (term-sort term) (term-sort term-image)))) | |
| 555 | (values (make-applform (method-coarity method) | |
| 556 | method l-result) | |
| 557 | t)))))) | |
| 558 | (t (break "not implemented yet")) ))) | |
| 485 | (let ((im (if slow-map | |
| 486 | (variable-image-slow sigma term) | |
| 487 | (variable-image sigma term)))) | |
| 488 | (if im | |
| 489 | (values (if cp | |
| 490 | (progn | |
| 491 | ;; debug | |
| 492 | ;; (format t "~©ing " (term-print im)) | |
| 493 | (simple-copy-term im)) | |
| 494 | im) | |
| 495 | (sort= (variable-sort term) | |
| 496 | (term-sort im))) | |
| 497 | (values term t)))) | |
| 498 | ((term-is-chaos-expr? term) | |
| 499 | (when *rewrite-debug* | |
| 500 | (format t "CHAOS: ~S" (chaos-form-expr term))) | |
| 501 | (multiple-value-bind (new-term success) | |
| 502 | (funcall (chaos-form-expr term) sigma) | |
| 503 | (if success | |
| 504 | new-term | |
| 505 | (throw 'fule-failure :fail-builtin)))) | |
| 506 | ((term-is-builtin-constant? term) term) | |
| 507 | ((term-is-lisp-form? term) | |
| 508 | (multiple-value-bind (new success) | |
| 509 | (funcall (lisp-form-function term) sigma) | |
| 510 | (if success | |
| 511 | new | |
| 512 | (throw 'rule-failure :fail-builtin)))) | |
| 513 | ((term-is-applform? term) | |
| 514 | (let ((l-result nil) | |
| 515 | (modif-sort nil)) | |
| 516 | (dolist (s-t (term-subterms term)) | |
| 517 | (multiple-value-bind (image-s-t same-sort) | |
| 518 | (substitution-image-simplifying sigma s-t cp) | |
| 519 | (unless same-sort (setq modif-sort t)) | |
| 520 | (push image-s-t l-result))) | |
| 521 | (setq l-result (nreverse l-result)) | |
| 522 | (let ((method (term-head term))) | |
| 523 | (if (and (cdr l-result) | |
| 524 | (null (cddr l-result)) | |
| 525 | (method-is-identity method)) | |
| 526 | ;; head operator is binary & has identity theory | |
| 527 | (if (term-is-zero-for-method (car l-result) method) | |
| 528 | ;; ID * X --> X | |
| 529 | ;; simplify for left identity. | |
| 530 | (values (cadr l-result) | |
| 531 | (sort= (term-sort term) | |
| 532 | (term-sort (cadr l-result)))) | |
| 533 | ;; X * ID --> X | |
| 534 | (if (term-is-zero-for-method (cadr l-result) method) | |
| 535 | (values (car l-result) | |
| 536 | (sort= (term-sort term) | |
| 537 | (term-sort (car l-result)))) | |
| 538 | ;; X * Y | |
| 539 | (if modif-sort | |
| 540 | (let ((term-image (make-term-with-sort-check | |
| 541 | method l-result))) | |
| 542 | (values term-image | |
| 543 | (sort= (term-sort term) | |
| 544 | (term-sort term-image)))) | |
| 545 | (values (make-applform (term-sort term) | |
| 546 | method l-result) | |
| 547 | t) ; sort not changed | |
| 548 | ))) ; done for zero cases | |
| 549 | ;; This is the same as the previous bit of code | |
| 550 | (if modif-sort | |
| 551 | (let ((term-image (make-term-with-sort-check method | |
| 552 | l-result))) | |
| 553 | (values term-image | |
| 554 | (sort= (term-sort term) (term-sort term-image)))) | |
| 555 | (values (make-applform (method-coarity method) | |
| 556 | method l-result) | |
| 557 | t)))))) | |
| 558 | (t (break "not implemented yet")) ))) | |
| 559 | 559 | |
| 560 | 560 | ;;; CANONICALIZE-SUBSTITUTION |
| 561 | 561 | ;;; |
| 562 | 562 | (defun substitution-can (s) |
| 563 | 563 | (declare (type list s) |
| 564 | (values list)) | |
| 564 | (values list)) | |
| 565 | 565 | (sort (copy-list s) |
| 566 | #'(lambda (x y) ;two substitution items (var . term) | |
| 567 | (declare (type list x y)) | |
| 568 | (string< (the simple-string (string (variable-name (car x)))) | |
| 569 | (the simple-string (string (variable-name (car y))))) | |
| 570 | ))) | |
| 566 | #'(lambda (x y) ;two substitution items (var . term) | |
| 567 | (declare (type list x y)) | |
| 568 | (string< (the simple-string (string (variable-name (car x)))) | |
| 569 | (the simple-string (string (variable-name (car y))))) | |
| 570 | ))) | |
| 571 | 571 | |
| 572 | 572 | ;;; |
| 573 | 573 | (defun substitution-simple-image (teta term) |
| 574 | 574 | (declare (type list teta) |
| 575 | (type term term)) | |
| 575 | (type term term)) | |
| 576 | 576 | (macrolet ((assoc% (_?x _?y) |
| 577 | `(let ((lst$$ ,_?y)) | |
| 578 | (loop | |
| 579 | (when (null lst$$) (return nil)) | |
| 580 | (when (eq ,_?x (caar lst$$)) (return (car lst$$))) | |
| 581 | (setq lst$$ (cdr lst$$)))))) | |
| 577 | `(let ((lst$$ ,_?y)) | |
| 578 | (loop | |
| 579 | (when (null lst$$) (return nil)) | |
| 580 | (when (eq ,_?x (caar lst$$)) (return (car lst$$))) | |
| 581 | (setq lst$$ (cdr lst$$)))))) | |
| 582 | 582 | (cond ((term-is-variable? term) |
| 583 | (let ((im (cdr (assoc% term teta)))) | |
| 584 | (if im im term))) | |
| 585 | ((term-is-builtin-constant? term) | |
| 586 | (make-bconst-term (term-sort term) | |
| 587 | (term-builtin-value term))) | |
| 588 | (t (make-applform (method-coarity (term-head term)) | |
| 589 | (term-head term) | |
| 590 | (mapcar #'(lambda (stm) | |
| 591 | (substitution-simple-image teta stm)) | |
| 592 | (term-subterms term))))))) | |
| 583 | (let ((im (cdr (assoc% term teta)))) | |
| 584 | (if im im term))) | |
| 585 | ((term-is-builtin-constant? term) | |
| 586 | (make-bconst-term (term-sort term) | |
| 587 | (term-builtin-value term))) | |
| 588 | (t (make-applform (method-coarity (term-head term)) | |
| 589 | (term-head term) | |
| 590 | (mapcar #'(lambda (stm) | |
| 591 | (substitution-simple-image teta stm)) | |
| 592 | (term-subterms term))))))) | |
| 593 | 593 | ;;; EOF |
| 0 | 0 | ;;;-*- Mode: Lisp; Syntax:CommonLisp; Package:CHAOS; Base:10 -*- |
| 1 | 1 | ;;; |
| 2 | ;;; Copyright (c) 2000-2014, Toshimi Sawada. All rights reserved. | |
| 2 | ;;; Copyright (c) 2000-2015, Toshimi Sawada. All rights reserved. | |
| 3 | 3 | ;;; |
| 4 | 4 | ;;; Redistribution and use in source and binary forms, with or without |
| 5 | 5 | ;;; modification, are permitted provided that the following conditions |
| 27 | 27 | ;;; |
| 28 | 28 | (in-package :chaos) |
| 29 | 29 | #|============================================================================= |
| 30 | System:CHAOS | |
| 31 | Module: primitives.chaos | |
| 32 | File: term-utils.lisp | |
| 30 | System:CHAOS | |
| 31 | Module: primitives.chaos | |
| 32 | File: term-utils.lisp | |
| 33 | 33 | =============================================================================|# |
| 34 | 34 | #-:chaos-debug |
| 35 | 35 | (declaim (optimize (speed 3) (safety 0) #-GCL (debug 0))) |
| 58 | 58 | |
| 59 | 59 | (defun make-applform (sort meth &optional args) |
| 60 | 60 | (declare (type sort* sort) |
| 61 | (type method meth) | |
| 62 | (type list args) | |
| 63 | (values term)) | |
| 64 | (if *consider-object* | |
| 65 | (if (method-is-object-constructor meth) | |
| 66 | (let ((id (car args)) ; the first argument is always an object | |
| 67 | ; identifier. | |
| 68 | (class sort)) | |
| 69 | #+:debug-term | |
| 70 | (progn | |
| 71 | (format t "~&object construction: ") | |
| 72 | (print-object meth) | |
| 73 | (force-output)) | |
| 74 | (if (not (term-is-variable? id)) ; non variable means the term | |
| 75 | ; denotes a concrete instance. | |
| 76 | (let ((instance nil)) | |
| 77 | (setf instance (find-instance id class)) | |
| 78 | (if instance | |
| 79 | (progn (setf (term-arg-3 instance) (third args)) | |
| 80 | instance) | |
| 81 | (progn (setf instance | |
| 82 | (make-applform-simple sort meth args)) | |
| 83 | (register-instance instance) | |
| 84 | instance))) | |
| 85 | (make-applform-simple sort meth args) | |
| 86 | )) | |
| 87 | (make-applform-simple sort meth args) ) | |
| 88 | (make-applform-simple sort meth args))) | |
| 61 | (type method meth) | |
| 62 | (type list args)) | |
| 63 | (make-applform-simple sort meth args)) | |
| 89 | 64 | |
| 90 | 65 | ;;; ****************** |
| 91 | 66 | ;;; RESET-REDUCED-FLAG |
| 93 | 68 | (defun reset-reduced-flag (term) |
| 94 | 69 | (declare (type term term)) |
| 95 | 70 | (when (or (term-is-builtin-constant? term) |
| 96 | (term-is-variable? term)) | |
| 71 | (term-is-variable? term)) | |
| 97 | 72 | (return-from reset-reduced-flag term)) |
| 98 | 73 | (mark-term-as-not-reduced term) |
| 99 | 74 | (when (term-is-application-form? term) |
| 110 | 85 | |
| 111 | 86 | (defun term-is-an-error (term) |
| 112 | 87 | (declare (type term term) |
| 113 | (values (or null t))) | |
| 88 | (values (or null t))) | |
| 114 | 89 | (and (term? term) |
| 115 | 90 | (let ((sort (term$sort (term-body term)))) |
| 116 | (and (not (sort= *bottom-sort* sort)) | |
| 117 | (sort<= sort *syntax-err-sort* *chaos-sort-order*))))) | |
| 118 | ||
| 119 | (eval-when (:execute :load-toplevel) ; synonym | |
| 91 | (and (not (sort= *bottom-sort* sort)) | |
| 92 | (sort<= sort *syntax-err-sort* *chaos-sort-order*))))) | |
| 93 | ||
| 94 | (eval-when (:execute :load-toplevel) ; synonym | |
| 120 | 95 | (setf (symbol-function 'term-ill-defined) |
| 121 | (symbol-function 'term-is-an-error))) | |
| 96 | (symbol-function 'term-is-an-error))) | |
| 122 | 97 | |
| 123 | 98 | ;;; Returns true iff the term is application form and has error-method |
| 124 | 99 | ;;; as its top. |
| 125 | 100 | ;;; |
| 126 | 101 | (defun term-head-is-error (tm) |
| 127 | 102 | (declare (type term tm) |
| 128 | (values (or null t))) | |
| 103 | (values (or null t))) | |
| 129 | 104 | (let ((body (term-body tm))) |
| 130 | 105 | (and (term$is-application-form? body) |
| 131 | (method-is-error-method (term$head body))))) | |
| 106 | (method-is-error-method (term$head body))))) | |
| 132 | 107 | |
| 133 | 108 | ;;; Returns true iff the term is application form and has user defined |
| 134 | 109 | ;;; error method as its top. |
| 135 | 110 | ;;; |
| 136 | 111 | (defun term-head-is-user-defined-error (tm) |
| 137 | 112 | (declare (type term tm) |
| 138 | (values (or null t))) | |
| 113 | (values (or null t))) | |
| 139 | 114 | (and (term-is-application-form? tm) |
| 140 | 115 | (method-is-user-defined-error-method (term-head tm)))) |
| 141 | 116 | |
| 148 | 123 | ;;; |
| 149 | 124 | (defun term-is-really-well-defined (term) |
| 150 | 125 | (declare (type term term) |
| 151 | (values (or null t))) | |
| 126 | (values (or null t))) | |
| 152 | 127 | (if (term-is-an-error term) |
| 153 | 128 | nil |
| 154 | 129 | (if (term-is-applform? term) |
| 155 | (if (method-is-error-method (term-head term)) | |
| 156 | nil | |
| 157 | (dolist (sub (term-subterms term) t) | |
| 158 | (unless (term-is-really-well-defined sub) | |
| 159 | (return nil)))) | |
| 160 | t))) | |
| 130 | (if (method-is-error-method (term-head term)) | |
| 131 | nil | |
| 132 | (dolist (sub (term-subterms term) t) | |
| 133 | (unless (term-is-really-well-defined sub) | |
| 134 | (return nil)))) | |
| 135 | t))) | |
| 161 | 136 | |
| 162 | 137 | ;;; creats ill-formed terms |
| 163 | 138 | ;;; |
| 164 | 139 | |
| 165 | 140 | (defun make-directly-ill-term (head subterms) |
| 166 | 141 | (declare (type method head) |
| 167 | (type list subterms) | |
| 168 | (values term)) | |
| 142 | (type list subterms) | |
| 143 | (values term)) | |
| 169 | 144 | (make-applform-simple *type-err-sort* head subterms)) |
| 170 | 145 | |
| 171 | 146 | (defun make-inheritedly-ill-term (head subterms) |
| 172 | 147 | (declare (type method head) |
| 173 | (type list subterms) | |
| 174 | (values term)) | |
| 148 | (type list subterms) | |
| 149 | (values term)) | |
| 175 | 150 | (make-applform-simple *type-err-sort* head subterms)) |
| 176 | 151 | |
| 177 | 152 | ;;; TERM-ERROR-OPERATORS&VARIABLES |
| 179 | 154 | ;;; |
| 180 | 155 | (defun term-error-operators&variables (term &optional vars-also) |
| 181 | 156 | (declare (type term term) |
| 182 | (type (or null t) vars-also) | |
| 183 | (values list)) | |
| 157 | (type (or null t) vars-also) | |
| 158 | (values list)) | |
| 184 | 159 | (let ((res (cons nil nil))) |
| 185 | 160 | (gather-error-methods-and-variables term res vars-also) |
| 186 | 161 | (car res))) |
| 187 | 162 | |
| 188 | 163 | (defun gather-error-methods-and-variables (term res vars-also) |
| 189 | 164 | (declare (type term term) |
| 190 | (type list res) | |
| 191 | (type (or null t) vars-also) | |
| 192 | (values list)) | |
| 165 | (type list res) | |
| 166 | (type (or null t) vars-also) | |
| 167 | (values list)) | |
| 193 | 168 | (if (term-is-application-form? term) |
| 194 | 169 | (let ((head (term-head term))) |
| 195 | (if (method-is-error-method head) | |
| 196 | (progn | |
| 197 | (pushnew head (car res) :test #'eq) | |
| 198 | (dolist (sub (term-subterms term)) | |
| 199 | (gather-error-methods-and-variables sub res vars-also))) | |
| 200 | (if t ;; (method-is-universal* head) | |
| 201 | (dolist (sub (term-subterms term)) | |
| 202 | (gather-error-methods-and-variables sub res vars-also))))) | |
| 170 | (if (method-is-error-method head) | |
| 171 | (progn | |
| 172 | (pushnew head (car res) :test #'eq) | |
| 173 | (dolist (sub (term-subterms term)) | |
| 174 | (gather-error-methods-and-variables sub res vars-also))) | |
| 175 | (if t ;; (method-is-universal* head) | |
| 176 | (dolist (sub (term-subterms term)) | |
| 177 | (gather-error-methods-and-variables sub res vars-also))))) | |
| 203 | 178 | (if (and vars-also (term-is-variable? term)) |
| 204 | (when (err-sort-p (variable-sort term)) | |
| 205 | (pushnew term (car res) :test #'eq))))) | |
| 179 | (when (err-sort-p (variable-sort term)) | |
| 180 | (pushnew term (car res) :test #'eq))))) | |
| 206 | 181 | |
| 207 | 182 | ;;; test if a appl term contains error-method. |
| 208 | 183 | |
| 209 | 184 | (defun term-contains-error-method (term) |
| 210 | 185 | (declare (type term term) |
| 211 | (values (or null t))) | |
| 186 | (values (or null t))) | |
| 212 | 187 | (let ((body (term-body term))) |
| 213 | 188 | (when (term$is-application-form? body) |
| 214 | 189 | (or (method-is-error-method (term$head body)) |
| 215 | (some #'term-contains-error-method (term$subterms body)))))) | |
| 190 | (some #'term-contains-error-method (term$subterms body)))))) | |
| 216 | 191 | |
| 217 | 192 | |
| 218 | 193 | ;;; test if a appl form contains user defined error-method. |
| 219 | 194 | |
| 220 | 195 | (defun term-contains-user-defined-error-method (term) |
| 221 | 196 | (declare (type term term) |
| 222 | (values (or null t))) | |
| 197 | (values (or null t))) | |
| 223 | 198 | (and (term-is-application-form? term) |
| 224 | 199 | (or (method-is-user-defined-error-method (term-head term)) |
| 225 | (some #'term-contains-user-defined-error-method | |
| 226 | (term-subterms term))))) | |
| 200 | (some #'term-contains-user-defined-error-method | |
| 201 | (term-subterms term))))) | |
| 227 | 202 | |
| 228 | 203 | ;;; test if a appl form contains math-operator(:=). |
| 229 | 204 | |
| 230 | 205 | (defun term-contains-match-op (term) |
| 231 | 206 | (declare (type term term) |
| 232 | (values (or null t))) | |
| 207 | (values (or null t))) | |
| 233 | 208 | (and (term-is-application-form? term) |
| 234 | 209 | (or (method= *bool-match* (term-head term)) |
| 235 | (some #'term-contains-match-op | |
| 236 | (term-subterms term))))) | |
| 210 | (some #'term-contains-match-op | |
| 211 | (term-subterms term))))) | |
| 237 | 212 | |
| 238 | 213 | ;;; **************** |
| 239 | 214 | ;;; RECOMPUTING SORT____________________________________________________________ |
| 244 | 219 | ;;; |
| 245 | 220 | (defun set-if-then-else-sort (term &optional (so *current-sort-order*)) |
| 246 | 221 | (when (eq (term-head term) |
| 247 | *bool-if*) | |
| 222 | *bool-if*) | |
| 248 | 223 | (let ((arg2 (term-arg-2 term)) |
| 249 | (arg3 (term-arg-3 term))) | |
| 224 | (arg3 (term-arg-3 term))) | |
| 250 | 225 | (unless (is-in-same-connected-component (term-sort arg2) |
| 251 | (term-sort arg3) | |
| 252 | so) | |
| 253 | (with-output-chaos-error ('incompatible-sorts) | |
| 254 | (princ "value of if_then_else_fi must be of the same sort."))) | |
| 226 | (term-sort arg3) | |
| 227 | so) | |
| 228 | (with-output-chaos-error ('incompatible-sorts) | |
| 229 | (princ "2nd. and 3rd. arguments of if_then_else_fi must be of the same sort."))) | |
| 255 | 230 | (update-lowest-parse arg2) |
| 256 | 231 | (update-lowest-parse arg3) |
| 257 | 232 | (if (sort<= (term-sort arg2) (term-sort arg3)) |
| 258 | (setf (term-sort term) (term-sort arg3)) | |
| 259 | (setf (term-sort term) (term-sort arg2))))) | |
| 233 | (setf (term-sort term) (term-sort arg3)) | |
| 234 | (setf (term-sort term) (term-sort arg2))))) | |
| 260 | 235 | ) |
| 261 | 236 | |
| 237 | (defun select-if-then-least (ifs &optional (so *current-sort-order*)) | |
| 238 | (unless (cdr ifs) (return-from select-if-then-least ifs)) | |
| 239 | (dolist (x ifs) | |
| 240 | (set-if-then-else-sort x so)) | |
| 241 | (let ((result (car ifs))) | |
| 242 | (dolist (ift (cdr ifs)) | |
| 243 | (if (sort< (term-sort ift) (term-sort result) so) | |
| 244 | (setq result ift) | |
| 245 | (unless (is-in-same-connected-component (term-sort ift) (term-sort result) so) | |
| 246 | (return-from select-if-then-least ifs)))) | |
| 247 | (list result))) | |
| 262 | 248 | |
| 263 | 249 | (declaim (special *update-lowest-parse-in-progress*)) |
| 264 | 250 | (defvar *update-lowest-parse-in-progress* nil) |
| 265 | 251 | |
| 266 | 252 | (defun update-lowest-parse (term) |
| 267 | 253 | (declare (type term term) |
| 268 | (values t)) | |
| 269 | (let ((body (term-body term))) | |
| 254 | (values t)) | |
| 255 | (let ((body (term-body term)) | |
| 256 | (assoc-applied nil)) | |
| 270 | 257 | (unless (or (term$is-variable? body) (term$is-psuedo-constant? body) |
| 271 | (term-is-an-error term)) | |
| 258 | (term-is-an-error term)) | |
| 272 | 259 | ;; |
| 273 | 260 | (when (term-is-application-form? term) |
| 274 | (let ((ts (term-sort term)) | |
| 275 | (mso (method-coarity (term-head term)))) | |
| 276 | (when (sort< mso ts) | |
| 277 | (when *term-debug* | |
| 278 | (with-output-chaos-warning () | |
| 279 | (format t "something is bad, sort of the term is bigger than top method's coarity.") | |
| 280 | (print-next) | |
| 281 | (format t "Coarity: ") | |
| 282 | (print-sort-name mso *current-module*) | |
| 283 | (print-next) | |
| 284 | (term-print-with-sort term))) | |
| 285 | (setf (term-sort term) mso) | |
| 286 | (when *term-debug* | |
| 287 | (format t "~&[ULP] --> ") | |
| 288 | (term-print-with-sort term))))) | |
| 261 | (let ((ts (term-sort term)) | |
| 262 | (mso (method-coarity (term-head term)))) | |
| 263 | (when (sort< mso ts) | |
| 264 | (when *term-debug* | |
| 265 | (with-output-chaos-warning () | |
| 266 | (format t "something is bad, sort of the term is bigger than top method's coarity.") | |
| 267 | (print-next) | |
| 268 | (format t "Coarity: ") | |
| 269 | (print-sort-name mso *current-module*) | |
| 270 | (print-next) | |
| 271 | (term-print-with-sort term))) | |
| 272 | (setf (term-sort term) mso) | |
| 273 | (when *term-debug* | |
| 274 | (format t "~&[ULP] --> ") | |
| 275 | (term-print-with-sort term))))) | |
| 289 | 276 | (if (term$is-builtin-constant? body) |
| 290 | ;; built-in constant term | |
| 291 | (let ((so (module-sort-order | |
| 292 | (if *current-module* | |
| 293 | *current-module* | |
| 294 | (or *last-module* | |
| 295 | (sort-module (term$sort body)))))) | |
| 296 | (isrt (term$sort body)) | |
| 297 | (val (term$builtin-value body))) | |
| 298 | (declare (type sort-order so) | |
| 299 | (type sort* isrt) | |
| 300 | (type t val)) | |
| 301 | (let ((subs (subsorts isrt so)) | |
| 302 | (srt isrt)) | |
| 303 | (declare (type list subs) | |
| 304 | (type sort* srt)) | |
| 305 | (dolist (s subs) | |
| 306 | (declare (type sort* s)) | |
| 307 | (if (and (sort< s srt so) | |
| 308 | (sort-is-builtin s) | |
| 309 | (bsort-term-predicate s) | |
| 310 | (funcall (bsort-term-predicate s) val)) | |
| 311 | (setq srt s))) | |
| 312 | (setf (term$sort body) srt) | |
| 313 | term)) | |
| 314 | ||
| 315 | ;; application form | |
| 316 | (let* ((head (term$head body)) | |
| 317 | (mod (if *current-module* | |
| 318 | *current-module* | |
| 319 | (or *last-module* | |
| 320 | (operator-module (method-operator head))))) | |
| 321 | (son nil) | |
| 322 | (t1 nil) | |
| 323 | (t2 nil) | |
| 324 | (sort-order (module-sort-order mod)) | |
| 325 | (new-head nil)) | |
| 326 | (declare (type method head) | |
| 327 | (type module mod)) | |
| 328 | ;; #|| | |
| 329 | (when (method-is-error-method head) | |
| 330 | (when *term-debug* | |
| 331 | (with-output-msg () | |
| 332 | (format t "ULP:ERR_TERM: ") | |
| 333 | (term-print-with-sort term))) | |
| 334 | ;; recursively | |
| 335 | (dolist (sub (term-subterms term)) | |
| 336 | (update-lowest-parse sub))) | |
| 337 | ;; ||# | |
| 338 | ||
| 339 | ;; ---------------------------- | |
| 340 | ;; special case if_then_else_fi | |
| 341 | ;; ---------------------------- | |
| 342 | (when (eq (term-head term) *bool-if*) | |
| 343 | (set-if-then-else-sort term) | |
| 344 | (return-from update-lowest-parse term)) | |
| 345 | ||
| 346 | ;; -------------------------- | |
| 347 | ;; "standard" morphism rules | |
| 348 | ;; -------------------------- | |
| 349 | ||
| 350 | (when *term-debug* | |
| 351 | (format t "~&[ULP] given term =====================~% ") | |
| 352 | (term-print-with-sort term) | |
| 353 | (format t "~&[ULP] current = ") | |
| 354 | (print-chaos-object head) | |
| 355 | (trace lowest-method)) | |
| 356 | (setq new-head | |
| 357 | (lowest-method head | |
| 358 | (mapcar #'(lambda (x) | |
| 359 | (declare (type term x)) | |
| 360 | (term-sort x)) | |
| 361 | (term$subterms body)) | |
| 362 | mod)) | |
| 363 | (when *term-debug* | |
| 364 | (format t "~&[ULP] new = ") | |
| 365 | (print-chaos-object new-head) | |
| 366 | (untrace)) | |
| 367 | ;; | |
| 368 | (when (not (eq head new-head)) | |
| 369 | (change-head-operator term new-head) | |
| 370 | (setf (term-sort term) (method-coarity new-head)) | |
| 371 | (mark-term-as-not-reduced term) | |
| 372 | ;; (reset-reduced-flag term) ; ???? | |
| 373 | (when *term-debug* | |
| 374 | (format t "~&[ULP] head operator was changed ======="))) | |
| 375 | ;; | |
| 376 | #|| | |
| 377 | (if (eq (term-head term) *bool-if*) | |
| 378 | (progn | |
| 379 | (set-if-then-else-sort term) | |
| 380 | ;; (setq sort (term-sort term)) | |
| 381 | ) | |
| 382 | ;; (setq sort (setf (term$sort body) (method-coarity (term$head body)))) | |
| 383 | ) | |
| 384 | ||# | |
| 385 | ;; | |
| 386 | (setq head new-head) | |
| 387 | (when (method-is-associative head) | |
| 388 | ;; &&&& the following transformation tends to put | |
| 389 | ;; term into standard form even when sort doesn't decrease. | |
| 390 | (when (and (not (or (term$is-variable? (setq son (term-body | |
| 391 | (term$arg-1 body)))) | |
| 392 | (term$is-builtin-constant? son))) | |
| 393 | (method-is-associative-restriction-of (term$head son) head) | |
| 394 | (sort= (term-sort (setq t1 (term$arg-2 son))) | |
| 395 | (term-sort (setq t2 (term$arg-2 body)))) | |
| 396 | (sort< (term-sort t2) | |
| 397 | (term-sort (term$arg-1 son)) | |
| 398 | sort-order)) | |
| 399 | (when *term-debug* | |
| 400 | (format t "~&[ULP] treating ASSOCIATIVITY")) | |
| 401 | ;; we are in the following configuration | |
| 402 | ;; fs' -> fs' | |
| 403 | ;; fs' s s' fs | |
| 404 | ;; s' s s s | |
| 405 | ;; so: | |
| 406 | (setf (term$subterms body) | |
| 407 | (list (term$arg-1 son) | |
| 408 | (update-lowest-parse (make-term-with-sort-check-bin head (list t1 t2)))))) | |
| 409 | ; (make-applform (method-coarity head) head (list t1 t2)) | |
| 410 | ;; would only like to do the following if the | |
| 411 | ;; sort really decreases | |
| 412 | (when (and (not (or (term$is-variable? (setq son (term-body | |
| 413 | (term$arg-2 body)))) | |
| 414 | (term$is-builtin-constant? son))) | |
| 415 | (method-is-associative-restriction-of (term$head son) head) | |
| 416 | (sort= (term-sort (setq t1 (term$arg-1 body))) | |
| 417 | (term-sort (setq t2 (term$arg-1 son)))) | |
| 418 | (sort< (term-sort t1) (term-sort (term$arg-2 son)) sort-order)) | |
| 419 | (when *term-debug* | |
| 420 | (format t "~&[ULP] ASSOCIATIVITY 2")) | |
| 421 | ;; we are in the following configuration | |
| 422 | ;; fs' -> fs' | |
| 423 | ;; s fs' fs s' | |
| 424 | ;; s s' s s | |
| 425 | ;; so: | |
| 426 | (setf (term-subterms term) | |
| 427 | (list (update-lowest-parse | |
| 428 | ;(make-applform (method-coarity head) head (list t1 t2)) | |
| 429 | (make-term-with-sort-check-bin head (list t1 t2))) | |
| 430 | (term$arg-2 son))))) | |
| 431 | ||
| 432 | ;; necesary to have true lowest parse | |
| 433 | ||
| 434 | (when (method-is-commutative head) | |
| 435 | (let* ((t1 (term$arg-1 body)) | |
| 436 | (t2 (term$arg-2 body)) | |
| 437 | (alt-op (lowest-method head | |
| 438 | (list (term-sort t2) (term-sort t1))))) | |
| 439 | (when (not (eq alt-op head)) | |
| 440 | (term-replace term ;(make-applform (method-coarity alt-op) alt-op (list t2 t1)) | |
| 441 | (make-term-with-sort-check-bin alt-op (list t2 t1)))))) | |
| 442 | (mark-term-as-lowest-parsed term) | |
| 443 | term))))) | |
| 277 | ;; built-in constant term | |
| 278 | (let* ((isrt (term$sort body)) | |
| 279 | (cm (get-object-context isrt)) | |
| 280 | (so (if cm | |
| 281 | (module-sort-order cm) | |
| 282 | (with-output-chaos-error ('internal-error) | |
| 283 | (format t "Internal Error, No context module [ULP].")))) | |
| 284 | (val (term$builtin-value body))) | |
| 285 | (declare (type sort-order so) | |
| 286 | (type sort* isrt) | |
| 287 | (type t val)) | |
| 288 | (let ((subs (subsorts isrt so)) | |
| 289 | (srt isrt)) | |
| 290 | (declare (type list subs) | |
| 291 | (type sort* srt)) | |
| 292 | (dolist (s subs) | |
| 293 | (declare (type sort* s)) | |
| 294 | (if (and (sort< s srt so) | |
| 295 | (sort-is-builtin s) | |
| 296 | (bsort-term-predicate s) | |
| 297 | (funcall (bsort-term-predicate s) val)) | |
| 298 | (setq srt s))) | |
| 299 | (setf (term$sort body) srt) | |
| 300 | term)) | |
| 301 | ||
| 302 | ;; application form | |
| 303 | (let* ((head (term$head body)) | |
| 304 | (mod (get-object-context (method-operator head))) | |
| 305 | (son nil) | |
| 306 | (t1 nil) | |
| 307 | (t2 nil) | |
| 308 | (sort-order (module-sort-order mod)) | |
| 309 | (new-head nil)) | |
| 310 | (declare (type method head) | |
| 311 | (type module mod)) | |
| 312 | ;; ---------------------------- | |
| 313 | ;; special case if_then_else_fi | |
| 314 | ;; ---------------------------- | |
| 315 | (when (eq (term-head term) *bool-if*) | |
| 316 | (set-if-then-else-sort term) | |
| 317 | (return-from update-lowest-parse term)) | |
| 318 | ||
| 319 | ;; -------------------------- | |
| 320 | ;; "standard" morphism rules | |
| 321 | ;; -------------------------- | |
| 322 | ||
| 323 | (when *term-debug* | |
| 324 | (format t "~&[ULP] given term =====================~% ") | |
| 325 | (term-print-with-sort term) | |
| 326 | (format t "~&[ULP] current = ") | |
| 327 | (print-chaos-object head)) | |
| 328 | (setq new-head | |
| 329 | (lowest-method head | |
| 330 | (mapcar #'(lambda (x) | |
| 331 | (declare (type term x)) | |
| 332 | (term-sort x)) | |
| 333 | (term$subterms body)) | |
| 334 | mod)) | |
| 335 | (when *term-debug* | |
| 336 | (format t "~&[ULP] new = ") | |
| 337 | (print-chaos-object new-head) | |
| 338 | (untrace)) | |
| 339 | ;; | |
| 340 | (when (not (eq head new-head)) | |
| 341 | (change-head-operator term new-head) | |
| 342 | (setf (term-sort term) (method-coarity new-head)) | |
| 343 | (mark-term-as-not-reduced term) | |
| 344 | ;; (reset-reduced-flag term) ; ???? | |
| 345 | (when *term-debug* | |
| 346 | (format t "~&[ULP] head operator was changed ======="))) | |
| 347 | ;; | |
| 348 | (setq head new-head) | |
| 349 | (when (method-is-associative head) | |
| 350 | ;; &&&& the following transformation tends to put | |
| 351 | ;; term into standard form even when sort doesn't decrease. | |
| 352 | (when (and (not (or (term$is-variable? (setq son (term-body | |
| 353 | (term$arg-1 body)))) | |
| 354 | (term$is-builtin-constant? son))) | |
| 355 | (method-is-associative-restriction-of (term$head son) head) | |
| 356 | (sort= (term-sort (setq t1 (term$arg-2 son))) | |
| 357 | (term-sort (setq t2 (term$arg-2 body)))) | |
| 358 | (sort< (term-sort t2) | |
| 359 | (term-sort (term$arg-1 son)) | |
| 360 | sort-order)) | |
| 361 | (when *term-debug* | |
| 362 | (format t "~&[ULP] treating ASSOCIATIVITY")) | |
| 363 | ;; we are in the following configuration | |
| 364 | ;; fs' -> fs' | |
| 365 | ;; fs' s s' fs | |
| 366 | ;; s' s s s | |
| 367 | ;; so: | |
| 368 | (setf (term$subterms body) | |
| 369 | (list (term$arg-1 son) | |
| 370 | (update-lowest-parse (make-term-with-sort-check-bin head (list t1 t2))))) | |
| 371 | (setq assoc-applied t)) | |
| 372 | ||
| 373 | ;; would only like to do the following if the | |
| 374 | ;; sort really decreases | |
| 375 | (when (and (not (or (term$is-variable? (setq son (term-body | |
| 376 | (term$arg-2 body)))) | |
| 377 | (term$is-builtin-constant? son))) | |
| 378 | (method-is-associative-restriction-of (term$head son) head) | |
| 379 | (sort= (term-sort (setq t1 (term$arg-1 body))) | |
| 380 | (term-sort (setq t2 (term$arg-1 son)))) | |
| 381 | (sort< (term-sort t1) (term-sort (term$arg-2 son)) sort-order)) | |
| 382 | ||
| 383 | ;; we are in the following configuration | |
| 384 | ;; fs' -> fs' | |
| 385 | ;; s fs' fs s' | |
| 386 | ;; s s' s s | |
| 387 | ;; so: | |
| 388 | (setf (term-subterms term) | |
| 389 | (list (update-lowest-parse | |
| 390 | ;(make-applform (method-coarity head) head (list t1 t2)) | |
| 391 | (make-term-with-sort-check-bin head (list t1 t2))) | |
| 392 | (term$arg-2 son))) | |
| 393 | (when *term-debug* | |
| 394 | (format t "~&[ULP] ASSOCIATIVITY 2~%=> ") | |
| 395 | (term-print-with-sort term)) | |
| 396 | ;; we mark | |
| 397 | (setf assoc-applied t))) | |
| 398 | ||
| 399 | ;; necesary to have true lowest parse | |
| 400 | ||
| 401 | (when (method-is-commutative head) | |
| 402 | (let* ((t1 (term$arg-1 body)) | |
| 403 | (t2 (term$arg-2 body)) | |
| 404 | (alt-op (lowest-method head | |
| 405 | (list (term-sort t2) (term-sort t1))))) | |
| 406 | (when (not (eq alt-op head)) | |
| 407 | (term-replace term | |
| 408 | (make-term-with-sort-check-bin alt-op (list t2 t1)))))) | |
| 409 | (mark-term-as-lowest-parsed term) | |
| 410 | (values term assoc-applied)))))) | |
| 444 | 411 | |
| 445 | 412 | #|| |
| 446 | 413 | (defun update-lowest-parse (term) |
| 450 | 417 | (let ((body (term-body term))) |
| 451 | 418 | (unless (term$is-variable? body) |
| 452 | 419 | (if (term$is-builtin-constant? body) |
| 453 | (let ((so (module-sort-order | |
| 454 | (if *current-module* | |
| 455 | *current-module* | |
| 456 | (sort-module (term$sort body))))) | |
| 457 | (isrt (term$sort body)) | |
| 458 | (val (term$builtin-value body))) | |
| 459 | (let ((subs (subsorts isrt so)) | |
| 460 | (srt isrt)) | |
| 461 | (dolist (s subs) | |
| 462 | (if (and (sort< s srt so) | |
| 463 | (sort-is-builtin s) | |
| 464 | (bsort-term-predicate s) | |
| 465 | (funcall (bsort-term-predicate s) val)) | |
| 466 | (setq srt s))) | |
| 467 | (unless (eq isrt srt) | |
| 468 | (setf (term$sort body) srt)) | |
| 469 | ;; (mark-term-as-lowest-parsed ter) | |
| 470 | term)) | |
| 471 | ;; | |
| 472 | (let* ((head (term$head body)) | |
| 473 | (son nil) | |
| 474 | (t1 nil) | |
| 475 | (t2 nil) | |
| 476 | (mod (if *current-module* | |
| 477 | *current-module* | |
| 478 | (operator-module (method-operator head)))) | |
| 479 | (sort-order (module-sort-order mod))) | |
| 480 | ;; "standard" morphism rules | |
| 481 | (change-head-operator term | |
| 482 | (lowest-method head (mapcar #'(lambda (x) | |
| 483 | (term$sort | |
| 484 | (term-body x))) | |
| 485 | (term$subterms body)) | |
| 486 | mod)) | |
| 487 | ;;; (setf (term$sort body) (method-coarity (term$head body))) | |
| 488 | (setf (term-sort term) (method-coarity (term-head term))) | |
| 489 | ||
| 490 | ;; ;;;;; FOR NOW;;;;;;;;;;;;; | |
| 491 | ;; (return-from update-lowest-parse term) | |
| 492 | ;; extensions for associativity: if s and s' are sorts s.t. s < s' then | |
| 493 | (when (method-is-associative head) | |
| 494 | ;; &&&& the following transformation tends to put | |
| 495 | ;; term into standard form even when sort doesn't decrease. | |
| 496 | (when (and (not (or (term$is-variable? (setq son (term-body | |
| 497 | (term$arg-1 body)))) | |
| 498 | (term$is-builtin-constant? son))) | |
| 499 | (method-is-associative-restriction-of (term$head son) head) | |
| 500 | (sort= (term-sort (setq t1 (term$arg-2 son))) | |
| 501 | (term-sort (setq t2 (term$arg-2 body)))) | |
| 502 | (sort< (term-sort t2) | |
| 503 | (term-sort (term$arg-1 son)) | |
| 504 | sort-order)) | |
| 505 | ;; we are in the following configuration | |
| 506 | ;; fs' -> fs' | |
| 507 | ;; fs' s s' fs | |
| 508 | ;; s' s s s | |
| 509 | ;; so: | |
| 510 | (setf (term$subterms body) | |
| 511 | (list (term$arg-1 son) | |
| 512 | (update-lowest-parse | |
| 513 | (make-applform (method-coarity head) | |
| 514 | head | |
| 515 | (list t1 t2)))))) | |
| 516 | ;; would only like to do the following if the | |
| 517 | ;; sort really decreases | |
| 518 | (when (and (not (or (term$is-variable? (setq son (term-body | |
| 519 | (term$arg-2 body)))) | |
| 520 | (term$is-builtin-constant? son))) | |
| 521 | (method-is-associative-restriction-of (term$head son) head) | |
| 522 | (sort= (term-sort (setq t1 (term$arg-1 body))) | |
| 523 | (term-sort (setq t2 (term$arg-1 son)))) | |
| 524 | (sort< (term-sort t1) (term-sort (term$arg-2 son)) sort-order)) | |
| 525 | ;; we are in the following configuration | |
| 526 | ;; fs' -> fs' | |
| 527 | ;; s fs' fs s' | |
| 528 | ;; s s' s s | |
| 529 | ;; so: | |
| 530 | (setf (term-subterms term) | |
| 531 | (list (update-lowest-parse | |
| 532 | (make-applform (method-coarity head) head | |
| 533 | (list t1 t2))) | |
| 534 | (term$arg-2 son)))) | |
| 535 | ) | |
| 536 | ||
| 537 | ;; necesary to have true lowest parse | |
| 538 | ||
| 539 | (when (method-is-commutative head) | |
| 540 | (let* ((t1 (term$arg-1 body)) | |
| 541 | (t2 (term$arg-2 body)) | |
| 542 | (alt-op (lowest-method head | |
| 543 | (list (term-sort t2) (term-sort t1))))) | |
| 544 | (when (not (eq alt-op head)) | |
| 545 | (term-replace term (make-applform | |
| 546 | (method-coarity alt-op) | |
| 547 | alt-op | |
| 548 | (list t2 t1)))))) | |
| 549 | ||
| 550 | ;; (mark-term-as-lowest-parsed term) | |
| 551 | term ))))) | |
| 420 | (let ((so (module-sort-order | |
| 421 | (if *current-module* | |
| 422 | *current-module* | |
| 423 | (sort-module (term$sort body))))) | |
| 424 | (isrt (term$sort body)) | |
| 425 | (val (term$builtin-value body))) | |
| 426 | (let ((subs (subsorts isrt so)) | |
| 427 | (srt isrt)) | |
| 428 | (dolist (s subs) | |
| 429 | (if (and (sort< s srt so) | |
| 430 | (sort-is-builtin s) | |
| 431 | (bsort-term-predicate s) | |
| 432 | (funcall (bsort-term-predicate s) val)) | |
| 433 | (setq srt s))) | |
| 434 | (unless (eq isrt srt) | |
| 435 | (setf (term$sort body) srt)) | |
| 436 | ;; (mark-term-as-lowest-parsed ter) | |
| 437 | term)) | |
| 438 | ;; | |
| 439 | (let* ((head (term$head body)) | |
| 440 | (son nil) | |
| 441 | (t1 nil) | |
| 442 | (t2 nil) | |
| 443 | (mod (if *current-module* | |
| 444 | *current-module* | |
| 445 | (operator-module (method-operator head)))) | |
| 446 | (sort-order (module-sort-order mod))) | |
| 447 | ;; "standard" morphism rules | |
| 448 | (change-head-operator term | |
| 449 | (lowest-method head (mapcar #'(lambda (x) | |
| 450 | (term$sort | |
| 451 | (term-body x))) | |
| 452 | (term$subterms body)) | |
| 453 | mod)) | |
| 454 | ;;; (setf (term$sort body) (method-coarity (term$head body))) | |
| 455 | (setf (term-sort term) (method-coarity (term-head term))) | |
| 456 | ||
| 457 | ;; extensions for associativity: if s and s' are sorts s.t. s < s' then | |
| 458 | (when (method-is-associative head) | |
| 459 | ;; &&&& the following transformation tends to put | |
| 460 | ;; term into standard form even when sort doesn't decrease. | |
| 461 | (when (and (not (or (term$is-variable? (setq son (term-body | |
| 462 | (term$arg-1 body)))) | |
| 463 | (term$is-builtin-constant? son))) | |
| 464 | (method-is-associative-restriction-of (term$head son) head) | |
| 465 | (sort= (term-sort (setq t1 (term$arg-2 son))) | |
| 466 | (term-sort (setq t2 (term$arg-2 body)))) | |
| 467 | (sort< (term-sort t2) | |
| 468 | (term-sort (term$arg-1 son)) | |
| 469 | sort-order)) | |
| 470 | ;; we are in the following configuration | |
| 471 | ;; fs' -> fs' | |
| 472 | ;; fs' s s' fs | |
| 473 | ;; s' s s s | |
| 474 | ;; so: | |
| 475 | (setf (term$subterms body) | |
| 476 | (list (term$arg-1 son) | |
| 477 | (update-lowest-parse | |
| 478 | (make-applform (method-coarity head) | |
| 479 | head | |
| 480 | (list t1 t2)))))) | |
| 481 | ;; would only like to do the following if the | |
| 482 | ;; sort really decreases | |
| 483 | (when (and (not (or (term$is-variable? (setq son (term-body | |
| 484 | (term$arg-2 body)))) | |
| 485 | (term$is-builtin-constant? son))) | |
| 486 | (method-is-associative-restriction-of (term$head son) head) | |
| 487 | (sort= (term-sort (setq t1 (term$arg-1 body))) | |
| 488 | (term-sort (setq t2 (term$arg-1 son)))) | |
| 489 | (sort< (term-sort t1) (term-sort (term$arg-2 son)) sort-order)) | |
| 490 | ;; we are in the following configuration | |
| 491 | ;; fs' -> fs' | |
| 492 | ;; s fs' fs s' | |
| 493 | ;; s s' s s | |
| 494 | ;; so: | |
| 495 | (setf (term-subterms term) | |
| 496 | (list (update-lowest-parse | |
| 497 | (make-applform (method-coarity head) head | |
| 498 | (list t1 t2))) | |
| 499 | (term$arg-2 son)))) | |
| 500 | ) | |
| 501 | ||
| 502 | ;; necesary to have true lowest parse | |
| 503 | ||
| 504 | (when (method-is-commutative head) | |
| 505 | (let* ((t1 (term$arg-1 body)) | |
| 506 | (t2 (term$arg-2 body)) | |
| 507 | (alt-op (lowest-method head | |
| 508 | (list (term-sort t2) (term-sort t1))))) | |
| 509 | (when (not (eq alt-op head)) | |
| 510 | (term-replace term (make-applform | |
| 511 | (method-coarity alt-op) | |
| 512 | alt-op | |
| 513 | (list t2 t1)))))) | |
| 514 | ||
| 515 | ;; (mark-term-as-lowest-parsed term) | |
| 516 | term ))))) | |
| 552 | 517 | ||# |
| 553 | 518 | |
| 554 | 519 | ;;; ********************************* |
| 581 | 546 | ;;; |
| 582 | 547 | (defun variable-equal (x y) |
| 583 | 548 | (declare (type term x y) |
| 584 | (values (or null t))) | |
| 549 | (values (or null t))) | |
| 585 | 550 | (or (term-eq x y) |
| 586 | 551 | (and (eq (variable-name x) (variable-name y)) |
| 587 | (sort= (variable-sort x) (variable-sort y))))) | |
| 552 | (sort= (variable-sort x) (variable-sort y))))) | |
| 588 | 553 | |
| 589 | 554 | (defun variable= (x y) |
| 590 | 555 | (declare (type term x y) |
| 591 | (values (or null t))) | |
| 556 | (values (or null t))) | |
| 592 | 557 | (term-eq x y)) |
| 593 | 558 | |
| 594 | 559 | (defun variable-eq (x y) |
| 595 | 560 | (declare (type term x y) |
| 596 | (values (or null t))) | |
| 561 | (values (or null t))) | |
| 597 | 562 | (term-eq x y)) |
| 598 | 563 | |
| 599 | 564 | ;;; TERM-IS-ZERO-FOR-METHOD : TERM METHOD -> BOOL |
| 601 | 566 | ;;; |
| 602 | 567 | (defun term-is-zero-for-method (term meth) |
| 603 | 568 | (declare (type term term) |
| 604 | (type method meth) | |
| 605 | (values (or null t))) | |
| 569 | (type method meth) | |
| 570 | (values (or null t))) | |
| 606 | 571 | (let* ((th (method-theory meth)) |
| 607 | (zero (car (theory-zero th)))) | |
| 572 | (zero (car (theory-zero th)))) | |
| 608 | 573 | (declare (type op-theory th) |
| 609 | (type (or null term) zero)) | |
| 574 | (type (or null term) zero)) | |
| 610 | 575 | (if zero ;; term |
| 611 | (term-is-similar? term zero) | |
| 576 | (term-is-similar? term zero) | |
| 612 | 577 | nil))) |
| 613 | 578 | |
| 614 | 579 | ;;; TERM-OP-CONTAINS-THEORY |
| 617 | 582 | (defun term-op-contains-theory (term) |
| 618 | 583 | (if (term-is-application-form? term) |
| 619 | 584 | (let ((th (method-theory-info-for-matching (term-head term)))) |
| 620 | (or (not (theory-info-empty-for-matching th)) | |
| 621 | (some #'(lambda (sub) (term-op-contains-theory sub)) | |
| 622 | (term-subterms term)))) | |
| 585 | (or (not (theory-info-empty-for-matching th)) | |
| 586 | (some #'(lambda (sub) (term-op-contains-theory sub)) | |
| 587 | (term-subterms term)))) | |
| 623 | 588 | nil) |
| 624 | 589 | ) |
| 625 | 590 | |
| 629 | 594 | ;;; |
| 630 | 595 | (defun term-is-congruent? (t1 t2) |
| 631 | 596 | (declare (type term t1 t2) |
| 632 | (values (or null t))) | |
| 597 | (values (or null t))) | |
| 633 | 598 | (let ((t1-body (term-body t1)) |
| 634 | (t2-body (term-body t2))) | |
| 599 | (t2-body (term-body t2))) | |
| 635 | 600 | (cond ((term$is-variable? t1-body) |
| 636 | (or (eq t1 t2) | |
| 637 | (and (term$is-variable? t2-body) | |
| 638 | ;; (eq (variable$name t1-body) (variable$name t2-body)) | |
| 639 | (sort= (variable$sort t1-body) (variable$sort t2-body))))) | |
| 640 | ((term$is-variable? t2-body) nil) | |
| 641 | ((term$is-application-form? t1-body) | |
| 642 | (and (term$is-application-form? t2-body) | |
| 643 | (if (method-is-same-qual-method (term$method t1-body) | |
| 644 | (term$method t2-body)) | |
| 645 | (let ((sl1 (term$subterms t1-body)) | |
| 646 | (sl2 (term$subterms t2-body))) | |
| 647 | (loop (when (null sl1) (return (null sl2))) | |
| 648 | (unless (term-is-congruent? (car sl1) (car sl2)) | |
| 649 | (return nil)) | |
| 650 | (setf sl1 (cdr sl1) | |
| 651 | sl2 (cdr sl2)))) | |
| 652 | nil))) | |
| 653 | ((term$is-builtin-constant? t1-body) | |
| 654 | (term$builtin-equal t1-body t2-body)) | |
| 655 | ((term$is-builtin-constant? t2-body) nil) | |
| 656 | ((term$is-lisp-form? t1-body) | |
| 657 | (and (term$is-lisp-form? t2-body) | |
| 658 | (equal (term$lisp-function t1-body) | |
| 659 | (term$lisp-function t2-body)))) | |
| 660 | ((term$is-lisp-form? t2-body) nil) | |
| 661 | (t (break "Panic! unknown type of term to term-is-congruent?"))))) | |
| 601 | (or (eq t1 t2) | |
| 602 | (and (term$is-variable? t2-body) | |
| 603 | ;; (eq (variable$name t1-body) (variable$name t2-body)) | |
| 604 | (sort= (variable$sort t1-body) (variable$sort t2-body))))) | |
| 605 | ((term$is-variable? t2-body) nil) | |
| 606 | ((term$is-application-form? t1-body) | |
| 607 | (and (term$is-application-form? t2-body) | |
| 608 | (if (method-is-same-qual-method (term$method t1-body) | |
| 609 | (term$method t2-body)) | |
| 610 | (let ((sl1 (term$subterms t1-body)) | |
| 611 | (sl2 (term$subterms t2-body))) | |
| 612 | (loop (when (null sl1) (return (null sl2))) | |
| 613 | (unless (term-is-congruent? (car sl1) (car sl2)) | |
| 614 | (return nil)) | |
| 615 | (setf sl1 (cdr sl1) | |
| 616 | sl2 (cdr sl2)))) | |
| 617 | nil))) | |
| 618 | ((term$is-builtin-constant? t1-body) | |
| 619 | (term$builtin-equal t1-body t2-body)) | |
| 620 | ((term$is-builtin-constant? t2-body) nil) | |
| 621 | ((term$is-lisp-form? t1-body) | |
| 622 | (and (term$is-lisp-form? t2-body) | |
| 623 | (equal (term$lisp-function t1-body) | |
| 624 | (term$lisp-function t2-body)))) | |
| 625 | ((term$is-lisp-form? t2-body) nil) | |
| 626 | (t (break "Panic! unknown type of term to term-is-congruent?"))))) | |
| 662 | 627 | |
| 663 | 628 | ;;; TERM-EQUATIONAL-EQUAL : TERM TERM -> BOOL |
| 664 | 629 | ;;; return t iff the two terms are equationally equal. |
| 668 | 633 | |
| 669 | 634 | (defun match-with-empty-theory (t1 t2) |
| 670 | 635 | (declare (type term t1 t2) |
| 671 | (values (or null t))) | |
| 636 | (values (or null t))) | |
| 672 | 637 | (or (term-eq t1 t2) |
| 673 | 638 | (cond ((term-is-applform? t1) |
| 674 | (unless (term-is-applform? t2) | |
| 675 | (setq *used==* t) | |
| 676 | (return-from match-with-empty-theory nil)) | |
| 677 | ;; | |
| 678 | (let ((head1 (term-head t1)) | |
| 679 | (head2 (term-head t2)) | |
| 680 | (subs1 (term-subterms t1)) | |
| 681 | (subs2 (term-subterms t2))) | |
| 682 | (declare (type list subs1 subs2) | |
| 683 | (type method head1 head2)) | |
| 684 | ;; | |
| 685 | (if (null subs1) | |
| 686 | (and (null subs2) | |
| 687 | (eq head1 head2)) | |
| 688 | (if (method-is-of-same-operator head1 head2) | |
| 689 | (do* ((sub1 subs1 (cdr sub1)) | |
| 690 | (sub2 subs2 (cdr sub2)) | |
| 691 | (st1 nil) | |
| 692 | (st2 nil)) | |
| 693 | ((null sub1) t) | |
| 694 | (setq st1 (car sub1)) | |
| 695 | (setq st2 (car sub2)) | |
| 696 | ;; (unless st2 (return nil)) | |
| 697 | (cond ((term-is-applform? st1) | |
| 698 | (unless | |
| 699 | (and (term-is-applform? st2) | |
| 700 | (if (theory-info-empty-for-matching | |
| 701 | (method-theory-info-for-matching | |
| 702 | (term-method st1))) | |
| 703 | (match-with-empty-theory st1 st2) | |
| 704 | (term-equational-equal st1 st2))) | |
| 705 | (return nil))) | |
| 706 | ((term-is-variable? st1) | |
| 707 | (setq *used==* t) | |
| 708 | (unless (variable= st1 st2) (return nil))) | |
| 709 | ;; | |
| 710 | ((term-is-variable? st2) | |
| 711 | (setq *used==* t) | |
| 712 | (return nil)) | |
| 713 | ;; | |
| 714 | ((term-is-builtin-constant? st1) | |
| 715 | (unless (term-builtin-equal st1 st2) (return nil))) | |
| 716 | ;; | |
| 717 | (t | |
| 718 | (break "Panic: unknown type of term") | |
| 719 | ;; | |
| 720 | ))) | |
| 721 | nil)))) | |
| 722 | ((term-is-builtin-constant? t1) | |
| 723 | (term-builtin-equal t1 t2)) | |
| 724 | ((term-is-builtin-constant? t2) nil) | |
| 725 | ))) | |
| 639 | (unless (term-is-applform? t2) | |
| 640 | (setq *used==* t) | |
| 641 | (return-from match-with-empty-theory nil)) | |
| 642 | ;; | |
| 643 | (let ((head1 (term-head t1)) | |
| 644 | (head2 (term-head t2)) | |
| 645 | (subs1 (term-subterms t1)) | |
| 646 | (subs2 (term-subterms t2))) | |
| 647 | (declare (type list subs1 subs2) | |
| 648 | (type method head1 head2)) | |
| 649 | ;; | |
| 650 | (if (null subs1) | |
| 651 | (and (null subs2) | |
| 652 | (eq head1 head2)) | |
| 653 | (if (method-is-of-same-operator head1 head2) | |
| 654 | (do* ((sub1 subs1 (cdr sub1)) | |
| 655 | (sub2 subs2 (cdr sub2)) | |
| 656 | (st1 nil) | |
| 657 | (st2 nil)) | |
| 658 | ((null sub1) t) | |
| 659 | (setq st1 (car sub1)) | |
| 660 | (setq st2 (car sub2)) | |
| 661 | ;; (unless st2 (return nil)) | |
| 662 | (cond ((term-is-applform? st1) | |
| 663 | (unless | |
| 664 | (and (term-is-applform? st2) | |
| 665 | (if (theory-info-empty-for-matching | |
| 666 | (method-theory-info-for-matching | |
| 667 | (term-method st1))) | |
| 668 | (match-with-empty-theory st1 st2) | |
| 669 | (term-equational-equal st1 st2))) | |
| 670 | (return nil))) | |
| 671 | ((term-is-variable? st1) | |
| 672 | (setq *used==* t) | |
| 673 | (unless (variable= st1 st2) (return nil))) | |
| 674 | ;; | |
| 675 | ((term-is-variable? st2) | |
| 676 | (setq *used==* t) | |
| 677 | (return nil)) | |
| 678 | ;; | |
| 679 | ((term-is-builtin-constant? st1) | |
| 680 | (unless (term-builtin-equal st1 st2) (return nil))) | |
| 681 | ;; | |
| 682 | (t | |
| 683 | (break "Panic: unknown type of term") | |
| 684 | ;; | |
| 685 | ))) | |
| 686 | nil)))) | |
| 687 | ((term-is-builtin-constant? t1) | |
| 688 | (term-builtin-equal t1 t2)) | |
| 689 | ((term-is-builtin-constant? t2) nil) | |
| 690 | ))) | |
| 726 | 691 | |
| 727 | 692 | (defun term-equational-equal (t1 t2) |
| 728 | 693 | (declare (type term t1 t2) |
| 729 | (values (or null t))) | |
| 694 | (values (or null t))) | |
| 730 | 695 | (or (term-eq t1 t2) |
| 731 | 696 | ;; (equal t1 t2) |
| 732 | 697 | (let ((t1-body (term-body t1)) |
| 733 | (t2-body (term-body t2))) | |
| 734 | (cond ((term$is-applform? t1-body) | |
| 735 | (let ((f1 (term$head t1-body))) | |
| 736 | (if (theory-info-empty-for-matching | |
| 737 | (method-theory-info-for-matching f1)) | |
| 738 | (match-with-empty-theory t1 t2) | |
| 739 | (E-equal-in-theory (method-theory f1) t1 t2)))) | |
| 740 | ((term$is-builtin-constant? t1-body) | |
| 741 | (term$builtin-equal t1-body t2-body)) | |
| 742 | ((term$is-builtin-constant? t2-body) nil) | |
| 743 | ;; | |
| 744 | ((term$is-variable? t1-body) | |
| 745 | (setq *used==* t) | |
| 746 | (eq t1-body t2-body)) | |
| 747 | ((term$is-variable? t2-body) | |
| 748 | (setq *used==* t) | |
| 749 | nil) | |
| 750 | ((term$is-lisp-form? t1-body) | |
| 751 | (and (term$is-lisp-form? t2-body) | |
| 752 | (equal (term$lisp-code-original-form t1-body) | |
| 753 | (term$lisp-code-original-form t2-body)))) | |
| 754 | (t (break "term-equational-equal: not-implemented ~s" t1)))))) | |
| 698 | (t2-body (term-body t2))) | |
| 699 | (cond ((term$is-applform? t1-body) | |
| 700 | (let ((f1 (term$head t1-body))) | |
| 701 | (if (theory-info-empty-for-matching | |
| 702 | (method-theory-info-for-matching f1)) | |
| 703 | (match-with-empty-theory t1 t2) | |
| 704 | (E-equal-in-theory (method-theory f1) t1 t2)))) | |
| 705 | ((term$is-builtin-constant? t1-body) | |
| 706 | (term$builtin-equal t1-body t2-body)) | |
| 707 | ((term$is-builtin-constant? t2-body) nil) | |
| 708 | ;; | |
| 709 | ((term$is-variable? t1-body) | |
| 710 | (setq *used==* t) | |
| 711 | (eq t1-body t2-body)) | |
| 712 | ((term$is-variable? t2-body) | |
| 713 | (setq *used==* t) | |
| 714 | nil) | |
| 715 | ((term$is-lisp-form? t1-body) | |
| 716 | (and (term$is-lisp-form? t2-body) | |
| 717 | (equal (term$lisp-code-original-form t1-body) | |
| 718 | (term$lisp-code-original-form t2-body)))) | |
| 719 | (t (break "term-equational-equal: not-implemented ~s" t1)))))) | |
| 755 | 720 | |
| 756 | 721 | ;;; TERM-IS-SIMILAR? : TERM TERM -> BOOL |
| 757 | 722 | ;;; returns true iff two terms are similar, i.e., syntactically equal. |
| 759 | 724 | ;;; |
| 760 | 725 | (defun term-is-similar? (t1 t2) |
| 761 | 726 | (declare (type term t1) |
| 762 | (type (or term null) t2) | |
| 763 | (values (or null t))) | |
| 727 | (type (or term null) t2) | |
| 728 | (values (or null t))) | |
| 764 | 729 | (or (term-eq t1 t2) |
| 765 | 730 | (if t2 |
| 766 | (let ((t1-body (term-body t1)) | |
| 767 | (t2-body (term-body t2))) | |
| 768 | (cond ((term$is-application-form? t1-body) | |
| 769 | (and (term$is-application-form? t2-body) | |
| 770 | (if (method-w= (term$head t1-body) (term$head t2-body)) | |
| 771 | (let ((subs1 (term$subterms t1-body)) | |
| 772 | (subs2 (term$subterms t2-body))) | |
| 773 | (loop | |
| 774 | ;; (when (null subs1) (return (null subs2))) | |
| 775 | (when (null subs1) (return t)) | |
| 776 | (unless (term-is-similar? (car subs1) (car subs2)) | |
| 777 | (return nil)) | |
| 778 | (setq subs1 (cdr subs1) subs2 (cdr subs2)))) | |
| 779 | nil))) | |
| 780 | ((term$is-variable? t1-body) | |
| 781 | (and (term$is-variable? t2-body) | |
| 782 | (eq (variable$name t1-body) | |
| 783 | (variable$name t2-body)) | |
| 784 | (sort= (variable$sort t1-body) | |
| 785 | (variable$sort t2-body)))) | |
| 786 | ((term$is-variable? t2-body) nil) | |
| 787 | ((term$is-builtin-constant? t1-body) | |
| 788 | (term$builtin-equal t1-body t2-body)) | |
| 789 | ((term$is-builtin-constant? t2-body) nil) | |
| 790 | ((term$is-lisp-form? t1-body) | |
| 791 | (and (term$is-lisp-form? t2-body) | |
| 792 | (equal (term$lisp-form-original-form t1-body) | |
| 793 | (term$lisp-form-original-form t2-body)))) | |
| 794 | ((term$is-lisp-form? t2-body) nil) | |
| 795 | (t (break "unknown type of term." ))))))) | |
| 731 | (let ((t1-body (term-body t1)) | |
| 732 | (t2-body (term-body t2))) | |
| 733 | (cond ((term$is-application-form? t1-body) | |
| 734 | (and (term$is-application-form? t2-body) | |
| 735 | (if (method-w= (term$head t1-body) (term$head t2-body)) | |
| 736 | (let ((subs1 (term$subterms t1-body)) | |
| 737 | (subs2 (term$subterms t2-body))) | |
| 738 | (loop | |
| 739 | ;; (when (null subs1) (return (null subs2))) | |
| 740 | (when (null subs1) (return t)) | |
| 741 | (unless (term-is-similar? (car subs1) (car subs2)) | |
| 742 | (return nil)) | |
| 743 | (setq subs1 (cdr subs1) subs2 (cdr subs2)))) | |
| 744 | nil))) | |
| 745 | ((term$is-variable? t1-body) | |
| 746 | (and (term$is-variable? t2-body) | |
| 747 | (eq (variable$name t1-body) | |
| 748 | (variable$name t2-body)) | |
| 749 | (sort= (variable$sort t1-body) | |
| 750 | (variable$sort t2-body)))) | |
| 751 | ((term$is-variable? t2-body) nil) | |
| 752 | ((term$is-builtin-constant? t1-body) | |
| 753 | (term$builtin-equal t1-body t2-body)) | |
| 754 | ((term$is-builtin-constant? t2-body) nil) | |
| 755 | ((term$is-lisp-form? t1-body) | |
| 756 | (and (term$is-lisp-form? t2-body) | |
| 757 | (equal (term$lisp-form-original-form t1-body) | |
| 758 | (term$lisp-form-original-form t2-body)))) | |
| 759 | ((term$is-lisp-form? t2-body) nil) | |
| 760 | (t (break "unknown type of term." ))))))) | |
| 796 | 761 | |
| 797 | 762 | ;;; **************************** |
| 798 | 763 | ;;; APPLICATION FORM CONSTRUTORS |
| 803 | 768 | ;;; |
| 804 | 769 | (defun make-term-check-op (f subterms &optional module) |
| 805 | 770 | (declare (type method f) |
| 806 | (type list subterms) | |
| 807 | (type (or null module) module)) | |
| 771 | (type list subterms) | |
| 772 | (type (or null module) module)) | |
| 808 | 773 | (make-term-with-sort-check f subterms module)) |
| 809 | 774 | |
| 810 | 775 | ;;; op make-term-check-op-with-sort-check : |
| 813 | 778 | ;;; |
| 814 | 779 | (defun make-term-check-op-with-sort-check (f subterms &optional module) |
| 815 | 780 | (declare (type method f) |
| 816 | (type list subterms) | |
| 817 | (type (or null module) module) | |
| 818 | (values term)) | |
| 781 | (type list subterms) | |
| 782 | (type (or null module) module) | |
| 783 | (values term)) | |
| 819 | 784 | (make-term-with-sort-check f subterms module)) |
| 820 | 785 | |
| 821 | 786 | ;;; MAKE-TERM-WITH-SORT-CHECK : METHOD SUBTERMS -> TERM |
| 824 | 789 | ;;; method, otherwise, given method is used. |
| 825 | 790 | (defvar **sa-debug** nil) |
| 826 | 791 | (defun make-term-with-sort-check (meth subterms |
| 827 | &optional (module (or *current-module* | |
| 828 | *last-module*))) | |
| 792 | &optional (module (get-context-module))) | |
| 829 | 793 | (declare (type method meth) |
| 830 | (type list subterms) | |
| 831 | (type module module)) | |
| 794 | (type list subterms) | |
| 795 | (type module module)) | |
| 832 | 796 | (let ((res nil)) |
| 833 | 797 | (if (do ((arl (method-arity meth) (cdr arl)) |
| 834 | (sl subterms (cdr sl))) | |
| 835 | ((null arl) t) | |
| 836 | (unless (sort= (car arl) (term-sort (car sl))) (return nil))) | |
| 837 | (setq res (make-applform (method-coarity meth) meth subterms)) | |
| 798 | (sl subterms (cdr sl))) | |
| 799 | ((null arl) t) | |
| 800 | (unless (sort= (car arl) (term-sort (car sl))) (return nil))) | |
| 801 | (setq res (make-applform (method-coarity meth) meth subterms)) | |
| 838 | 802 | (let ((m (lowest-method meth |
| 839 | (mapcar #'(lambda (x) (term-sort x)) subterms) ; | |
| 840 | module))) | |
| 841 | (setq res (make-applform (method-coarity m) m subterms)))) | |
| 803 | (mapcar #'(lambda (x) (term-sort x)) subterms) ; | |
| 804 | module))) | |
| 805 | (setq res (make-applform (method-coarity m) m subterms)))) | |
| 842 | 806 | (when **sa-debug** |
| 843 | (format t "~&MTWSC: meth=") | |
| 807 | (format t "~%MTWSC: meth=") | |
| 844 | 808 | (print-chaos-object meth) |
| 845 | 809 | (print "==> ") |
| 846 | 810 | (term-print res) |
| 853 | 817 | ;;; same as make-term-with-sort-check, but specialized to binary operators. |
| 854 | 818 | |
| 855 | 819 | (defun make-term-with-sort-check-bin (meth subterms |
| 856 | &optional (module *current-module*)) | |
| 820 | &optional (module (get-context-module))) | |
| 857 | 821 | (declare (type method meth) |
| 858 | (type list subterms) | |
| 859 | (type (or null module) module) | |
| 860 | (values term)) | |
| 822 | (type list subterms) | |
| 823 | (type (or null module) module) | |
| 824 | (values term)) | |
| 861 | 825 | (let ((s1 (term-sort (car subterms))) |
| 862 | 826 | (s2 (term-sort (cadr subterms))) |
| 863 | (res nil)) | |
| 827 | (res nil)) | |
| 864 | 828 | (if (let ((ar (method-arity meth))) |
| 865 | (and (sort= (car ar) s1) | |
| 866 | (sort= (cadr ar) s2))) | |
| 829 | (and (sort= (car ar) s1) | |
| 830 | (sort= (cadr ar) s2))) | |
| 867 | 831 | (setq res (make-applform (method-coarity meth) meth subterms)) |
| 868 | 832 | (let ((lm (lowest-method meth (list s1 s2) module))) |
| 869 | (setq res (make-applform (method-coarity lm) lm subterms)))) | |
| 833 | (setq res (make-applform (method-coarity lm) lm subterms)))) | |
| 870 | 834 | (when **sa-debug** |
| 871 | 835 | (format t "~&MTWSC-BIN: meth=") |
| 872 | 836 | (print-chaos-object meth) |
| 893 | 857 | #+GCL |
| 894 | 858 | (defun list-assoc-subterms (term method) |
| 895 | 859 | (declare (type term term) |
| 896 | (type method method) | |
| 897 | (values list)) | |
| 860 | (type method method) | |
| 861 | (values list)) | |
| 898 | 862 | (let ((res (list-assoc-subterms-aux term method nil))) |
| 899 | 863 | res)) |
| 900 | 864 | |
| 901 | 865 | (defun list-assoc-subterms-aux (term method lst) |
| 902 | 866 | (declare (type term term) |
| 903 | (type method method) | |
| 904 | (type list lst)) | |
| 867 | (type method method) | |
| 868 | (type list lst)) | |
| 905 | 869 | (let ((body (term-body term))) |
| 906 | 870 | (if (term$is-application-form? body) |
| 907 | (progn | |
| 908 | (if (method-is-of-same-operator (term$method body) method) | |
| 909 | (list-assoc-subterms-aux (term$arg-1 body) method | |
| 910 | (list-assoc-subterms-aux (term$arg-2 body) | |
| 911 | method | |
| 912 | lst)) | |
| 913 | (cons term lst))) | |
| 914 | (cons term lst)))) | |
| 871 | (progn | |
| 872 | (if (method-is-of-same-operator (term$method body) method) | |
| 873 | (list-assoc-subterms-aux (term$arg-1 body) method | |
| 874 | (list-assoc-subterms-aux (term$arg-2 body) | |
| 875 | method | |
| 876 | lst)) | |
| 877 | (cons term lst))) | |
| 878 | (cons term lst)))) | |
| 915 | 879 | |
| 916 | 880 | #-GCL |
| 917 | 881 | (defun list-assoc-subterms (term method) |
| 918 | 882 | (declare (type term term) |
| 919 | (type method method) | |
| 920 | (values list)) | |
| 883 | (type method method) | |
| 884 | (values list)) | |
| 921 | 885 | (labels ((list-a-subs (term method lst) |
| 922 | (declare (type term term) | |
| 923 | (type method method) | |
| 924 | (type list lst) | |
| 925 | (values list)) | |
| 926 | (let ((body (term-body term))) | |
| 927 | (if (term$is-application-form? body) | |
| 928 | (progn | |
| 929 | (if (method-is-of-same-operator (term$method body) method) | |
| 930 | (list-a-subs (term$arg-1 body) method | |
| 931 | (list-a-subs (term$arg-2 body) | |
| 932 | method | |
| 933 | lst)) | |
| 934 | (cons term lst))) | |
| 935 | (cons term lst))))) | |
| 886 | (declare (type term term) | |
| 887 | (type method method) | |
| 888 | (type list lst) | |
| 889 | (values list)) | |
| 890 | (let ((body (term-body term))) | |
| 891 | (if (term$is-application-form? body) | |
| 892 | (progn | |
| 893 | (if (method-is-of-same-operator (term$method body) method) | |
| 894 | (list-a-subs (term$arg-1 body) method | |
| 895 | (list-a-subs (term$arg-2 body) | |
| 896 | method | |
| 897 | lst)) | |
| 898 | (cons term lst))) | |
| 899 | (cons term lst))))) | |
| 936 | 900 | ;; |
| 937 | 901 | (list-a-subs term method nil))) |
| 938 | 902 | |
| 943 | 907 | |
| 944 | 908 | (defun list-assoc-id-subterms (term method) |
| 945 | 909 | (declare (type term term) |
| 946 | (type method method)) | |
| 910 | (type method method)) | |
| 947 | 911 | (list-assoc-id-subterms-aux term method nil)) |
| 948 | 912 | |
| 949 | 913 | (defun list-assoc-id-subterms-aux (term method lst) |
| 950 | 914 | (declare (type term term) |
| 951 | (type method method) | |
| 952 | (type list lst)) | |
| 915 | (type method method) | |
| 916 | (type list lst)) | |
| 953 | 917 | (let ((body (term-body term))) |
| 954 | 918 | (if (term$is-variable? body) |
| 955 | (cons term lst) | |
| 956 | (if (term-is-zero-for-method term method) | |
| 957 | lst | |
| 958 | (if (term$is-application-form? body) | |
| 959 | (if (method-is-of-same-operator (term$head body) method) | |
| 960 | (list-assoc-id-subterms-aux (term$arg-1 body) | |
| 961 | method | |
| 962 | (list-assoc-id-subterms-aux | |
| 963 | (term$arg-2 body) | |
| 964 | method | |
| 965 | lst)) | |
| 966 | (cons term lst)) | |
| 967 | (cons term lst)))))) | |
| 919 | (cons term lst) | |
| 920 | (if (term-is-zero-for-method term method) | |
| 921 | lst | |
| 922 | (if (term$is-application-form? body) | |
| 923 | (if (method-is-of-same-operator (term$head body) method) | |
| 924 | (list-assoc-id-subterms-aux (term$arg-1 body) | |
| 925 | method | |
| 926 | (list-assoc-id-subterms-aux | |
| 927 | (term$arg-2 body) | |
| 928 | method | |
| 929 | lst)) | |
| 930 | (cons term lst)) | |
| 931 | (cons term lst)))))) | |
| 968 | 932 | |
| 969 | 933 | #+:other |
| 970 | 934 | (defun list-assoc-id-subterms (term method) |
| 971 | 935 | (declare (type term term) |
| 972 | (type method method) | |
| 973 | (values list)) | |
| 936 | (type method method) | |
| 937 | (values list)) | |
| 974 | 938 | (labels ((list-a-subs (term method lst) |
| 975 | (declare (type term term) | |
| 976 | (type method method) | |
| 977 | (type list lst) | |
| 978 | (values list)) | |
| 979 | (let ((body (term-body term))) | |
| 980 | (if (term$is-variable? body) | |
| 981 | (cons term lst) | |
| 982 | (if (term-is-zero-for-method term method) | |
| 983 | lst | |
| 984 | (if (term$is-application-form? body) | |
| 985 | (if (method-is-of-same-operator (term$head body) method) | |
| 986 | (list-a-subs (term$arg-1 body) | |
| 987 | method | |
| 988 | (list-a-subs | |
| 989 | (term$arg-2 body) | |
| 990 | method | |
| 991 | lst)) | |
| 992 | (cons term lst)) | |
| 993 | (cons term lst))))))) | |
| 939 | (declare (type term term) | |
| 940 | (type method method) | |
| 941 | (type list lst) | |
| 942 | (values list)) | |
| 943 | (let ((body (term-body term))) | |
| 944 | (if (term$is-variable? body) | |
| 945 | (cons term lst) | |
| 946 | (if (term-is-zero-for-method term method) | |
| 947 | lst | |
| 948 | (if (term$is-application-form? body) | |
| 949 | (if (method-is-of-same-operator (term$head body) method) | |
| 950 | (list-a-subs (term$arg-1 body) | |
| 951 | method | |
| 952 | (list-a-subs | |
| 953 | (term$arg-2 body) | |
| 954 | method | |
| 955 | lst)) | |
| 956 | (cons term lst)) | |
| 957 | (cons term lst))))))) | |
| 994 | 958 | ;; |
| 995 | 959 | (list-a-subs term method nil))) |
| 996 | 960 | |
| 1004 | 968 | #+GCL |
| 1005 | 969 | (defun list-AC-subterms (term method) |
| 1006 | 970 | (declare (type term term) |
| 1007 | (type method method)) | |
| 971 | (type method method)) | |
| 1008 | 972 | (list-ac-subterms-aux term method nil)) |
| 1009 | 973 | |
| 1010 | 974 | (defun list-AC-subterms-aux (term method lst) |
| 1011 | 975 | (declare (type term term) |
| 1012 | (type method method) | |
| 1013 | (type list lst)) | |
| 976 | (type method method) | |
| 977 | (type list lst)) | |
| 1014 | 978 | (let ((body (term-body term))) |
| 1015 | 979 | (if (term$is-application-form? body) |
| 1016 | (if (method-is-ac-restriction-of (term$head body) method) | |
| 1017 | (list-ac-subterms-aux (term$arg-1 body) | |
| 1018 | method | |
| 1019 | (list-ac-subterms-aux (term$arg-2 body) | |
| 1020 | method | |
| 1021 | lst)) | |
| 1022 | (cons term lst)) | |
| 1023 | (cons term lst)))) | |
| 980 | (if (method-is-ac-restriction-of (term$head body) method) | |
| 981 | (list-ac-subterms-aux (term$arg-1 body) | |
| 982 | method | |
| 983 | (list-ac-subterms-aux (term$arg-2 body) | |
| 984 | method | |
| 985 | lst)) | |
| 986 | (cons term lst)) | |
| 987 | (cons term lst)))) | |
| 1024 | 988 | |
| 1025 | 989 | #-GCL |
| 1026 | 990 | (defun list-AC-subterms (term method) |
| 1027 | 991 | (declare (type term term) |
| 1028 | (type method method)) | |
| 992 | (type method method)) | |
| 1029 | 993 | (labels ((list-subs (term method lst) |
| 1030 | (declare (type term term) | |
| 1031 | (type method method) | |
| 1032 | (type list lst)) | |
| 1033 | (let ((body (term-body term))) | |
| 1034 | (if (term$is-application-form? body) | |
| 1035 | (if (method-is-ac-restriction-of (term$head body) method) | |
| 1036 | (list-subs (term$arg-1 body) | |
| 1037 | method | |
| 1038 | (list-subs (term$arg-2 body) | |
| 1039 | method | |
| 1040 | lst)) | |
| 1041 | (cons term lst)) | |
| 1042 | (cons term lst))))) | |
| 994 | (declare (type term term) | |
| 995 | (type method method) | |
| 996 | (type list lst)) | |
| 997 | (let ((body (term-body term))) | |
| 998 | (if (term$is-application-form? body) | |
| 999 | (if (method-is-ac-restriction-of (term$head body) method) | |
| 1000 | (list-subs (term$arg-1 body) | |
| 1001 | method | |
| 1002 | (list-subs (term$arg-2 body) | |
| 1003 | method | |
| 1004 | lst)) | |
| 1005 | (cons term lst)) | |
| 1006 | (cons term lst))))) | |
| 1043 | 1007 | ;; |
| 1044 | 1008 | (list-subs term method nil))) |
| 1045 | 1009 | |
| 1052 | 1016 | #+GCL |
| 1053 | 1017 | (defun list-ACZ-subterms (term meth) |
| 1054 | 1018 | (declare (type term term) |
| 1055 | (type method meth)) | |
| 1019 | (type method meth)) | |
| 1056 | 1020 | (list-ACZ-subterms-aux term meth nil)) |
| 1057 | 1021 | |
| 1058 | 1022 | (defun list-ACZ-subterms-aux (term method lst) |
| 1059 | 1023 | (declare (type term term) |
| 1060 | (type method method) | |
| 1061 | (type list lst)) | |
| 1024 | (type method method) | |
| 1025 | (type list lst)) | |
| 1062 | 1026 | (let ((body (term-body term))) |
| 1063 | 1027 | (if (term$is-variable? body) |
| 1064 | (cons term lst) | |
| 1065 | (if (term-is-zero-for-method term method) | |
| 1066 | lst | |
| 1067 | (if (term$is-application-form? body) | |
| 1068 | (if (method-is-ac-restriction-of (term$head body) method) | |
| 1069 | ;; then the operator is binary of course | |
| 1070 | (list-ACZ-subterms-aux (term$arg-1 body) | |
| 1071 | method | |
| 1072 | (list-ACZ-subterms-aux | |
| 1073 | (term$arg-2 body) method lst)) | |
| 1074 | (cons term lst)) | |
| 1075 | (cons term lst)))))) | |
| 1028 | (cons term lst) | |
| 1029 | (if (term-is-zero-for-method term method) | |
| 1030 | lst | |
| 1031 | (if (term$is-application-form? body) | |
| 1032 | (if (method-is-ac-restriction-of (term$head body) method) | |
| 1033 | ;; then the operator is binary of course | |
| 1034 | (list-ACZ-subterms-aux (term$arg-1 body) | |
| 1035 | method | |
| 1036 | (list-ACZ-subterms-aux | |
| 1037 | (term$arg-2 body) method lst)) | |
| 1038 | (cons term lst)) | |
| 1039 | (cons term lst)))))) | |
| 1076 | 1040 | |
| 1077 | 1041 | #-GCL |
| 1078 | 1042 | (defun list-ACZ-subterms (term meth) |
| 1079 | 1043 | (declare (type term term) |
| 1080 | (type method meth)) | |
| 1044 | (type method meth)) | |
| 1081 | 1045 | (labels ((list-subs (term method lst) |
| 1082 | (declare (type term term) | |
| 1083 | (type method method) | |
| 1084 | (type list lst)) | |
| 1085 | (let ((body (term-body term))) | |
| 1086 | (if (term$is-variable? body) | |
| 1087 | (cons term lst) | |
| 1088 | (if (term-is-zero-for-method term method) | |
| 1089 | lst | |
| 1090 | (if (term$is-application-form? body) | |
| 1091 | (if ;; (method-is-ac-restriction-of (term$head body) | |
| 1092 | ;; method) | |
| 1093 | (method-is-of-same-operator (term$head body) | |
| 1094 | method) | |
| 1095 | ;; then the operator is binary of course | |
| 1096 | (list-subs (term$arg-1 body) | |
| 1097 | method | |
| 1098 | (list-subs (term$arg-2 body) | |
| 1099 | method | |
| 1100 | lst)) | |
| 1101 | (cons term lst)) | |
| 1102 | (cons term lst))))))) | |
| 1046 | (declare (type term term) | |
| 1047 | (type method method) | |
| 1048 | (type list lst)) | |
| 1049 | (let ((body (term-body term))) | |
| 1050 | (if (term$is-variable? body) | |
| 1051 | (cons term lst) | |
| 1052 | (if (term-is-zero-for-method term method) | |
| 1053 | lst | |
| 1054 | (if (term$is-application-form? body) | |
| 1055 | (if ;; (method-is-ac-restriction-of (term$head body) | |
| 1056 | ;; method) | |
| 1057 | (method-is-of-same-operator (term$head body) | |
| 1058 | method) | |
| 1059 | ;; then the operator is binary of course | |
| 1060 | (list-subs (term$arg-1 body) | |
| 1061 | method | |
| 1062 | (list-subs (term$arg-2 body) | |
| 1063 | method | |
| 1064 | lst)) | |
| 1065 | (cons term lst)) | |
| 1066 | (cons term lst))))))) | |
| 1103 | 1067 | ;; |
| 1104 | 1068 | (list-subs term meth nil))) |
| 1105 | 1069 | |
| 1112 | 1076 | ;;; |
| 1113 | 1077 | (defun make-right-assoc-normal-form (meth subterms) |
| 1114 | 1078 | (declare (type method meth) |
| 1115 | (type list subterms)) | |
| 1079 | (type list subterms)) | |
| 1116 | 1080 | #|| |
| 1117 | 1081 | (when *term-debug* |
| 1118 | 1082 | (format t "~&make-right-assoc-normal-form:") |
| 1124 | 1088 | (force-output)) |
| 1125 | 1089 | ||# |
| 1126 | 1090 | (let ((res (if (= (length subterms) 2) |
| 1127 | (make-applform (method-coarity meth) meth subterms) | |
| 1128 | (make-applform (method-coarity meth) | |
| 1129 | meth | |
| 1130 | (list (pop subterms) | |
| 1131 | (make-right-assoc-normal-form meth subterms)))))) | |
| 1091 | (make-applform (method-coarity meth) meth subterms) | |
| 1092 | (make-applform (method-coarity meth) | |
| 1093 | meth | |
| 1094 | (list (pop subterms) | |
| 1095 | (make-right-assoc-normal-form meth subterms)))))) | |
| 1132 | 1096 | ;; (when *term-debug* |
| 1133 | 1097 | ;; (format t "~& -- new term = ")(print-term-tree res) (force-output)) |
| 1134 | 1098 | res)) |
| 1140 | 1104 | |
| 1141 | 1105 | (defun make-right-assoc-normal-form-with-sort-check (meth subterms) |
| 1142 | 1106 | (declare (type method meth) |
| 1143 | (type list subterms) | |
| 1144 | (values term)) | |
| 1107 | (type list subterms) | |
| 1108 | (values term)) | |
| 1145 | 1109 | (if (= 1 (length subterms)) |
| 1146 | 1110 | (car subterms) |
| 1147 | 1111 | (if (= 2 (length subterms)) |
| 1148 | (make-term-with-sort-check-bin meth subterms) | |
| 1112 | (make-term-with-sort-check-bin meth subterms) | |
| 1149 | 1113 | (make-term-with-sort-check-bin |
| 1150 | 1114 | meth |
| 1151 | 1115 | (list (car subterms) |
| 1152 | (make-right-assoc-normal-form-with-sort-check meth | |
| 1153 | (cdr subterms))))))) | |
| 1116 | (make-right-assoc-normal-form-with-sort-check meth | |
| 1117 | (cdr subterms))))))) | |
| 1154 | 1118 | |
| 1155 | 1119 | ;;; RIGHT-ASSOCIATIVE-NORMAL-FORM : TERM -> TERM |
| 1156 | 1120 | ;;; Reconstruct the subterms to be right associative iff the head operator has |
| 1168 | 1132 | (let ((body (term-body t1))) |
| 1169 | 1133 | ;; (break "OK?") |
| 1170 | 1134 | (cond ((term$is-constant? body) t1) |
| 1171 | ((term$is-variable? body) t1) | |
| 1172 | (t (let ((h-op (term$head body))) | |
| 1173 | ;; (print-chaos-object h-op) | |
| 1174 | (cond ((theory-contains-associativity (method-theory h-op)) | |
| 1175 | ;; (break "OK3") | |
| 1176 | (make-right-assoc-normal-form-with-sort-check | |
| 1177 | h-op | |
| 1178 | (mapcar #'right-associative-normal-form | |
| 1179 | (list-assoc-subterms t1 h-op)))) | |
| 1180 | (t (make-applform (method-coarity h-op) | |
| 1181 | h-op | |
| 1182 | (mapcar #'right-associative-normal-form | |
| 1183 | (term$subterms body)))))))))) | |
| 1135 | ((term$is-variable? body) t1) | |
| 1136 | (t (let ((h-op (term$head body))) | |
| 1137 | ;; (print-chaos-object h-op) | |
| 1138 | (cond ((theory-contains-associativity (method-theory h-op)) | |
| 1139 | ;; (break "OK3") | |
| 1140 | (make-right-assoc-normal-form-with-sort-check | |
| 1141 | h-op | |
| 1142 | (mapcar #'right-associative-normal-form | |
| 1143 | (list-assoc-subterms t1 h-op)))) | |
| 1144 | (t (make-applform (method-coarity h-op) | |
| 1145 | h-op | |
| 1146 | (mapcar #'right-associative-normal-form | |
| 1147 | (term$subterms body)))))))))) | |
| 1184 | 1148 | |
| 1185 | 1149 | ;;; RIGHT-ASSOCIATIVE-ID-NORMAL-FORM : term -> term |
| 1186 | 1150 | ;;; Reconstruct the subterms to be right associative considering identity, iff |
| 1191 | 1155 | #|| |
| 1192 | 1156 | (defun right-associative-id-normal-form (t1) |
| 1193 | 1157 | (declare (type term t1) |
| 1194 | (values term)) | |
| 1158 | (values term)) | |
| 1195 | 1159 | ;; (break) |
| 1196 | 1160 | (let ((body (term-body t1))) |
| 1197 | 1161 | (cond ((term$is-variable? body) t1) |
| 1198 | ((term$is-constant? body) t1) | |
| 1199 | (t (let ((meth (term$head body))) | |
| 1200 | (cond ((theory-contains-AZ (method-theory meth)) | |
| 1201 | (make-right-assoc-normal-form | |
| 1202 | meth | |
| 1203 | (mapcar | |
| 1204 | #'right-associative-id-normal-form | |
| 1205 | (list-assoc-id-subterms t1 meth)) | |
| 1206 | )) | |
| 1207 | ;; note this is only top-level normalization. | |
| 1208 | (t t1))))))) | |
| 1162 | ((term$is-constant? body) t1) | |
| 1163 | (t (let ((meth (term$head body))) | |
| 1164 | (cond ((theory-contains-AZ (method-theory meth)) | |
| 1165 | (make-right-assoc-normal-form | |
| 1166 | meth | |
| 1167 | (mapcar | |
| 1168 | #'right-associative-id-normal-form | |
| 1169 | (list-assoc-id-subterms t1 meth)) | |
| 1170 | )) | |
| 1171 | ;; note this is only top-level normalization. | |
| 1172 | (t t1))))))) | |
| 1209 | 1173 | ||# |
| 1210 | 1174 | |
| 1211 | 1175 | (defun right-associative-id-normal-form (t1) |
| 1212 | 1176 | (declare (type term t1)) |
| 1213 | 1177 | (if (term-is-applform? t1) |
| 1214 | 1178 | (let ((meth (term-head t1))) |
| 1215 | (if (theory-contains-az (method-theory meth)) | |
| 1216 | (make-right-assoc-normal-form | |
| 1217 | meth | |
| 1218 | (mapcar #'right-associative-id-normal-form | |
| 1219 | (list-assoc-id-subterms t1 meth))) | |
| 1220 | t1)) | |
| 1179 | (if (theory-contains-az (method-theory meth)) | |
| 1180 | (make-right-assoc-normal-form | |
| 1181 | meth | |
| 1182 | (mapcar #'right-associative-id-normal-form | |
| 1183 | (list-assoc-id-subterms t1 meth))) | |
| 1184 | t1)) | |
| 1221 | 1185 | t1)) |
| 1222 | 1186 | |
| 1223 | 1187 | ;;; ID-NORMAL-FORM : term -> term |
| 1227 | 1191 | (declare (type term t1)) |
| 1228 | 1192 | (let ((body (term-body t1))) |
| 1229 | 1193 | (cond ((term$is-constant? body) t1) |
| 1230 | ((term$is-variable? body) t1) | |
| 1231 | (t (let ((meth (term$head body))) | |
| 1232 | (cond ((term-is-zero-for-method (term$arg-1 body) meth) | |
| 1233 | (id-normal-form (term$arg-2 body))) | |
| 1234 | ((term-is-zero-for-method (term$arg-2 body) meth) | |
| 1235 | (id-normal-form (term$arg-1 body))) | |
| 1236 | (t t1))))))) | |
| 1194 | ((term$is-variable? body) t1) | |
| 1195 | (t (let ((meth (term$head body))) | |
| 1196 | (cond ((term-is-zero-for-method (term$arg-1 body) meth) | |
| 1197 | (id-normal-form (term$arg-2 body))) | |
| 1198 | ((term-is-zero-for-method (term$arg-2 body) meth) | |
| 1199 | (id-normal-form (term$arg-1 body))) | |
| 1200 | (t t1))))))) | |
| 1237 | 1201 | |
| 1238 | 1202 | ;;; MAKE-RIGHT-ASSOC-ID-NORMAL-FORM : method subterms -> term |
| 1239 | 1203 | ;;; |
| 1240 | 1204 | (defun make-right-assoc-id-normal-form (method subterms) |
| 1241 | 1205 | (declare (type method method) |
| 1242 | (type list subterms) | |
| 1243 | (values list)) | |
| 1206 | (type list subterms) | |
| 1207 | (values list)) | |
| 1244 | 1208 | (make-right-assoc-normal-form method (filter-zero method subterms))) |
| 1245 | 1209 | |
| 1246 | 1210 | (defun filter-zero (method subterms) |
| 1247 | 1211 | (declare (type method method) |
| 1248 | (type list subterms)) | |
| 1212 | (type list subterms)) | |
| 1249 | 1213 | (when subterms |
| 1250 | 1214 | (if (term-is-zero-for-method (car subterms) method) |
| 1251 | (filter-zero method (cdr subterms)) | |
| 1215 | (filter-zero method (cdr subterms)) | |
| 1252 | 1216 | (cons (car subterms) |
| 1253 | (filter-zero method (cdr subterms)))))) | |
| 1217 | (filter-zero method (cdr subterms)))))) | |
| 1254 | 1218 | |
| 1255 | 1219 | |
| 1256 | 1220 | ;;; ********** |
| 1262 | 1226 | |
| 1263 | 1227 | (defun term-copy-and-returns-list-variables (term) |
| 1264 | 1228 | (declare (type term term) |
| 1265 | (values term list)) | |
| 1229 | (values term list)) | |
| 1266 | 1230 | (multiple-value-bind (res list-new-var) |
| 1267 | 1231 | (copy-list-term-using-list-var (list term) nil) |
| 1268 | 1232 | (declare (type list res list-new-var)) |
| 1270 | 1234 | |
| 1271 | 1235 | (defun copy-list-term-using-list-var (term-list list-new-var &key (test #'variable-eq)) |
| 1272 | 1236 | (declare (type list term-list list-new-var) |
| 1273 | (values list list)) | |
| 1237 | (values list list)) | |
| 1274 | 1238 | (let ((v-image nil) |
| 1275 | (list-copied-term nil)) | |
| 1239 | (list-copied-term nil)) | |
| 1276 | 1240 | (values (mapcar #'(lambda (term) |
| 1277 | (cond ((term-is-variable? term) | |
| 1278 | (if (setq v-image | |
| 1279 | (cdr (assoc term list-new-var :test test))) | |
| 1280 | v-image | |
| 1281 | (let ((new-var (variable-copy term))) | |
| 1282 | (declare (type term new-var)) | |
| 1283 | (setf list-new-var (acons term new-var list-new-var)) | |
| 1284 | new-var))) | |
| 1285 | ((term-is-builtin-constant? term) term) | |
| 1286 | ((term-is-lisp-form? term) term) | |
| 1287 | (t (multiple-value-setq (list-copied-term list-new-var) | |
| 1288 | (copy-list-term-using-list-var (term-subterms term) | |
| 1289 | list-new-var | |
| 1290 | :test test)) | |
| 1291 | (make-applform (term-sort term) | |
| 1292 | (term-head term) | |
| 1293 | list-copied-term)))) | |
| 1294 | term-list) | |
| 1295 | list-new-var))) | |
| 1241 | (cond ((term-is-variable? term) | |
| 1242 | (if (setq v-image | |
| 1243 | (cdr (assoc term list-new-var :test test))) | |
| 1244 | v-image | |
| 1245 | (let ((new-var (variable-copy term))) | |
| 1246 | (declare (type term new-var)) | |
| 1247 | (setf list-new-var (acons term new-var list-new-var)) | |
| 1248 | new-var))) | |
| 1249 | ((term-is-builtin-constant? term) term) | |
| 1250 | ((term-is-lisp-form? term) term) | |
| 1251 | (t (multiple-value-setq (list-copied-term list-new-var) | |
| 1252 | (copy-list-term-using-list-var (term-subterms term) | |
| 1253 | list-new-var | |
| 1254 | :test test)) | |
| 1255 | (make-applform (term-sort term) | |
| 1256 | (term-head term) | |
| 1257 | list-copied-term)))) | |
| 1258 | term-list) | |
| 1259 | list-new-var))) | |
| 1296 | 1260 | |
| 1297 | 1261 | ;;; COPY-TERM-USING-VARIABLE : term List[variable] -> term |
| 1298 | 1262 | ;;; |
| 1299 | 1263 | (defun copy-term-using-variable (term list-new-var &optional (test #'variable-eq)) |
| 1300 | 1264 | (declare (type term term) |
| 1301 | (type list list-new-var) | |
| 1302 | (values term)) | |
| 1265 | (type list list-new-var) | |
| 1266 | (values term)) | |
| 1303 | 1267 | (multiple-value-bind (res list-new-var-res) |
| 1304 | 1268 | (copy-list-term-using-list-var (list term) list-new-var :test test) |
| 1305 | 1269 | (declare (ignore list-new-var-res) |
| 1306 | (type list res)) | |
| 1270 | (type list res)) | |
| 1307 | 1271 | (car res))) |
| 1308 | 1272 | |
| 1309 | 1273 | ;;; ***************************** |
| 1324 | 1288 | (declare (type term term)) |
| 1325 | 1289 | (let ((body (term-body term))) |
| 1326 | 1290 | (if (term$is-application-form? body) |
| 1327 | (let* ((f (term$head body)) | |
| 1328 | (subterms (mapcar #'theory-standard-form (term$subterms body))) | |
| 1329 | (th (method-theory f)) | |
| 1330 | (theory-info (theory-info th)) | |
| 1331 | (t1 nil) | |
| 1332 | (t2 nil)) | |
| 1333 | (let ((val (cond ((theory-info-is-empty-for-matching theory-info) | |
| 1334 | (make-applform (method-coarity f) f subterms)) | |
| 1335 | ||
| 1336 | ;; case x+0 -> x, 0+x -> x | |
| 1337 | ((and (progn | |
| 1338 | (setq t1 (car subterms) t2 (cadr subterms)) | |
| 1339 | (theory-zero th)) | |
| 1340 | (let ((zero (car (theory-zero th)))) | |
| 1341 | (cond ((term-is-similar? t1 zero) t2) | |
| 1342 | ((term-is-similar? t2 zero) t1))))) | |
| 1343 | ;; case x+x -> x | |
| 1344 | ((or (theory-info-is-I theory-info) | |
| 1345 | (theory-info-is-CI theory-info)) | |
| 1346 | (if (term-is-similar? t1 t2) t1)) | |
| 1347 | ||
| 1348 | ;; It is more complex in the next cases because of | |
| 1349 | ;; the presence of non trivial extensions | |
| 1350 | ;; and of commutativity, so we refer to appropriate | |
| 1351 | ;; procedure | |
| 1352 | ((theory-info-is-AI theory-info) | |
| 1353 | (A-idempotent-normal-form f t1 t2)) | |
| 1354 | ||
| 1355 | ((or (theory-info-is-ACI theory-info) | |
| 1356 | (theory-info-is-ACIZ theory-info)) | |
| 1357 | (AC-idempotent-normal-form f t1 t2)) | |
| 1358 | ))) | |
| 1359 | (if val | |
| 1360 | val | |
| 1361 | (make-applform (method-coarity f) f subterms)))) | |
| 1291 | (let* ((f (term$head body)) | |
| 1292 | (subterms (mapcar #'theory-standard-form (term$subterms body))) | |
| 1293 | (th (method-theory f)) | |
| 1294 | (theory-info (theory-info th)) | |
| 1295 | (t1 nil) | |
| 1296 | (t2 nil)) | |
| 1297 | (let ((val (cond ((theory-info-is-empty-for-matching theory-info) | |
| 1298 | (make-applform (method-coarity f) f subterms)) | |
| 1299 | ||
| 1300 | ;; case x+0 -> x, 0+x -> x | |
| 1301 | ((and (progn | |
| 1302 | (setq t1 (car subterms) t2 (cadr subterms)) | |
| 1303 | (theory-zero th)) | |
| 1304 | (let ((zero (car (theory-zero th)))) | |
| 1305 | (cond ((term-is-similar? t1 zero) t2) | |
| 1306 | ((term-is-similar? t2 zero) t1))))) | |
| 1307 | ;; case x+x -> x | |
| 1308 | ((or (theory-info-is-I theory-info) | |
| 1309 | (theory-info-is-CI theory-info)) | |
| 1310 | (if (term-is-similar? t1 t2) t1)) | |
| 1311 | ||
| 1312 | ;; It is more complex in the next cases because of | |
| 1313 | ;; the presence of non trivial extensions | |
| 1314 | ;; and of commutativity, so we refer to appropriate | |
| 1315 | ;; procedure | |
| 1316 | ((theory-info-is-AI theory-info) | |
| 1317 | (A-idempotent-normal-form f t1 t2)) | |
| 1318 | ||
| 1319 | ((or (theory-info-is-ACI theory-info) | |
| 1320 | (theory-info-is-ACIZ theory-info)) | |
| 1321 | (AC-idempotent-normal-form f t1 t2)) | |
| 1322 | ))) | |
| 1323 | (if val | |
| 1324 | val | |
| 1325 | (make-applform (method-coarity f) f subterms)))) | |
| 1362 | 1326 | term))) |
| 1363 | 1327 | |
| 1364 | 1328 | (defun A-idempotent-normal-form (f t1 t2) |
| 1365 | 1329 | (declare (type method f) |
| 1366 | (type term t1 t2)) | |
| 1330 | (type term t1 t2)) | |
| 1367 | 1331 | (if (term-is-similar? t1 t2) |
| 1368 | 1332 | t1 |
| 1369 | 1333 | (make-applform (method-coarity f) f (list t1 t2)))) |
| 1370 | 1334 | |
| 1371 | 1335 | (defun AC-idempotent-normal-form (f t1 t2) |
| 1372 | 1336 | (declare (type method f) |
| 1373 | (type term t1 t2)) | |
| 1337 | (type term t1 t2)) | |
| 1374 | 1338 | (if (term-is-similar? t1 t2) |
| 1375 | 1339 | t1 |
| 1376 | 1340 | (make-applform (method-coarity f) f (list t1 t2)))) |
| 1399 | 1363 | (declare (type term term)) |
| 1400 | 1364 | (if (term-is-application-form? term) |
| 1401 | 1365 | (make-applform (method-coarity (term-head term)) |
| 1402 | (term-head term) | |
| 1403 | (mapcar #'clean-term (term-subterms term))) | |
| 1366 | (term-head term) | |
| 1367 | (mapcar #'clean-term (term-subterms term))) | |
| 1404 | 1368 | term)) |
| 1405 | 1369 | |
| 1406 | 1370 | (defun term-make-zero (method) |
| 1407 | 1371 | (declare (type method method) |
| 1408 | (values (or null term))) | |
| 1372 | (values (or null term))) | |
| 1409 | 1373 | (let ((zero (car (theory-zero (method-theory method))))) |
| 1410 | 1374 | (if zero |
| 1411 | zero | |
| 1412 | nil))) | |
| 1375 | zero | |
| 1376 | nil))) | |
| 1413 | 1377 | |
| 1414 | 1378 | ;;; SUPPLY-PSUEDO-VARIABLES |
| 1415 | 1379 | ;;; |
| 1416 | 1380 | (defun supply-psuedo-variables (term) |
| 1417 | 1381 | (declare (type term term) |
| 1418 | (values term)) | |
| 1382 | (values term)) | |
| 1419 | 1383 | (let ((target (simple-copy-term term))) |
| 1420 | 1384 | (declare (type term target)) |
| 1421 | 1385 | (let ((vars (term-variables target))) |
| 1422 | 1386 | (unless vars (return-from supply-psuedo-variables term)) |
| 1423 | 1387 | (dolist (var vars target) |
| 1424 | (term-replace var | |
| 1425 | (make-pvariable-term (variable-sort var) | |
| 1426 | (variable-name var) | |
| 1427 | (variable-print-name var))))))) | |
| 1388 | (term-replace var | |
| 1389 | (make-pvariable-term (variable-sort var) | |
| 1390 | (variable-name var) | |
| 1391 | (variable-print-name var))))))) | |
| 1428 | 1392 | |
| 1429 | 1393 | ;;; *********************** |
| 1430 | 1394 | ;;; MISC PREDICATES ON TERM |
| 1433 | 1397 | (if (term-is-applform? term) |
| 1434 | 1398 | (not (method-is-behavioural (term-head term))) |
| 1435 | 1399 | t)) |
| 1436 | ||
| 1400 | ||
| 1437 | 1401 | (defun term-is-of-behavioural? (term) |
| 1438 | 1402 | (if (term-is-applform? term) |
| 1439 | 1403 | (method-is-behavioural (term-head term)) |
| 1440 | 1404 | nil)) |
| 1441 | 1405 | |
| 1442 | 1406 | (defun term-is-of-behavioural*? (term |
| 1443 | &optional (opinfo-table *current-opinfo-table*)) | |
| 1407 | &optional (opinfo-table *current-opinfo-table*)) | |
| 1444 | 1408 | (if (term-is-applform? term) |
| 1445 | 1409 | (or (method-is-behavioural (term-head term)) |
| 1446 | (method-is-coherent (term-head term) opinfo-table)) | |
| 1410 | (method-is-coherent (term-head term) opinfo-table)) | |
| 1447 | 1411 | nil)) |
| 1448 | 1412 | |
| 1449 | 1413 | (defun term-is-behavioural? (term) |
| 1450 | 1414 | (declare (type term term) |
| 1451 | (values (or null t))) | |
| 1415 | (values (or null t))) | |
| 1452 | 1416 | (and (sort-is-hidden (term-sort term)) |
| 1453 | 1417 | (or (term-is-constant? term) |
| 1454 | (let ((head (term-head term))) | |
| 1455 | (or (method-is-behavioural head) | |
| 1456 | (method-is-coherent head)))))) | |
| 1418 | (let ((head (term-head term))) | |
| 1419 | (or (method-is-behavioural head) | |
| 1420 | (method-is-coherent head)))))) | |
| 1457 | 1421 | |
| 1458 | 1422 | (defun term-can-be-in-beh-axiom? (term) |
| 1459 | 1423 | (declare (type term term) |
| 1460 | (values (or null t))) | |
| 1424 | (values (or null t))) | |
| 1461 | 1425 | (cond ((term-is-applform? term) |
| 1462 | (if (eq (term-head term) *bool-if*) | |
| 1463 | (and (term-can-be-in-beh-axiom? (term-arg-2 term)) | |
| 1464 | (term-can-be-in-beh-axiom? (term-arg-3 term))) | |
| 1465 | (and (if (find-if #'(lambda (x) | |
| 1466 | (sort-is-hidden x)) | |
| 1467 | (mapcar #'(lambda (y) (term-sort y)) | |
| 1468 | (term-subterms term))) | |
| 1469 | ;; patch Tue May 26 10:11:22 JST 1998 | |
| 1470 | (or (method-is-behavioural (term-head term)) | |
| 1471 | (method-is-coherent (term-head term))) | |
| 1472 | t) | |
| 1473 | (every #'term-can-be-in-beh-axiom? (term-subterms term)))) | |
| 1474 | ) | |
| 1475 | (t t))) | |
| 1426 | (if (eq (term-head term) *bool-if*) | |
| 1427 | (and (term-can-be-in-beh-axiom? (term-arg-2 term)) | |
| 1428 | (term-can-be-in-beh-axiom? (term-arg-3 term))) | |
| 1429 | (and (if (find-if #'(lambda (x) | |
| 1430 | (sort-is-hidden x)) | |
| 1431 | (mapcar #'(lambda (y) (term-sort y)) | |
| 1432 | (term-subterms term))) | |
| 1433 | (or (method-is-behavioural (term-head term)) | |
| 1434 | (method-is-coherent (term-head term))) | |
| 1435 | t) | |
| 1436 | (every #'term-can-be-in-beh-axiom? (term-subterms term))))) | |
| 1437 | (t t))) | |
| 1476 | 1438 | |
| 1477 | 1439 | (defun term-is-non-behavioural? (term) |
| 1478 | 1440 | (declare (type term term) |
| 1479 | (values (or null t))) | |
| 1441 | (values (or null t))) | |
| 1480 | 1442 | (not (term-is-behavioural? term))) |
| 1481 | 1443 | |
| 1482 | 1444 | ;;; returns t iff given term is a constructor, i.e., |
| 1485 | 1447 | (defun term-is-constructor? (term) |
| 1486 | 1448 | (or (term-is-builtin-constant? term) |
| 1487 | 1449 | (and (term-is-application-form? term) |
| 1488 | (method-is-constructor? (term-head term))))) | |
| 1450 | (method-is-constructor? (term-head term))))) | |
| 1489 | 1451 | |
| 1490 | 1452 | ;;; we sometimes need to make variables on the fly.----------------------------- |
| 1491 | 1453 | ;;; |
| 1493 | 1455 | (declare (type fixnum *var-num*)) |
| 1494 | 1456 | (defun generate-variable (sort) |
| 1495 | 1457 | (@create-variable-term (intern (format nil "#Genvar-~d" (incf *var-num*))) |
| 1496 | sort )) | |
| 1458 | sort )) | |
| 1497 | 1459 | (defun make-new-variable (name sort &optional (pname name)) |
| 1498 | 1460 | (@create-variable-term (intern (format nil "~a-~d" name (incf *var-num*))) |
| 1499 | sort | |
| 1500 | pname)) | |
| 1461 | sort | |
| 1462 | pname)) | |
| 1501 | 1463 | (defun rename-variable (var) |
| 1502 | 1464 | (@create-variable-term (intern (format nil "~a-~d" |
| 1503 | (variable-name var) | |
| 1504 | (incf *var-num*))) | |
| 1505 | (variable-sort var))) | |
| 1465 | (variable-name var) | |
| 1466 | (incf *var-num*))) | |
| 1467 | (variable-sort var))) | |
| 1506 | 1468 | ) |
| 1507 | 1469 | |
| 1508 | 1470 | ;;; inspecting term --- for debugging ----------------------------------------- |
| 1509 | 1471 | ;;; |
| 1510 | 1472 | (defun inspect-term (term &optional (occur nil) (context *current-module*)) |
| 1511 | 1473 | (flet ((print-occr () |
| 1512 | (format t " ~A" (if (null occur) "top" (reverse occur))))) | |
| 1474 | (format t " ~A" (if (null occur) "top" (reverse occur))))) | |
| 1513 | 1475 | (with-in-module (context) |
| 1514 | 1476 | (print-next) |
| 1515 | 1477 | (format t "[NF=~a,LP=~a] " (term-is-reduced? term) (term-is-lowest-parsed? term)) |
| 1516 | 1478 | (cond ((term-is-applform? term) |
| 1517 | (print-chaos-object (term-head term)) | |
| 1518 | (print-occr) | |
| 1519 | (dotimes (x (length (term-subterms term))) | |
| 1520 | (let ((*print-indent* (+ 2 *print-indent*))) | |
| 1521 | (inspect-term (term-arg-n term x) (cons (1+ x) occur))))) | |
| 1522 | ((term-is-builtin-constant? term) | |
| 1523 | (term-print-with-sort term) | |
| 1524 | (print-occr)) | |
| 1525 | (t (print-chaos-object term) | |
| 1526 | (print-occr)))))) | |
| 1479 | (print-chaos-object (term-head term)) | |
| 1480 | (print-occr) | |
| 1481 | (dotimes (x (length (term-subterms term))) | |
| 1482 | (let ((*print-indent* (+ 2 *print-indent*))) | |
| 1483 | (inspect-term (term-arg-n term x) (cons (1+ x) occur))))) | |
| 1484 | ((term-is-builtin-constant? term) | |
| 1485 | (term-print-with-sort term) | |
| 1486 | (print-occr)) | |
| 1487 | (t (print-chaos-object term) | |
| 1488 | (print-occr)))))) | |
| 1527 | 1489 | |
| 1528 | 1490 | ;;; |
| 1529 | 1491 | ;;; REPLACE-VARIABLES-WITH-TOC |
| 1532 | 1494 | (unless (term-is-applform? term) |
| 1533 | 1495 | (return-from replace-variables-with-toc term)) |
| 1534 | 1496 | (let ((vars (term-variables term)) |
| 1535 | (subst nil)) | |
| 1497 | (subst nil)) | |
| 1536 | 1498 | (cond (vars |
| 1537 | (dolist (var vars) | |
| 1538 | (unless (assoc var subst) | |
| 1539 | (let ((toc (make-pvariable-term | |
| 1540 | (variable-sort var) | |
| 1541 | (intern (concatenate 'string "`" (string (variable-name var))))))) | |
| 1542 | (push (cons var toc) subst)))) | |
| 1543 | (when (and warn (stringp warn)) | |
| 1544 | (with-output-chaos-warning () | |
| 1545 | (format t warn)) | |
| 1546 | (format t "~%substitution: ") | |
| 1547 | (print-substitution subst)) | |
| 1548 | (multiple-value-bind (res list-new-var-res) | |
| 1549 | (copy-list-term-using-list-var (list term) subst) | |
| 1550 | (declare (ignore list-new-var-res)) | |
| 1551 | (car res))) | |
| 1552 | (t term)))) | |
| 1499 | (dolist (var vars) | |
| 1500 | (unless (assoc var subst) | |
| 1501 | (let ((toc (make-pvariable-term | |
| 1502 | (variable-sort var) | |
| 1503 | (intern (concatenate 'string "`" (string (variable-name var))))))) | |
| 1504 | (push (cons var toc) subst)))) | |
| 1505 | (when (and warn (stringp warn)) | |
| 1506 | (with-output-chaos-warning () | |
| 1507 | (format t warn)) | |
| 1508 | (format t "~%substitution: ") | |
| 1509 | (print-substitution subst)) | |
| 1510 | (multiple-value-bind (res list-new-var-res) | |
| 1511 | (copy-list-term-using-list-var (list term) subst) | |
| 1512 | (declare (ignore list-new-var-res)) | |
| 1513 | (car res))) | |
| 1514 | (t term)))) | |
| 1553 | 1515 | |
| 1554 | 1516 | ;;; canonicalize--variables |
| 1555 | 1517 | ;;; |
| 1556 | 1518 | (defun canonicalize-variables (list-term module) |
| 1557 | 1519 | (with-in-module (module) |
| 1558 | 1520 | (multiple-value-bind (list-copied-term list-new-var) |
| 1559 | (copy-list-term-using-list-var list-term nil :test #'variable-equal) | |
| 1521 | (copy-list-term-using-list-var list-term nil :test #'variable-equal) | |
| 1560 | 1522 | (declare (ignore list-new-var)) |
| 1561 | 1523 | list-copied-term))) |
| 1562 | 1524 | |
| 1525 | ;;; print-term-struct | |
| 1526 | ;;; | |
| 1527 | (defun print-term-struct (term module &optional (stream *standard-output*)) | |
| 1528 | (with-in-module (module) | |
| 1529 | (let ((*standard-output* stream)) | |
| 1530 | (print-next) | |
| 1531 | (cond ((term-is-applform? term) | |
| 1532 | (format t "~a" (method-name (term-head term))) | |
| 1533 | (dotimes (x (length (term-subterms term))) | |
| 1534 | (let ((*print-indent* (+ 2 *print-indent*))) | |
| 1535 | (print-term-struct (term-arg-n term x) module)))) | |
| 1536 | ((term-is-builtin-constant? term) | |
| 1537 | (term-print term)) | |
| 1538 | (t (print-chaos-object term)))))) | |
| 1539 | ||
| 1563 | 1540 | ;;; EOF |
| 0 | 0 | ;;;-*-Mode:LISP; Package: Chaos; Base:10; Syntax:Common-lisp -*- |
| 1 | 1 | ;;; |
| 2 | ;;; Copyright (c) 2000-2014, Toshimi Sawada. All rights reserved. | |
| 2 | ;;; Copyright (c) 2000-2015, Toshimi Sawada. All rights reserved. | |
| 3 | 3 | ;;; |
| 4 | 4 | ;;; Redistribution and use in source and binary forms, with or without |
| 5 | 5 | ;;; modification, are permitted provided that the following conditions |
| 27 | 27 | ;;; |
| 28 | 28 | (in-package :chaos) |
| 29 | 29 | #|============================================================================== |
| 30 | System: Chaos | |
| 31 | Module: primitives.chaos | |
| 32 | File: term2.lisp | |
| 30 | System: Chaos | |
| 31 | Module: primitives.chaos | |
| 32 | File: term2.lisp | |
| 33 | 33 | ==============================================================================|# |
| 34 | 34 | #-:chaos-debug |
| 35 | 35 | (declaim (optimize (speed 3) (safety 0) #-GCL (debug 0))) |
| 56 | 56 | ;;; |
| 57 | 57 | (defmacro termp (obj) |
| 58 | 58 | (once-only (obj) |
| 59 | `(and (consp ,obj) (consp (car ,obj)) (integerp (caar ,obj))))) | |
| 59 | `(and (consp ,obj) (consp (car ,obj)) (integerp (caar ,obj))))) | |
| 60 | 60 | |
| 61 | 61 | (defun is-term? (obj) (termp obj)) |
| 62 | 62 | |
| 150 | 150 | (defconstant pure-builtin-constant-type #x020) |
| 151 | 151 | (defconstant system-object-type #x040) |
| 152 | 152 | (defconstant builtin-constant-type (logior psuedo-constant-type |
| 153 | pure-builtin-constant-type | |
| 154 | system-object-type)) | |
| 153 | pure-builtin-constant-type | |
| 154 | system-object-type)) | |
| 155 | 155 | (defconstant pre-encode-bit #x100) |
| 156 | 156 | (defconstant pre-variable-type (logior pre-encode-bit variable-type)) |
| 157 | 157 | (defconstant pre-application-form-type (logior pre-encode-bit |
| 158 | application-form-type)) | |
| 158 | application-form-type)) | |
| 159 | 159 | (defconstant pre-simple-lisp-code-type (logior pre-encode-bit |
| 160 | simple-lisp-code-type)) | |
| 160 | simple-lisp-code-type)) | |
| 161 | 161 | (defconstant pre-general-lisp-code-type (logior pre-encode-bit |
| 162 | general-lisp-code-type)) | |
| 162 | general-lisp-code-type)) | |
| 163 | 163 | (defconstant pre-lisp-code-type (logior pre-encode-bit lisp-code-type)) |
| 164 | 164 | (defconstant pre-psuedo-constant-type |
| 165 | 165 | (logior pre-encode-bit psuedo-constant-type)) |
| 166 | 166 | (defconstant pre-builtin-constant-type (logior pre-encode-bit |
| 167 | builtin-constant-type)) | |
| 167 | builtin-constant-type)) | |
| 168 | 168 | (defconstant pre-pure-builtin-constant-type |
| 169 | 169 | (logior pre-encode-bit pure-builtin-constant-type)) |
| 170 | 170 | (defconstant pre-system-object-type (logior pre-encode-bit system-object-type)) |
| 225 | 225 | (defun term-type (t1) |
| 226 | 226 | (let ((code (term-code t1))) |
| 227 | 227 | (cond ((test-and code variable-type) :variable) |
| 228 | ((test-and code application-form-type) :applform) | |
| 229 | ((test-and code simple-lisp-code-type) :lisp) | |
| 230 | ((test-and code general-lisp-code-type) :glisp) | |
| 231 | ((test-and code system-object-type) :sysobject) | |
| 232 | ((test-and code builtin-constant-type) :builtin) | |
| 233 | ((test-and code psuedo-constant-type) :literal) | |
| 234 | (t nil)))) | |
| 228 | ((test-and code application-form-type) :applform) | |
| 229 | ((test-and code simple-lisp-code-type) :lisp) | |
| 230 | ((test-and code general-lisp-code-type) :glisp) | |
| 231 | ((test-and code system-object-type) :sysobject) | |
| 232 | ((test-and code builtin-constant-type) :builtin) | |
| 233 | ((test-and code psuedo-constant-type) :literal) | |
| 234 | (t nil)))) | |
| 235 | 235 | |
| 236 | 236 | ;;;----------------------------------------------------------------------------- |
| 237 | 237 | ;;; SORT/SORT-CODE : the 3rd part |
| 328 | 328 | (defmacro term$lisp-code-original-form (_term-body) |
| 329 | 329 | `(body-4th ,_term-body)) |
| 330 | 330 | (defmacro term$lisp-form-original-form (_term-body) |
| 331 | `(body-4th ,_term-body)) ; synonym | |
| 331 | `(body-4th ,_term-body)) ; synonym | |
| 332 | 332 | (defmacro lisp-code-original-form (_term) |
| 333 | 333 | `(term-4th ,_term)) |
| 334 | 334 | (defmacro lisp-form-original-form (_term) |
| 335 | `(term-4th ,_term)) ; synonym | |
| 335 | `(term-4th ,_term)) ; synonym | |
| 336 | 336 | |
| 337 | 337 | ;;; APPLICATION FORM : |
| 338 | 338 | ;;; all are setf'able |
| 354 | 354 | (defmacro term-arg-4 (_term) `(cadddr (term-subterms ,_term))) |
| 355 | 355 | (defmacro term-arg-n (_term n) |
| 356 | 356 | ` (nth (the fixnum ,n) |
| 357 | (term-subterms ,_term))) | |
| 357 | (term-subterms ,_term))) | |
| 358 | 358 | |
| 359 | 359 | ;;; ***************** |
| 360 | 360 | ;;; term type testers___________________________________________________________ |
| 440 | 440 | `(term-code$is-system-object? (term-code ,_term))) |
| 441 | 441 | (defmacro term-is-chaos-expr? (_term) |
| 442 | 442 | `(and (term-is-builtin-constant? ,_term) |
| 443 | (eq *chaos-value-sort* (term-sort ,_term)) | |
| 444 | (let ((value (term-builtin-value ,_term))) | |
| 445 | (and (consp value) | |
| 446 | (eq (car value) '|%Chaos|))))) | |
| 443 | (eq *chaos-value-sort* (term-sort ,_term)) | |
| 444 | (let ((value (term-builtin-value ,_term))) | |
| 445 | (and (consp value) | |
| 446 | (eq (car value) '|%Chaos|))))) | |
| 447 | 447 | |
| 448 | 448 | ;;; ****************** |
| 449 | 449 | ;;; TERM STATE TESTERS _________________________________________________________ |
| 462 | 462 | `(test-and reduced-flag (term$state-flag ,*term-body))) |
| 463 | 463 | (defmacro term-test-reduced-flag (*term) |
| 464 | 464 | `(test-and reduced-flag (term-state-flag ,*term))) |
| 465 | (defmacro term-is-reduced? (_term) ; synonym | |
| 465 | (defmacro term-is-reduced? (_term) ; synonym | |
| 466 | 466 | `(term-test-reduced-flag ,_term)) |
| 467 | 467 | |
| 468 | 468 | ;;; red flag |
| 480 | 480 | `(test-and lowest-parsed-flag (term$state-flag ,*term-body))) |
| 481 | 481 | (defmacro term-test-lowest-parsed-flag (*term) |
| 482 | 482 | `(test-and lowest-parsed-flag (term-state-flag ,*term))) |
| 483 | (defmacro term-is-lowest-parsed? (_term) ; synonym | |
| 483 | (defmacro term-is-lowest-parsed? (_term) ; synonym | |
| 484 | 484 | `(term-test-lowest-parsed-flag ,_term)) |
| 485 | 485 | |
| 486 | 486 | ;;; on demand flag |
| 489 | 489 | `(test-and on-demand-flag (term$state-flag ,*term-body))) |
| 490 | 490 | (defmacro term-test-on-demand-flag (*term) |
| 491 | 491 | `(test-and on-demand-flag (term-state-flag ,*term))) |
| 492 | (defmacro term-is-on-demand? (_term) ; synonym | |
| 492 | (defmacro term-is-on-demand? (_term) ; synonym | |
| 493 | 493 | `(term-test-on-demand-flag ,_term)) |
| 494 | 494 | |
| 495 | 495 | ;;; STATE SETTERS |
| 503 | 503 | (once-only (*term) |
| 504 | 504 | `(setf (term-state-flag ,*term) |
| 505 | 505 | (make-or reduced-flag (term-state-flag ,*term))))) |
| 506 | (defmacro mark-term-as-reduced (_term) ; synonym | |
| 506 | (defmacro mark-term-as-reduced (_term) ; synonym | |
| 507 | 507 | `(term-set-reduced-flag ,_term)) |
| 508 | 508 | |
| 509 | 509 | (defconstant .not-reduced-bit. (logand #xffff (lognot reduced-flag))) |
| 524 | 524 | ;;; red flag |
| 525 | 525 | (defmacro term$set-red-flag (*term-body) |
| 526 | 526 | (once-only (*term-body) |
| 527 | `(setf (term$state-flag ,*term-body) | |
| 528 | (make-or red-flag (term$state-flag ,*term-body))))) | |
| 527 | `(setf (term$state-flag ,*term-body) | |
| 528 | (make-or red-flag (term$state-flag ,*term-body))))) | |
| 529 | 529 | |
| 530 | 530 | (defmacro term-set-red (*term) |
| 531 | 531 | (once-only (*term) |
| 532 | `(setf (term-state-flag ,*term) | |
| 533 | (make-or red-flag (term-state-flag ,*term))))) | |
| 532 | `(setf (term-state-flag ,*term) | |
| 533 | (make-or red-flag (term-state-flag ,*term))))) | |
| 534 | 534 | |
| 535 | 535 | (defconstant .green-bit. (logand #xffff (lognot red-flag))) |
| 536 | 536 | (defmacro term$set-green (*term-body) |
| 537 | 537 | (once-only (*term-body) |
| 538 | `(setf (term$state-falag ,*term-body) | |
| 539 | (make-and .green-bit. (term$state-flag ,*term-body))))) | |
| 538 | `(setf (term$state-falag ,*term-body) | |
| 539 | (make-and .green-bit. (term$state-flag ,*term-body))))) | |
| 540 | 540 | |
| 541 | 541 | (defmacro term-set-green (*term) |
| 542 | 542 | (once-only (*term) |
| 543 | `(setf (term-state-flag ,*term) | |
| 544 | (make-and .green-bit. (term-state-flag ,*term))))) | |
| 543 | `(setf (term-state-flag ,*term) | |
| 544 | (make-and .green-bit. (term-state-flag ,*term))))) | |
| 545 | 545 | |
| 546 | 546 | ;;; lowest parsed flag : |
| 547 | 547 | |
| 549 | 549 | (once-only (*term-body) |
| 550 | 550 | `(setf (term$state-flag ,*term-body) |
| 551 | 551 | (make-or lowest-parsed-flag |
| 552 | (term$state-flag ,*term-body))))) | |
| 552 | (term$state-flag ,*term-body))))) | |
| 553 | 553 | |
| 554 | 554 | (defmacro term-set-lowest-parsed-flag (*term) |
| 555 | 555 | (once-only (*term) |
| 556 | 556 | `(setf (term-state-flag ,*term) |
| 557 | 557 | (make-or lowest-parsed-flag |
| 558 | (term-state-flag ,*term))))) | |
| 559 | ||
| 560 | (defmacro mark-term-as-lowest-parsed (_term) ; synonym | |
| 558 | (term-state-flag ,*term))))) | |
| 559 | ||
| 560 | (defmacro mark-term-as-lowest-parsed (_term) ; synonym | |
| 561 | 561 | `(term-set-lowest-parsed-flag ,_term)) |
| 562 | 562 | |
| 563 | 563 | (defconstant .not-lowest-parsed-bit. (logand #xffff (lognot lowest-parsed-flag))) |
| 572 | 572 | (once-only (*term) |
| 573 | 573 | `(setf (term-state-flag ,*term) |
| 574 | 574 | (make-and .not-lowest-parsed-bit. |
| 575 | (term-state-flag ,*term))))) | |
| 576 | ||
| 577 | (defmacro mark-term-as-not-lowest-parsed (_term) ; synonym | |
| 575 | (term-state-flag ,*term))))) | |
| 576 | ||
| 577 | (defmacro mark-term-as-not-lowest-parsed (_term) ; synonym | |
| 578 | 578 | `(term-unset-lowest-parsed-flag ,_term)) |
| 579 | 579 | |
| 580 | 580 | ;;; on demand flag : |
| 583 | 583 | (once-only (*term-body) |
| 584 | 584 | `(setf (term$state-flag ,*term-body) |
| 585 | 585 | (make-or on-demand-flag |
| 586 | (term$state-flag ,*term-body))))) | |
| 586 | (term$state-flag ,*term-body))))) | |
| 587 | 587 | |
| 588 | 588 | (defmacro term-set-on-demand-flag (*term) |
| 589 | 589 | (once-only (*term) |
| 590 | 590 | `(setf (term-state-flag ,*term) |
| 591 | 591 | (make-or on-demand-flag |
| 592 | (term-state-flag ,*term))))) | |
| 593 | ||
| 594 | (defmacro mark-term-as-on-demand (_term) ; synonym | |
| 592 | (term-state-flag ,*term))))) | |
| 593 | ||
| 594 | (defmacro mark-term-as-on-demand (_term) ; synonym | |
| 595 | 595 | `(term-set-on-demand-flag ,_term)) |
| 596 | 596 | |
| 597 | 597 | (defconstant .not-on-demand-bit. (logand #xffff (lognot on-demand-flag))) |
| 600 | 600 | (once-only (*term-body) |
| 601 | 601 | `(setf (term$state-flag ,*term-body) |
| 602 | 602 | (make-and .not-on-demand-bit. |
| 603 | (term$state-flag ,*term-body))))) | |
| 603 | (term$state-flag ,*term-body))))) | |
| 604 | 604 | |
| 605 | 605 | (defmacro term-unset-on-demand-flag (*term) |
| 606 | 606 | (once-only (*term) |
| 607 | 607 | `(setf (term-state-flag ,*term) |
| 608 | 608 | (make-and .not-on-demand-bit. |
| 609 | (term-state-flag ,*term))))) | |
| 609 | (term-state-flag ,*term))))) | |
| 610 | 610 | |
| 611 | 611 | (defmacro mark-term-as-not-on-demand (_term) ; synonym |
| 612 | 612 | `(term-unset-on-demand-flag ,_term)) |
| 633 | 633 | ;;; `(create-term (vector pre-var-const-code ,__variable-name ,__sort nil))) |
| 634 | 634 | |
| 635 | 635 | (defmacro @create-variable-term (__variable-name __sort |
| 636 | &optional (p_name __variable-name)) | |
| 636 | &optional (p_name __variable-name)) | |
| 637 | 637 | ` (create-term (list pre-var-const-code ,__variable-name ,__sort |
| 638 | ,p_name))) | |
| 638 | ,p_name))) | |
| 639 | 639 | |
| 640 | 640 | (defmacro make-variable-term (__sort __variable-name |
| 641 | &optional (_print_name __variable-name)) | |
| 641 | &optional (_print_name __variable-name)) | |
| 642 | 642 | `(create-term (list pre-var-const-code |
| 643 | ,__variable-name | |
| 644 | ,__sort | |
| 645 | ,_print_name))) | |
| 643 | ,__variable-name | |
| 644 | ,__sort | |
| 645 | ,_print_name))) | |
| 646 | 646 | |
| 647 | 647 | |
| 648 | 648 | (defmacro variable-copy (var) |
| 649 | 649 | (once-only (var) |
| 650 | 650 | `(make-variable-term (variable-sort ,var) |
| 651 | (variable-name ,var) | |
| 652 | (variable-print-name ,var)))) | |
| 651 | (variable-name ,var) | |
| 652 | (variable-print-name ,var)))) | |
| 653 | 653 | |
| 654 | 654 | (defmacro variable-copy-x (var) |
| 655 | 655 | (once-only (var) |
| 656 | `(make-variable-term (variable-sort ,var) | |
| 657 | (intern (concatenate 'string (string (variable-name ,var)) "'")) | |
| 658 | (variable-print-name ,var)))) | |
| 656 | `(make-variable-term (variable-sort ,var) | |
| 657 | (intern (concatenate 'string (string (variable-name ,var)) "'")) | |
| 658 | (variable-print-name ,var)))) | |
| 659 | 659 | |
| 660 | 660 | ;;; **************** |
| 661 | 661 | ;;; APPLICATION-FORM ___________________________________________________________ |
| 664 | 664 | #|| |
| 665 | 665 | (defmacro create-application-form-term (_operator-code _sort-id-code _subterms) |
| 666 | 666 | ` (create-term (vector applicatin-form-type |
| 667 | ,_operator-code | |
| 668 | ,_sort-id-code | |
| 669 | ,_subterms))) | |
| 667 | ,_operator-code | |
| 668 | ,_sort-id-code | |
| 669 | ,_subterms))) | |
| 670 | 670 | |
| 671 | 671 | (defmacro @create-application-form-term (_method _sort _subterms) |
| 672 | 672 | ` (create-term (vector pre-application-form-type |
| 673 | ,_method | |
| 674 | ,_sort | |
| 675 | ,_subterms))) | |
| 673 | ,_method | |
| 674 | ,_sort | |
| 675 | ,_subterms))) | |
| 676 | 676 | |
| 677 | 677 | ||# |
| 678 | 678 | |
| 679 | 679 | (defmacro create-application-form-term (_operator-code _sort-id-code _subterms) |
| 680 | 680 | ` (create-term (list applicatin-form-type |
| 681 | ,_operator-code | |
| 682 | ,_sort-id-code | |
| 683 | ,_subterms))) | |
| 681 | ,_operator-code | |
| 682 | ,_sort-id-code | |
| 683 | ,_subterms))) | |
| 684 | 684 | |
| 685 | 685 | (defmacro @create-application-form-term (_method _sort _subterms) |
| 686 | 686 | ` (create-term (list pre-application-form-type |
| 687 | ,_method | |
| 688 | ,_sort | |
| 689 | ,_subterms))) | |
| 687 | ,_method | |
| 688 | ,_sort | |
| 689 | ,_subterms))) | |
| 690 | 690 | |
| 691 | 691 | ;;; **************** |
| 692 | 692 | ;;; SIMPLE-LISP-CODE ___________________________________________________________ |
| 702 | 702 | #|| |
| 703 | 703 | (defmacro create-simple-lisp-code-term (_function &optional _sort-id-code) |
| 704 | 704 | ` (create-term (vector simple-lisp-const-code |
| 705 | ,_function | |
| 706 | ,_sort-id-code | |
| 707 | nil))) | |
| 705 | ,_function | |
| 706 | ,_sort-id-code | |
| 707 | nil))) | |
| 708 | 708 | |
| 709 | 709 | (defmacro make-simple-lisp-form-term (__original-form) |
| 710 | 710 | ` (create-term (vector pre-simple-lisp-const-code |
| 711 | nil | |
| 712 | *cosmos* | |
| 713 | ,__original-form))) | |
| 711 | nil | |
| 712 | *cosmos* | |
| 713 | ,__original-form))) | |
| 714 | 714 | |
| 715 | 715 | ||# |
| 716 | 716 | |
| 717 | 717 | (defmacro create-simple-lisp-code-term (_function &optional _sort-id-code) |
| 718 | 718 | ` (create-term (list simple-lisp-const-code |
| 719 | ,_function | |
| 720 | ,_sort-id-code | |
| 721 | nil))) | |
| 719 | ,_function | |
| 720 | ,_sort-id-code | |
| 721 | nil))) | |
| 722 | 722 | |
| 723 | 723 | (defmacro make-simple-lisp-form-term (__original-form) |
| 724 | 724 | ` (create-term (list pre-simple-lisp-const-code |
| 725 | nil | |
| 726 | *cosmos* | |
| 727 | ,__original-form))) | |
| 725 | nil | |
| 726 | *cosmos* | |
| 727 | ,__original-form))) | |
| 728 | 728 | |
| 729 | 729 | ;;; ***************** |
| 730 | 730 | ;;; GENERAL-LISP-CODE __________________________________________________________ |
| 740 | 740 | #|| |
| 741 | 741 | (defmacro create-general-lisp-code-term (_function _sort-id-code) |
| 742 | 742 | ` (create-term (vector general-lisp-const-code |
| 743 | ,_function | |
| 744 | ,_sort-id-code | |
| 745 | nil))) | |
| 743 | ,_function | |
| 744 | ,_sort-id-code | |
| 745 | nil))) | |
| 746 | 746 | |
| 747 | 747 | (defmacro @create-general-lisp-code-term (_function _original-form _sort) |
| 748 | 748 | ` (create-term (vector pre-general-lisp-const-code |
| 749 | ,_function | |
| 750 | ,_sort | |
| 751 | ,_original-form))) | |
| 749 | ,_function | |
| 750 | ,_sort | |
| 751 | ,_original-form))) | |
| 752 | 752 | |
| 753 | 753 | (defmacro make-general-lisp-form-term (_original-form) |
| 754 | 754 | ` (create-term (vector pre-general-lisp-const-code |
| 755 | nil | |
| 756 | *cosmos* | |
| 757 | ,_original-form))) | |
| 755 | nil | |
| 756 | *cosmos* | |
| 757 | ,_original-form))) | |
| 758 | 758 | |
| 759 | 759 | ||# |
| 760 | 760 | |
| 761 | 761 | (defmacro create-general-lisp-code-term (_function _sort-id-code) |
| 762 | 762 | ` (create-term (list general-lisp-const-code |
| 763 | ,_function | |
| 764 | ,_sort-id-code | |
| 765 | nil))) | |
| 763 | ,_function | |
| 764 | ,_sort-id-code | |
| 765 | nil))) | |
| 766 | 766 | |
| 767 | 767 | (defmacro @create-general-lisp-code-term (_function _original-form _sort) |
| 768 | 768 | ` (create-term (list pre-general-lisp-const-code |
| 769 | ,_function | |
| 770 | ,_sort | |
| 771 | ,_original-form))) | |
| 769 | ,_function | |
| 770 | ,_sort | |
| 771 | ,_original-form))) | |
| 772 | 772 | |
| 773 | 773 | (defmacro make-general-lisp-form-term (_original-form) |
| 774 | 774 | ` (create-term (list pre-general-lisp-const-code |
| 775 | nil | |
| 776 | *cosmos* | |
| 777 | ,_original-form))) | |
| 775 | nil | |
| 776 | *cosmos* | |
| 777 | ,_original-form))) | |
| 778 | 778 | |
| 779 | 779 | ;;; **************** |
| 780 | 780 | ;;; BUILTIN CONSTANT ___________________________________________________________ |
| 791 | 791 | #|| |
| 792 | 792 | (defmacro make-bconst-term (_sort_ _value_) |
| 793 | 793 | ` (create-term (vector pre-builtin-constr-code |
| 794 | ,_value_ | |
| 795 | ,_sort_ | |
| 796 | nil))) | |
| 794 | ,_value_ | |
| 795 | ,_sort_ | |
| 796 | nil))) | |
| 797 | 797 | ||# |
| 798 | 798 | |
| 799 | 799 | (defmacro make-bconst-term (_sort_ _value_) |
| 800 | 800 | ` (create-term (list pre-builtin-constr-code |
| 801 | ,_value_ | |
| 802 | ,_sort_ | |
| 803 | nil))) | |
| 801 | ,_value_ | |
| 802 | ,_sort_ | |
| 803 | nil))) | |
| 804 | 804 | |
| 805 | 805 | ;;; *************** |
| 806 | 806 | ;;; PSUEDO CONSTANT____________________________________________________________ |
| 816 | 816 | |
| 817 | 817 | (defmacro make-psuedo-constant-term (_sort _name) |
| 818 | 818 | ` (create-term (list pre-psuedo-constant-const-code |
| 819 | ,_name | |
| 820 | ,_sort | |
| 821 | nil))) | |
| 819 | ,_name | |
| 820 | ,_sort | |
| 821 | nil))) | |
| 822 | 822 | |
| 823 | 823 | (defmacro make-pvariable-term (_sort _name &optional (_p-name _name)) |
| 824 | 824 | ` (create-term (list pre-psuedo-constant-const-code |
| 825 | ,_name | |
| 826 | ,_sort | |
| 827 | ,_p-name))) | |
| 825 | ,_name | |
| 826 | ,_sort | |
| 827 | ,_p-name))) | |
| 828 | 828 | |
| 829 | 829 | (defmacro pvariable-copy (var) |
| 830 | 830 | (once-only (var) |
| 831 | 831 | `(make-pvariable-term (variable-sort ,var) (variable-name ,var) |
| 832 | (variable-print-name ,var)))) | |
| 832 | (variable-print-name ,var)))) | |
| 833 | 833 | |
| 834 | 834 | |
| 835 | 835 | ;;; ************* |
| 845 | 845 | #|| |
| 846 | 846 | (defmacro make-system-object-term (__value __sort) |
| 847 | 847 | ` (create-term (vector pre-system-object-const-code |
| 848 | ,__value | |
| 849 | ,__sort | |
| 850 | nil))) | |
| 848 | ,__value | |
| 849 | ,__sort | |
| 850 | nil))) | |
| 851 | 851 | |
| 852 | 852 | ||# |
| 853 | 853 | |
| 854 | 854 | (defmacro make-system-object-term (__value __sort) |
| 855 | 855 | ` (create-term (list pre-system-object-const-code |
| 856 | ,__value | |
| 857 | ,__sort | |
| 858 | nil))) | |
| 856 | ,__value | |
| 857 | ,__sort | |
| 858 | nil))) | |
| 859 | 859 | |
| 860 | 860 | ;;;***************************************************************************** |
| 861 | 861 | ;;; BASIC UTILITIES |
| 863 | 863 | |
| 864 | 864 | (defconstant all-term-code |
| 865 | 865 | (logior variable-type application-form-type lisp-code-type |
| 866 | builtin-constant-type psuedo-constant-type system-object-type)) | |
| 866 | builtin-constant-type psuedo-constant-type system-object-type)) | |
| 867 | 867 | |
| 868 | 868 | ;;; TERM? : object -> bool |
| 869 | 869 | ;;; we don't need fast predicate, this is not used as rewriting nor parsing. |
| 872 | 872 | (defmacro term? (!object) |
| 873 | 873 | (once-only (!object) |
| 874 | 874 | ` (and (consp ,!object) |
| 875 | (simple-vector-p (car ,!object)) | |
| 876 | (= 4 (the fixnum (length (car ,!object))))))) | |
| 875 | (simple-vector-p (car ,!object)) | |
| 876 | (= 4 (the fixnum (length (car ,!object))))))) | |
| 877 | 877 | ||# |
| 878 | 878 | |
| 879 | 879 | (defmacro term? (!object) |
| 880 | 880 | (once-only (!object) |
| 881 | 881 | ` (and (consp ,!object) |
| 882 | (consp (car ,!object)) | |
| 883 | (typep (caar ,!object) 'fixnum)))) | |
| 882 | (consp (car ,!object)) | |
| 883 | (typep (caar ,!object) 'fixnum)))) | |
| 884 | 884 | |
| 885 | 885 | ;;; TERM-BUILTIN-EQUAL : term1 term2 -> bool |
| 886 | 886 | ;;; assume term1 is builtin constant term |
| 888 | 888 | (defmacro term$builtin-equal (*_builtin-body *_term-body) |
| 889 | 889 | (once-only (*_term-body) |
| 890 | 890 | ` (and (term$is-builtin-constant? ,*_term-body) |
| 891 | (equal (term$builtin-value ,*_builtin-body) | |
| 892 | (term$builtin-value ,*_term-body))))) | |
| 891 | (equal (term$builtin-value ,*_builtin-body) | |
| 892 | (term$builtin-value ,*_term-body))))) | |
| 893 | 893 | |
| 894 | 894 | (defmacro term-builtin-equal (*_bi-term *_term) |
| 895 | 895 | `(term$builtin-equal (term-body ,*_bi-term) (term-body ,*_term))) |
| 899 | 899 | ;;; |
| 900 | 900 | (defconstant priori-constant-type |
| 901 | 901 | (logior variable-type lisp-code-type builtin-constant-type |
| 902 | psuedo-constant-type | |
| 903 | system-object-type)) | |
| 902 | psuedo-constant-type | |
| 903 | system-object-type)) | |
| 904 | 904 | |
| 905 | 905 | (defmacro term$is-constant? (*_body) |
| 906 | 906 | (once-only (*_body) |
| 916 | 916 | (defun term-variables (term) |
| 917 | 917 | (let ((body (term-body term))) |
| 918 | 918 | (cond ((term$is-variable? body) (list term)) |
| 919 | ((term$is-constant? body) nil) | |
| 920 | (t (let ((res nil)) | |
| 921 | (dolist (st (term$subterms body) res) | |
| 922 | (setq res (nunion res (term-variables st) :test #'!term-eq)))))))) | |
| 919 | ((term$is-constant? body) nil) | |
| 920 | (t (let ((res nil)) | |
| 921 | (dolist (st (term$subterms body) res) | |
| 922 | (setq res (nunion res (term-variables st) :test #'!term-eq)))))))) | |
| 923 | 923 | ||# |
| 924 | 924 | |
| 925 | 925 | (defun term-variables (term) |
| 926 | 926 | (let ((body (term-body term))) |
| 927 | 927 | (cond ((term$is-variable? body) (list term)) |
| 928 | ((term$is-constant? body) nil) | |
| 929 | (t (let ((res nil)) | |
| 930 | (declare (list res)) | |
| 931 | (dolist (st (term$subterms body) res) | |
| 932 | (setq res (delete-duplicates (append res (term-variables st)) | |
| 933 | :test #'!term-eq)))))))) | |
| 928 | ((term$is-constant? body) nil) | |
| 929 | (t (let ((res nil)) | |
| 930 | (declare (list res)) | |
| 931 | (dolist (st (term$subterms body) res) | |
| 932 | (setq res (delete-duplicates (append res (term-variables st)) | |
| 933 | :test #'!term-eq)))))))) | |
| 934 | 934 | |
| 935 | 935 | (declaim (inline variables-occur-at-top?)) |
| 936 | 936 | |
| 939 | 939 | (block variables-occur-at-top-exit |
| 940 | 940 | (dolist (st (term-subterms term)) |
| 941 | 941 | (when (term-is-variable? st) |
| 942 | (return-from variables-occur-at-top-exit t))))) | |
| 942 | (return-from variables-occur-at-top-exit t))))) | |
| 943 | 943 | |
| 944 | 944 | #-GCL |
| 945 | 945 | (defun variables-occur-at-top? (term) |
| 946 | 946 | (block variables-occur-at-top-exit |
| 947 | 947 | (dolist (st (term-subterms term)) |
| 948 | 948 | (when (term-is-variable? st) |
| 949 | (return-from variables-occur-at-top-exit t))))) | |
| 949 | (return-from variables-occur-at-top-exit t))))) | |
| 950 | 950 | |
| 951 | 951 | ;;; TERM-IS-GROUND? : term -> bool |
| 952 | 952 | ;;; |
| 953 | (defconstant apriori-ground-type ; not used now. | |
| 953 | (defconstant apriori-ground-type ; not used now. | |
| 954 | 954 | (logior lisp-code-type builtin-constant-type system-object-type)) |
| 955 | 955 | |
| 956 | 956 | (defmacro term$is-ground? (*_body) |
| 957 | 957 | (once-only (*_body) |
| 958 | 958 | ` (block success |
| 959 | (cond ((term$is-variable? ,*_body) (return-from success nil)) | |
| 960 | ((term$is-application-form? ,*_body) | |
| 961 | (dolist (st (term$subterms ,*_body) t) | |
| 962 | (unless (term-is-ground? st) | |
| 963 | (return-from success nil)))) | |
| 964 | (t t))))) | |
| 959 | (cond ((term$is-variable? ,*_body) (return-from success nil)) | |
| 960 | ((term$is-application-form? ,*_body) | |
| 961 | (dolist (st (term$subterms ,*_body) t) | |
| 962 | (unless (term-is-ground? st) | |
| 963 | (return-from success nil)))) | |
| 964 | (t t))))) | |
| 965 | 965 | |
| 966 | 966 | (defun term-is-ground? (xx_term) |
| 967 | 967 | (term$is-ground? (term-body xx_term))) |
| 973 | 973 | #|| |
| 974 | 974 | (defun simple-copy-term (term) |
| 975 | 975 | (create-term (let ((x (make-array 4)) |
| 976 | (body (term-body term))) | |
| 977 | (declare (type simple-vector x)) | |
| 978 | (dotimes (i 4) | |
| 979 | (declare (type fixnum i)) | |
| 980 | (setf (%svref x i) (%svref body i))) | |
| 981 | x))) | |
| 976 | (body (term-body term))) | |
| 977 | (declare (type simple-vector x)) | |
| 978 | (dotimes (i 4) | |
| 979 | (declare (type fixnum i)) | |
| 980 | (setf (%svref x i) (%svref body i))) | |
| 981 | x))) | |
| 982 | 982 | ||# |
| 983 | 983 | |
| 984 | 984 | (declaim (inline simple-copy-term)) |
| 994 | 994 | (defmacro !term-variable-match (*_variable-body *_term-body) |
| 995 | 995 | (once-only (*_variable-body *_term-body) |
| 996 | 996 | ` (test-and (term$sort-code ,*_variable-body) |
| 997 | (term$sort-code ,*_term-body)))) | |
| 997 | (term$sort-code ,*_term-body)))) | |
| 998 | 998 | |
| 999 | 999 | (defmacro term-variable-match (*_variable_ *_term_) |
| 1000 | 1000 | ` (!term-variable-match (term-body ,*_variable_) |
| 1001 | (term-body ,*_term_))) | |
| 1001 | (term-body ,*_term_))) | |
| 1002 | 1002 | |
| 1003 | 1003 | ;;; TERM-OPERATOR-EQ : term -> bool |
| 1004 | 1004 | ;;; |
| 1013 | 1013 | (defmacro !term-operator-equal (__*term-body1 __*term-body2) |
| 1014 | 1014 | (once-only (__*term-body1 __*term-body2) |
| 1015 | 1015 | ` (and (term$operator-eq ,__*term-body1 ,__*term-body2) |
| 1016 | (= (term$sort-code ,__*term-body1) (term$sort-code ,__*term-body2))))) | |
| 1016 | (= (term$sort-code ,__*term-body1) (term$sort-code ,__*term-body2))))) | |
| 1017 | 1017 | |
| 1018 | 1018 | (defmacro term-operator-equal (__*term1_ __*term2_) |
| 1019 | 1019 | `(!term-operator-equal (term-body ,__*term1_) (term-body ,__*term2_))) |
| 0 | 0 | ;;;-*-Mode:LISP; Package: CHAOS; Base:10; Syntax:Common-lisp -*- |
| 1 | 1 | ;;; |
| 2 | ;;; Copyright (c) 2000-2014, Toshimi Sawada. All rights reserved. | |
| 2 | ;;; Copyright (c) 2000-2015, Toshimi Sawada. All rights reserved. | |
| 3 | 3 | ;;; |
| 4 | 4 | ;;; Redistribution and use in source and binary forms, with or without |
| 5 | 5 | ;;; modification, are permitted provided that the following conditions |
| 0 | 0 | ;;;-*-Mode:LISP; Package: CHAOS; Base:10; Syntax:Common-lisp -*- |
| 1 | 1 | ;;; |
| 2 | ;;; Copyright (c) 2000-2014, Toshimi Sawada. All rights reserved. | |
| 2 | ;;; Copyright (c) 2000-2015, Toshimi Sawada. All rights reserved. | |
| 3 | 3 | ;;; |
| 4 | 4 | ;;; Redistribution and use in source and binary forms, with or without |
| 5 | 5 | ;;; modification, are permitted provided that the following conditions |
| 27 | 27 | ;;; |
| 28 | 28 | (in-package :chaos) |
| 29 | 29 | #|============================================================================== |
| 30 | System:Chaos | |
| 31 | Module:term-parser.chaos | |
| 32 | File: parse-engine.lisp | |
| 30 | System:Chaos | |
| 31 | Module:term-parser.chaos | |
| 32 | File: parse-engine.lisp | |
| 33 | 33 | ==============================================================================|# |
| 34 | 34 | #-:chaos-debug |
| 35 | 35 | (declaim (optimize (speed 3) (safety 0) #-GCL (debug 0))) |
| 47 | 47 | ;;; |
| 48 | 48 | (defun dictionary-add-info-on-token (dictionary token value) |
| 49 | 49 | (declare (type parse-dictionary dictionary) |
| 50 | (type t token value)) | |
| 50 | (type t token value)) | |
| 51 | 51 | (dictionary-add-token-info (dictionary-table dictionary) token value)) |
| 52 | 52 | |
| 53 | 53 | ;;; DICTIONARY-ADD-BUILTIN-SORT : Dictionary Info -> {Dictionary} |
| 54 | 54 | ;;; |
| 55 | 55 | (defun dictionary-add-builtin-sort (dictionary sort) |
| 56 | 56 | (declare (type parse-dictionary dictionary) |
| 57 | (type sort* sort)) | |
| 57 | (type sort* sort)) | |
| 58 | 58 | (unless (memq sort (dictionary-builtins dictionary)) |
| 59 | 59 | (push sort (dictionary-builtins dictionary)))) |
| 60 | 60 | |
| 62 | 62 | ;;; |
| 63 | 63 | (defun dictionary-delete-info-on-token (dictionary token value) |
| 64 | 64 | (declare (type parse-dictionary dictionary) |
| 65 | (type t token value)) | |
| 65 | (type t token value)) | |
| 66 | 66 | (dictionary-delete-token-info (dictionary-table dictionary) token value)) |
| 67 | 67 | |
| 68 | 68 | ;;;; functions on table component of dictionary |
| 72 | 72 | |
| 73 | 73 | (defun dictionary-get-token-info (table token) |
| 74 | 74 | (declare (type hash-table table) |
| 75 | (type t token)) | |
| 75 | (type t token)) | |
| 76 | 76 | (gethash token table)) |
| 77 | 77 | |
| 78 | 78 | ;;; DICTIONARY-REPLACE-TOKEN-INFO : Table Token List[Operator+Variable] |
| 81 | 81 | |
| 82 | 82 | (defun dictionary-replace-token-info (table token values) |
| 83 | 83 | (declare (type hash-table table) |
| 84 | (type t token values)) | |
| 84 | (type t token values)) | |
| 85 | 85 | (setf (gethash token table) values)) |
| 86 | 86 | |
| 87 | 87 | ;;; DICTIONARY-DELETE-TOKEN-INFO : Table Token Value -> {Table} |
| 88 | 88 | (defun dictionary-delete-token-info (table token value) |
| 89 | 89 | (declare (type hash-table table) |
| 90 | (type t token value)) | |
| 90 | (type t token value)) | |
| 91 | 91 | (let ((values (dictionary-get-token-info table token))) |
| 92 | 92 | (declare (type list values)) |
| 93 | 93 | (if (memq value values) |
| 94 | (let ((new-values (remove value values :test #'eq))) | |
| 95 | (if (null new-values) | |
| 96 | (remhash token table) | |
| 97 | (dictionary-replace-token-info table token new-values)))))) | |
| 94 | (let ((new-values (remove value values :test #'eq))) | |
| 95 | (if (null new-values) | |
| 96 | (remhash token table) | |
| 97 | (dictionary-replace-token-info table token new-values)))))) | |
| 98 | 98 | |
| 99 | 99 | ;;; DICTIONARY-ADD-TOKEN-INFO : Table Token Value -> {Table} |
| 100 | 100 | (defun dictionary-add-token-info (table token value) |
| 101 | 101 | (declare (type hash-table table) |
| 102 | (type t token value)) | |
| 102 | (type t token value)) | |
| 103 | 103 | (dictionary-replace-token-info table token |
| 104 | (adjoin value | |
| 105 | (dictionary-get-token-info table token) | |
| 106 | :test #'eq))) | |
| 104 | (adjoin value | |
| 105 | (dictionary-get-token-info table token) | |
| 106 | :test #'eq))) | |
| 107 | 107 | |
| 108 | 108 | |
| 109 | 109 | ;;; GET-INFO-ON-TOKEN : Dictionary Token -> List[Method+Variable+AST] |
| 113 | 113 | (case (car token) |
| 114 | 114 | ((|String| %string) |
| 115 | 115 | (when (memq *string-sort* |
| 116 | (module-all-sorts *current-module*)) | |
| 116 | (module-all-sorts *current-module*)) | |
| 117 | 117 | (make-bconst-term *string-sort* (cadr token)))) |
| 118 | 118 | #|| |
| 119 | 119 | ((|Character| %character) |
| 120 | 120 | (when (memq *character-sort* (module-all-sorts *current-module*)) |
| 121 | 121 | (make-bconst-term *character-sort* |
| 122 | (character (cadr token))))) | |
| 122 | (character (cadr token))))) | |
| 123 | 123 | ||# |
| 124 | 124 | (%slisp (make-simple-lisp-form-term (cadr token))) |
| 125 | 125 | (%glisp (make-general-lisp-form-term (cadr token))) |
| 126 | 126 | (|%Chaos| |
| 127 | 127 | (when (memq *chaos-value-sort* |
| 128 | (module-all-sorts *current-module*)) | |
| 128 | (module-all-sorts *current-module*)) | |
| 129 | 129 | (make-bconst-term *chaos-value-sort* |
| 130 | (cadr token)))) | |
| 130 | (cadr token)))) | |
| 131 | 131 | (otherwise |
| 132 | 132 | (with-output-panic-message () |
| 133 | 133 | (format t "Internal error: dictionary, unknown type of token ~s" token) |
| 137 | 137 | (declare (type term var)) |
| 138 | 138 | (@create-variable-term |
| 139 | 139 | (intern (concatenate 'string (the simple-string |
| 140 | (string (variable-name var))) | |
| 141 | "'")) | |
| 140 | (string (variable-name var))) | |
| 141 | "'")) | |
| 142 | 142 | (variable-sort var))) |
| 143 | 143 | |
| 144 | 144 | (defun simple-copy-term-sharing-variables (term dict) |
| 145 | 145 | (declare (type term term) |
| 146 | (type parse-dictionary dict)) | |
| 146 | (type parse-dictionary dict)) | |
| 147 | 147 | (if (term-is-variable? term) |
| 148 | 148 | (let ((infos (dictionary-get-token-info (dictionary-table dict) |
| 149 | (string (variable-name term))))) | |
| 150 | (declare (type list infos)) | |
| 151 | (dolist (info infos) | |
| 152 | (when (and (term-is-variable? info) | |
| 153 | (sort= (variable-sort term) | |
| 154 | (variable-sort info))) | |
| 155 | (return-from simple-copy-term-sharing-variables info))) | |
| 156 | (let ((res (assoc (variable-name term) *parse-variables* :test #'eql))) | |
| 157 | (declare (type list res)) | |
| 158 | (if res | |
| 159 | (cdr res) | |
| 160 | (progn | |
| 161 | (push (cons (variable-name term) ;; (variable-copy term) | |
| 162 | term) | |
| 163 | *parse-variables*) | |
| 164 | term)))) | |
| 149 | (string (variable-name term))))) | |
| 150 | (declare (type list infos)) | |
| 151 | (dolist (info infos) | |
| 152 | (when (and (term-is-variable? info) | |
| 153 | (sort= (variable-sort term) | |
| 154 | (variable-sort info))) | |
| 155 | (return-from simple-copy-term-sharing-variables info))) | |
| 156 | (let ((res (assoc (variable-name term) *parse-variables* :test #'eql))) | |
| 157 | (declare (type list res)) | |
| 158 | (if res | |
| 159 | (cdr res) | |
| 160 | (progn | |
| 161 | (push (cons (variable-name term) ;; (variable-copy term) | |
| 162 | term) | |
| 163 | *parse-variables*) | |
| 164 | term)))) | |
| 165 | 165 | (if (term-is-application-form? term) |
| 166 | (@create-application-form-term (term-head term) | |
| 167 | (term-sort term) | |
| 168 | (mapcar #'(lambda (x) | |
| 169 | (simple-copy-term-sharing-variables x dict)) | |
| 170 | (term-subterms term))) | |
| 171 | (simple-copy-term term)))) | |
| 172 | ||
| 173 | (defun get-qualified-op-pattern (tok &optional (module (or *current-module* | |
| 174 | *last-module*))) | |
| 166 | (@create-application-form-term (term-head term) | |
| 167 | (term-sort term) | |
| 168 | (mapcar #'(lambda (x) | |
| 169 | (simple-copy-term-sharing-variables x dict)) | |
| 170 | (term-subterms term))) | |
| 171 | (simple-copy-term term)))) | |
| 172 | ||
| 173 | (defun get-qualified-op-pattern (tok &optional (module (get-context-module))) | |
| 175 | 174 | (labels ((destruct-op-name (expr) |
| 176 | (let ((pos (position #\_ expr))) | |
| 177 | (declare (type (or null fixnum) pos)) | |
| 178 | (if pos | |
| 179 | (cons (subseq expr 0 pos) | |
| 180 | (list "_" | |
| 181 | (destruct-op-name | |
| 182 | (subseq expr (1+ pos))))) | |
| 183 | expr))) | |
| 184 | (parse-opref (expr) | |
| 185 | (declare (type string expr)) | |
| 186 | (let ((val (destruct-op-name expr))) | |
| 187 | (unless (consp val) | |
| 188 | (setq val (list val))) | |
| 189 | (let ((name (car val))) | |
| 190 | (declare (type simple-string name)) | |
| 191 | (let ((pos (position #\. name))) | |
| 192 | (if (and pos (< 0 pos) (< (1+ pos) (length name))) | |
| 193 | ;; "foo.qualifier" | |
| 194 | (values (cons (subseq name 0 pos) (cdr val)) | |
| 195 | (subseq name (1+ pos))) | |
| 196 | (return-from get-qualified-op-pattern nil)))))) | |
| 197 | (find-qual-operators-2 (name module context) | |
| 198 | (let ((modval (find-module-in-env-ext (canonicalize-simple-module-name module) | |
| 199 | context | |
| 200 | :no-error))) | |
| 201 | (if (module-p modval) | |
| 202 | (find-operators-in-module-no-number name modval nil t) | |
| 203 | (with-output-chaos-error ('invalid-context) | |
| 204 | (format t "module ~a is not available in the current context." module)))))) | |
| 175 | (let ((pos (position #\_ expr))) | |
| 176 | (declare (type (or null fixnum) pos)) | |
| 177 | (if pos | |
| 178 | (cons (subseq expr 0 pos) | |
| 179 | (list "_" | |
| 180 | (destruct-op-name | |
| 181 | (subseq expr (1+ pos))))) | |
| 182 | expr))) | |
| 183 | (parse-opref (expr) | |
| 184 | (declare (type string expr)) | |
| 185 | (let ((val (destruct-op-name expr))) | |
| 186 | (unless (consp val) | |
| 187 | (setq val (list val))) | |
| 188 | (let ((name (car val))) | |
| 189 | (declare (type simple-string name)) | |
| 190 | (let ((pos (position #\. name))) | |
| 191 | (if (and pos (< 0 pos) (< (1+ pos) (length name))) | |
| 192 | ;; "foo.qualifier" | |
| 193 | (values (cons (subseq name 0 pos) (cdr val)) | |
| 194 | (subseq name (1+ pos))) | |
| 195 | (return-from get-qualified-op-pattern nil)))))) | |
| 196 | (find-qual-operators-2 (name module context) | |
| 197 | (let ((modval (find-module-in-env-ext (canonicalize-simple-module-name module) | |
| 198 | context | |
| 199 | :no-error))) | |
| 200 | (if (module-p modval) | |
| 201 | (find-operators-in-module-no-number name modval nil t) | |
| 202 | (with-output-chaos-error ('invalid-context) | |
| 203 | (format t "module ~a is not available in the current context." module)))))) | |
| 205 | 204 | (let ((info nil) |
| 206 | (res nil)) | |
| 205 | (res nil)) | |
| 207 | 206 | (multiple-value-bind (name qual) |
| 208 | (parse-opref tok) | |
| 209 | (setq info (find-qual-operators-2 name qual module)) | |
| 210 | (dolist (i info) | |
| 211 | (if (cdr (opinfo-methods i)) | |
| 212 | (push (cadr (opinfo-methods i)) res) | |
| 213 | (push (car (opinfo-methods i)) res))) | |
| 214 | (values res name))))) | |
| 207 | (parse-opref tok) | |
| 208 | (setq info (find-qual-operators-2 name qual module)) | |
| 209 | (dolist (i info) | |
| 210 | (if (cdr (opinfo-methods i)) | |
| 211 | (push (cadr (opinfo-methods i)) res) | |
| 212 | (push (car (opinfo-methods i)) res))) | |
| 213 | (values res name))))) | |
| 215 | 214 | |
| 216 | 215 | (defun parser-is-more-general-one (obj lst) |
| 217 | 216 | (and (method-p obj) |
| 218 | 217 | (let ((lowers (method-lower-methods obj))) |
| 219 | (dolist (obj2 lst) | |
| 220 | (when (member obj2 lowers :test #'eq) | |
| 221 | (return-from parser-is-more-general-one t))) | |
| 222 | nil))) | |
| 218 | (dolist (obj2 lst) | |
| 219 | (when (member obj2 lowers :test #'eq) | |
| 220 | (return-from parser-is-more-general-one t))) | |
| 221 | nil))) | |
| 223 | 222 | |
| 224 | 223 | (defun get-info-on-token (dictionary token &optional sort-constraint) |
| 225 | 224 | (declare (type parse-dictionary dictionary) |
| 226 | (type t token)) | |
| 225 | (type t token)) | |
| 227 | 226 | (when *on-parse-debug* |
| 228 | (format t "~&dictionary info token = ~s" token)) | |
| 227 | (format t "~%dictionary info token = ~s" token)) | |
| 229 | 228 | (let ((res nil) |
| 230 | (mod-token nil)) | |
| 229 | (mod-token nil)) | |
| 231 | 230 | (block collect |
| 232 | 231 | (cond ((consp token) |
| 233 | ;; special builtin tokens | |
| 234 | (setq res (list (info-for-special-builtins token)))) | |
| 235 | ;; normal token | |
| 236 | (t (setq res (dictionary-get-token-info (dictionary-table dictionary) | |
| 237 | token)) | |
| 238 | ;; check builtin constant | |
| 239 | (let (pos) | |
| 240 | (dolist (bi (dictionary-builtins dictionary)) | |
| 241 | (let ((token-pred (bsort-token-predicate bi))) | |
| 242 | (when (and token-pred | |
| 243 | (funcall token-pred token)) | |
| 244 | (push bi pos)))) | |
| 245 | (if pos | |
| 246 | ;; may be builtin constant. | |
| 247 | (if (cdr pos) | |
| 248 | (let ((so (module-sort-order | |
| 249 | *current-module*))) | |
| 250 | (dolist (bi pos) | |
| 251 | (unless (some #'(lambda (x) (sort< x bi so)) pos) | |
| 252 | (push (dictionary-make-builtin-constant token bi) res)))) | |
| 253 | (push (dictionary-make-builtin-constant token (car pos)) res)))) | |
| 254 | ||
| 255 | ;; blocked let variable? | |
| 256 | ;; *TODO* | |
| 257 | ||
| 258 | ;; bound variable? | |
| 259 | (catch 'term-context-error | |
| 260 | (let ((val (get-bound-value token))) | |
| 261 | (when val | |
| 262 | (if (is-special-let-variable? token) | |
| 263 | (push val res) | |
| 264 | (push (simple-copy-term-sharing-variables val dictionary) | |
| 265 | res))))) | |
| 266 | ;; try other possiblities. | |
| 267 | ;; variable ? | |
| 268 | (let ((res2 (assoc (intern token) *parse-variables*))) | |
| 269 | (cond (res2 | |
| 270 | ;; there's a registered variable with name 'token', accumlate | |
| 271 | ;; it. now that vars are left in modules want | |
| 272 | ;; *parser-variables* to replace. | |
| 273 | (when *on-parse-debug* | |
| 274 | (format t "~&found var : ~s" (car res2))) | |
| 275 | (setq res (cons (cdr res2) (dictionary-delete-vars res)))) | |
| 276 | (t | |
| 277 | ;; check sort qualified variable reference | |
| 278 | ;; = on-the-fly (dynamic) variable declaration. | |
| 279 | (let ((q-pos (position #\: (the simple-string token) | |
| 280 | :from-end t))) | |
| 281 | (declare (type (or null fixnum) q-pos)) | |
| 282 | (cond ((and q-pos | |
| 283 | (not (zerop (the fixnum q-pos))) | |
| 284 | (not (= (the fixnum q-pos) | |
| 285 | (the fixnum | |
| 286 | (1- (length | |
| 287 | (the simple-string token))))))) | |
| 288 | (let ((sort nil) | |
| 289 | (var-name nil) | |
| 290 | (var nil)) | |
| 291 | ;; assumes the token is qualified vriable | |
| 292 | ;; declaration. | |
| 293 | (setq var-name (subseq (the simple-string token) | |
| 294 | 0 | |
| 295 | (the fixnum q-pos))) | |
| 296 | (setf sort (find-sort-in *current-module* | |
| 297 | (subseq | |
| 298 | (the simple-string token) | |
| 299 | (1+ (the fixnum q-pos))))) | |
| 300 | (unless sort | |
| 301 | (when res (return-from collect nil)) | |
| 302 | (with-output-chaos-error ('no-such-sort) | |
| 303 | (format t "unknown sort ~a for variable form ~a." | |
| 304 | (subseq token (1+ q-pos)) | |
| 305 | token))) | |
| 306 | (let ((bi (check-var-name-overloading-with-builtin | |
| 307 | var-name sort *current-module*))) | |
| 308 | (when bi | |
| 309 | (with-output-chaos-warning () | |
| 310 | (format t "declaring variable ~s on the fly," | |
| 311 | var-name) | |
| 312 | (print-next) | |
| 313 | (princ "the name is conflicting with built-in constant of sort ") | |
| 314 | (print-sort-name bi *current-module*) | |
| 315 | (princ ".") | |
| 316 | (terpri)))) | |
| 317 | ;; | |
| 318 | #|| | |
| 319 | (let ((gv (dictionary-get-token-info | |
| 320 | (dictionary-table dictionary) | |
| 321 | var-name))) | |
| 322 | (when gv | |
| 323 | (dolist (op-v gv) | |
| 324 | (when (eq (object-syntactic-type op-v) | |
| 325 | 'variable) | |
| 326 | (with-output-chaos-error ('already-used-name) | |
| 327 | (format t "~&on the fly variable name ~A is already used for static variable declaration..." var-name)))))) | |
| 328 | ||# | |
| 329 | (setq var-name (intern var-name)) | |
| 330 | ||
| 331 | ;; success parsing it as a variable declaration. | |
| 332 | ;; checks if there alredy a variable with the same | |
| 333 | ;; name. | |
| 334 | (when *on-parse-debug* | |
| 335 | (format t "~&on-the-fly var decl: ~A" var-name) | |
| 336 | (format t "... ~A" *parse-variables*)) | |
| 337 | (let ((old-var (assoc var-name *parse-variables*))) | |
| 338 | (if old-var | |
| 339 | (unless (sort= (variable-sort (cdr old-var)) | |
| 340 | sort) | |
| 341 | (with-output-chaos-error () | |
| 342 | (format t "variable ~A has been declared as sort ~A, but now being redefined as sort ~A.~%" | |
| 343 | (string var-name) | |
| 344 | (string (sort-id | |
| 345 | (variable-sort (cdr | |
| 346 | old-var)))) | |
| 347 | (string (sort-id sort)))) | |
| 348 | ;;(setf (cdr old-var) | |
| 349 | ;; (make-variable-term sort var-name)) | |
| 350 | ) | |
| 351 | (progn | |
| 352 | ;; check name, if it start with `, we make | |
| 353 | ;; pseudo variable | |
| 354 | (if (eql #\` (char (the simple-string (string var-name)) 0)) | |
| 355 | (setf var (make-pvariable-term sort var-name)) | |
| 356 | (setf var (make-variable-term sort var-name))) | |
| 357 | (push (cons var-name var) *parse-variables*))) | |
| 358 | (if old-var | |
| 359 | (progn | |
| 360 | (push (cdr old-var) res) | |
| 361 | #|| | |
| 362 | (when (err-sort-p (variable-sort | |
| 363 | (cdr old-var))) | |
| 364 | (pushew (cdr old-var) | |
| 365 | (module-error-variables | |
| 366 | *current-module*))) | |
| 367 | ||# | |
| 368 | ) | |
| 369 | (let ((svar (assoc var res :test #'equal))) | |
| 370 | (when *on-parse-debug* | |
| 371 | (format t "~%!res = ~s" res)) | |
| 372 | (when svar | |
| 373 | (with-output-chaos-error () | |
| 374 | (format t "Static variable ~s already used before in the same context" var-name))) | |
| 375 | (push var res) | |
| 376 | #|| | |
| 377 | (when (err-sort-p (variable-sort var)) | |
| 378 | (pushnew var (module-error-variables | |
| 379 | *current-module*))) | |
| 380 | ||# | |
| 381 | ))))) | |
| 382 | ||
| 383 | ;; must not be a variable declaration. | |
| 384 | ;; try yet other possibilities. | |
| 385 | (t | |
| 386 | ;; no possibilities of vairable nor builtin | |
| 387 | ;; constant. | |
| 388 | (let ((ast (gethash token *builtin-ast-dict*))) | |
| 389 | (if ast | |
| 390 | ;; abstract syntax tree. | |
| 391 | (setf res ast)) | |
| 392 | (unless res | |
| 393 | (multiple-value-setq (res mod-token) | |
| 394 | (get-qualified-op-pattern token))) | |
| 395 | ;; | |
| 396 | (when (and (null res) | |
| 397 | (memq *identifier-sort* | |
| 398 | (module-all-sorts | |
| 399 | *current-module*))) | |
| 400 | (let ((ident (intern token))) | |
| 401 | (unless (member ident '(|.| |,| | |
| 402 | |(| |)| | |
| 403 | |{| |}| | |
| 404 | |[| |]|)) | |
| 405 | (push (make-bconst-term *identifier-sort* ident) res))))))))))) | |
| 406 | ;; final possibility | |
| 407 | (unless res | |
| 408 | (multiple-value-setq (res mod-token) | |
| 409 | (get-qualified-op-pattern token)))))) | |
| 232 | ;; special builtin tokens | |
| 233 | (setq res (list (info-for-special-builtins token)))) | |
| 234 | ;; normal token | |
| 235 | (t (setq res (dictionary-get-token-info (dictionary-table dictionary) | |
| 236 | token)) | |
| 237 | ;; check builtin constant | |
| 238 | (let (pos) | |
| 239 | (dolist (bi (dictionary-builtins dictionary)) | |
| 240 | (let ((token-pred (bsort-token-predicate bi))) | |
| 241 | (when (and token-pred | |
| 242 | (funcall token-pred token)) | |
| 243 | (push bi pos)))) | |
| 244 | (if pos | |
| 245 | ;; may be builtin constant. | |
| 246 | (if (cdr pos) | |
| 247 | (let ((so (module-sort-order | |
| 248 | *current-module*))) | |
| 249 | (dolist (bi pos) | |
| 250 | (unless (some #'(lambda (x) (sort< x bi so)) pos) | |
| 251 | (push (dictionary-make-builtin-constant token bi) res)))) | |
| 252 | (push (dictionary-make-builtin-constant token (car pos)) res)))) | |
| 253 | ||
| 254 | ;; blocked let variable? | |
| 255 | ;; *TODO* | |
| 256 | ||
| 257 | ;; bound variable? | |
| 258 | (catch 'term-context-error | |
| 259 | (let ((val (get-bound-value token))) | |
| 260 | (when val | |
| 261 | (if (is-special-let-variable? token) | |
| 262 | (push val res) | |
| 263 | (push (simple-copy-term-sharing-variables val dictionary) | |
| 264 | res))))) | |
| 265 | ;; try other possiblities. | |
| 266 | ;; variable ? | |
| 267 | (let ((res2 (assoc (intern token) *parse-variables*))) | |
| 268 | (cond (res2 | |
| 269 | ;; there's a registered variable with name 'token', accumlate | |
| 270 | ;; it. now that vars are left in modules want | |
| 271 | ;; *parser-variables* to replace. | |
| 272 | (when *on-parse-debug* | |
| 273 | (format t "~%found var : ~s" (car res2))) | |
| 274 | (setq res (cons (cdr res2) (dictionary-delete-vars res)))) | |
| 275 | (t | |
| 276 | ;; check sort qualified variable reference | |
| 277 | ;; = on-the-fly (dynamic) variable declaration. | |
| 278 | (let ((q-pos (position #\: (the simple-string token) | |
| 279 | :from-end t))) | |
| 280 | (declare (type (or null fixnum) q-pos)) | |
| 281 | (cond ((and q-pos | |
| 282 | (not (zerop (the fixnum q-pos))) | |
| 283 | (not (= (the fixnum q-pos) | |
| 284 | (the fixnum | |
| 285 | (1- (length | |
| 286 | (the simple-string token))))))) | |
| 287 | (let ((sort nil) | |
| 288 | (var-name nil) | |
| 289 | (var nil)) | |
| 290 | ;; assumes the token is qualified vriable | |
| 291 | ;; declaration. | |
| 292 | (setq var-name (subseq (the simple-string token) | |
| 293 | 0 | |
| 294 | (the fixnum q-pos))) | |
| 295 | (setf sort (find-sort-in *current-module* | |
| 296 | (subseq | |
| 297 | (the simple-string token) | |
| 298 | (1+ (the fixnum q-pos))))) | |
| 299 | (unless sort | |
| 300 | (when res (return-from collect nil)) | |
| 301 | (with-output-chaos-error ('no-such-sort) | |
| 302 | (format t "unknown sort ~a for variable form ~a." | |
| 303 | (subseq token (1+ q-pos)) | |
| 304 | token))) | |
| 305 | (let ((bi (check-var-name-overloading-with-builtin | |
| 306 | var-name sort *current-module*))) | |
| 307 | (when bi | |
| 308 | (with-output-chaos-warning () | |
| 309 | (format t "declaring variable ~s on the fly," | |
| 310 | var-name) | |
| 311 | (print-next) | |
| 312 | (princ "the name is conflicting with built-in constant of sort ") | |
| 313 | (print-sort-name bi *current-module*) | |
| 314 | (princ ".") | |
| 315 | (terpri)))) | |
| 316 | ;; | |
| 317 | #|| | |
| 318 | (let ((gv (dictionary-get-token-info | |
| 319 | (dictionary-table dictionary) | |
| 320 | var-name))) | |
| 321 | (when gv | |
| 322 | (dolist (op-v gv) | |
| 323 | (when (eq (object-syntactic-type op-v) | |
| 324 | 'variable) | |
| 325 | (with-output-chaos-error ('already-used-name) | |
| 326 | (format t "~&on the fly variable name ~A is already used for static variable declaration..." var-name)))))) | |
| 327 | ||# | |
| 328 | (setq var-name (intern var-name)) | |
| 329 | ||
| 330 | ;; success parsing it as a variable declaration. | |
| 331 | ;; checks if there alredy a variable with the same | |
| 332 | ;; name. | |
| 333 | (when *on-parse-debug* | |
| 334 | (format t "~%on-the-fly var decl: ~A" var-name) | |
| 335 | (format t "... ~A" *parse-variables*)) | |
| 336 | (let ((old-var (assoc var-name *parse-variables*))) | |
| 337 | (if old-var | |
| 338 | (unless (sort= (variable-sort (cdr old-var)) | |
| 339 | sort) | |
| 340 | (with-output-chaos-error () | |
| 341 | (format t "variable ~A has been declared as sort ~A, but now being redefined as sort ~A.~%" | |
| 342 | (string var-name) | |
| 343 | (string (sort-id | |
| 344 | (variable-sort (cdr | |
| 345 | old-var)))) | |
| 346 | (string (sort-id sort)))) | |
| 347 | ;;(setf (cdr old-var) | |
| 348 | ;; (make-variable-term sort var-name)) | |
| 349 | ) | |
| 350 | (progn | |
| 351 | ;; check name, if it start with `, we make | |
| 352 | ;; pseudo variable | |
| 353 | (if (eql #\` (char (the simple-string (string var-name)) 0)) | |
| 354 | (setf var (make-pvariable-term sort var-name)) | |
| 355 | (setf var (make-variable-term sort var-name))) | |
| 356 | (push (cons var-name var) *parse-variables*))) | |
| 357 | (if old-var | |
| 358 | (progn | |
| 359 | (push (cdr old-var) res) | |
| 360 | #|| | |
| 361 | (when (err-sort-p (variable-sort | |
| 362 | (cdr old-var))) | |
| 363 | (pushew (cdr old-var) | |
| 364 | (module-error-variables | |
| 365 | *current-module*))) | |
| 366 | ||# | |
| 367 | ) | |
| 368 | (let ((svar (assoc var res :test #'equal))) | |
| 369 | (when *on-parse-debug* | |
| 370 | (format t "~%!res = ~s" res)) | |
| 371 | (when svar | |
| 372 | (with-output-chaos-error () | |
| 373 | (format t "Static variable ~s already used before in the same context" var-name))) | |
| 374 | (push var res) | |
| 375 | #|| | |
| 376 | (when (err-sort-p (variable-sort var)) | |
| 377 | (pushnew var (module-error-variables | |
| 378 | *current-module*))) | |
| 379 | ||# | |
| 380 | ))))) | |
| 381 | ||
| 382 | ;; must not be a variable declaration. | |
| 383 | ;; try yet other possibilities. | |
| 384 | (t | |
| 385 | ;; no possibilities of vairable nor builtin | |
| 386 | ;; constant. | |
| 387 | (let ((ast (gethash token *builtin-ast-dict*))) | |
| 388 | (if ast | |
| 389 | ;; abstract syntax tree. | |
| 390 | (setf res ast)) | |
| 391 | (unless res | |
| 392 | (multiple-value-setq (res mod-token) | |
| 393 | (get-qualified-op-pattern token))) | |
| 394 | ;; | |
| 395 | (when (and (null res) | |
| 396 | (memq *identifier-sort* | |
| 397 | (module-all-sorts | |
| 398 | *current-module*))) | |
| 399 | (let ((ident (intern token))) | |
| 400 | (unless (member ident '(|.| |,| | |
| 401 | |(| |)| | |
| 402 | |{| |}| | |
| 403 | |[| |]|)) | |
| 404 | (push (make-bconst-term *identifier-sort* ident) res))))))))))) | |
| 405 | ;; final possibility | |
| 406 | (unless res | |
| 407 | (multiple-value-setq (res mod-token) | |
| 408 | (get-qualified-op-pattern token)))))) | |
| 410 | 409 | ;; end collect |
| 411 | 410 | (when sort-constraint |
| 412 | 411 | (let ((real-res nil)) |
| 413 | (dolist (r res) | |
| 414 | (cond ((term? r) | |
| 415 | (when (parser-in-same-connected-component (term-sort r) | |
| 416 | sort-constraint | |
| 417 | *current-sort-order*) | |
| 418 | (push r real-res))) | |
| 419 | ((method-p r) | |
| 420 | (when (parser-in-same-connected-component (method-coarity r) | |
| 421 | sort-constraint | |
| 422 | *current-sort-order*) | |
| 423 | (push r real-res))) | |
| 424 | (t (push r real-res)))) | |
| 425 | (when real-res | |
| 426 | (setq res real-res)))) | |
| 412 | (dolist (r res) | |
| 413 | (cond ((term? r) | |
| 414 | (when (parser-in-same-connected-component (term-sort r) | |
| 415 | sort-constraint | |
| 416 | *current-sort-order*) | |
| 417 | (push r real-res))) | |
| 418 | ((method-p r) | |
| 419 | (when (parser-in-same-connected-component (method-coarity r) | |
| 420 | sort-constraint | |
| 421 | *current-sort-order*) | |
| 422 | (push r real-res))) | |
| 423 | (t (push r real-res)))) | |
| 424 | (when real-res | |
| 425 | (setq res real-res)))) | |
| 427 | 426 | (let ((result nil)) |
| 428 | 427 | (loop |
| 429 | (unless res (return)) | |
| 430 | (let ((p (pop res))) | |
| 431 | (unless (parser-is-more-general-one p res) | |
| 432 | (push p result)))) | |
| 428 | (unless res (return)) | |
| 429 | (let ((p (pop res))) | |
| 430 | (unless (parser-is-more-general-one p res) | |
| 431 | (push p result)))) | |
| 433 | 432 | (setq res (nreverse result))) |
| 434 | 433 | (when *on-parse-debug* |
| 435 | (format t "~& : sort constraint = ") | |
| 434 | (format t "~% : sort constraint = ") | |
| 436 | 435 | (print-chaos-object sort-constraint) |
| 437 | 436 | (format t "~& : result info = ~s" res) |
| 438 | 437 | (print-chaos-object res)) |
| 441 | 440 | (defun dictionary-delete-vars (lst) |
| 442 | 441 | (declare (type list lst)) |
| 443 | 442 | (if (dolist (e lst nil) |
| 444 | (when (consp e) (return t))) | |
| 443 | (when (consp e) (return t))) | |
| 445 | 444 | (let ((res nil)) |
| 446 | (dolist (e lst) | |
| 447 | (unless (consp e) (push e res))) | |
| 448 | (nreverse res)) | |
| 445 | (dolist (e lst) | |
| 446 | (unless (consp e) (push e res))) | |
| 447 | (nreverse res)) | |
| 449 | 448 | lst)) |
| 450 | 449 | |
| 451 | 450 | ;;; ** TODO ** |
| 453 | 452 | ;;; |
| 454 | 453 | (defun dictionary-make-builtin-constant (token bsort) |
| 455 | 454 | (declare (type t token) |
| 456 | (type sort* bsort)) | |
| 455 | (type sort* bsort)) | |
| 457 | 456 | (catch 'direct-value |
| 458 | 457 | (let ((value (funcall (bsort-term-creator bsort) token))) |
| 459 | 458 | (make-bconst-term bsort value)))) |
| 461 | 460 | |
| 462 | 461 | |
| 463 | 462 | ;;;============================================================================= |
| 464 | ;;; PARSE ENGINE | |
| 463 | ;;; PARSE ENGINE | |
| 465 | 464 | ;;;============================================================================= |
| 466 | 465 | |
| 467 | 466 | ;;; the range of precedence (and precedence level) : |
| 479 | 478 | (defun object-syntactic-type (e) |
| 480 | 479 | (declare (type t e)) |
| 481 | 480 | (cond ((term? e) |
| 482 | (if (term-is-variable? e) | |
| 483 | 'variable | |
| 484 | (if (term-is-builtin-constant? e) | |
| 485 | 'builtin | |
| 486 | (if (term-is-lisp-form? e) | |
| 487 | 'lisp-form | |
| 488 | 'normal-term)))) | |
| 489 | ((operator-method-p e) | |
| 490 | (operator-syntactic-type (method-operator e))) | |
| 491 | (t 'ast))) | |
| 481 | (if (term-is-variable? e) | |
| 482 | 'variable | |
| 483 | (if (term-is-builtin-constant? e) | |
| 484 | 'builtin | |
| 485 | (if (term-is-lisp-form? e) | |
| 486 | 'lisp-form | |
| 487 | 'normal-term)))) | |
| 488 | ((operator-method-p e) | |
| 489 | (operator-syntactic-type (method-operator e))) | |
| 490 | (t 'ast))) | |
| 492 | 491 | |
| 493 | 492 | (defun operator-parse-category (op) |
| 494 | 493 | (operator-syntactic-type-from-name (operator-token-sequence op))) |
| 540 | 539 | |
| 541 | 540 | (defun parse-term (token-list module level-constraint sort-constraint) |
| 542 | 541 | (declare (type list token-list) |
| 543 | (type module module) | |
| 544 | (type fixnum level-constraint) | |
| 545 | (type sort* sort-constraint)) | |
| 542 | (type module module) | |
| 543 | (type fixnum level-constraint) | |
| 544 | (type sort* sort-constraint)) | |
| 546 | 545 | (let ((terletox0-list (parser-get-term token-list |
| 547 | module | |
| 548 | level-constraint | |
| 549 | ;; sort-constraint | |
| 550 | ))) | |
| 546 | module | |
| 547 | level-constraint | |
| 548 | ;; sort-constraint | |
| 549 | ))) | |
| 551 | 550 | (declare (type list terletox0-list)) |
| 552 | 551 | (let ((res nil)) |
| 553 | (when terletox0-list | |
| 554 | (setq res (parser-continuing terletox0-list | |
| 555 | module | |
| 556 | level-constraint | |
| 557 | sort-constraint))) | |
| 558 | res))) | |
| 552 | (when terletox0-list | |
| 553 | (setq res (parser-continuing terletox0-list | |
| 554 | module | |
| 555 | level-constraint | |
| 556 | sort-constraint))) | |
| 557 | res))) | |
| 559 | 558 | |
| 560 | 559 | ;;; PARSER-CONTINUING : |
| 561 | 560 | ;;; LIST[ ( ( ChaosTerm . PrecedenceLevel ) . TokenList ) ] -- not empty ! |
| 585 | 584 | |
| 586 | 585 | (defun parser-continuing (terletox0-list module level-constraint sort-constraint) |
| 587 | 586 | (declare (type list terletox0-list) |
| 588 | (type module module) | |
| 589 | (type fixnum level-constraint) | |
| 590 | (type sort* sort-constraint)) | |
| 591 | (let ((terletox-list-prime nil)) ;initialization--will serve as accumulator | |
| 592 | ; and be returned in the end. | |
| 587 | (type module module) | |
| 588 | (type fixnum level-constraint) | |
| 589 | (type sort* sort-constraint)) | |
| 590 | (let ((terletox-list-prime nil)) ;initialization--will serve as accumulator | |
| 591 | ; and be returned in the end. | |
| 593 | 592 | (dolist (terletox0 terletox0-list terletox-list-prime) |
| 594 | (setq terletox-list-prime ;accumulate | |
| 593 | (setq terletox-list-prime ;accumulate | |
| 595 | 594 | (nconc (parser-continue-check terletox0 |
| 596 | module | |
| 597 | level-constraint | |
| 598 | sort-constraint) | |
| 595 | module | |
| 596 | level-constraint | |
| 597 | sort-constraint) | |
| 599 | 598 | terletox-list-prime))))) |
| 600 | 599 | |
| 601 | 600 | ;;; PARSER-CONTINUE-CHECK : |
| 629 | 628 | |
| 630 | 629 | (defun parser-continue-check (terletox0 module level-constraint sort-constraint) |
| 631 | 630 | (declare (type list terletox0) |
| 632 | (type module module) | |
| 633 | (type fixnum level-constraint) | |
| 634 | (type sort* sort-constraint)) | |
| 631 | (type module module) | |
| 632 | (type fixnum level-constraint) | |
| 633 | (type sort* sort-constraint)) | |
| 635 | 634 | ;; |
| 636 | 635 | (let* ((chaos-term0 (caar terletox0)) |
| 637 | (sort0 (term-sort chaos-term0)) | |
| 638 | (sort-order (module-sort-order module)) | |
| 639 | ;; add chaos-term0 in the set of solutions if its sort is correct: | |
| 640 | (terletox-sublist-prime (if (or | |
| 641 | ;; (term-ill-defined chaos-term0) | |
| 642 | (parser-in-same-connected-component | |
| 643 | sort0 | |
| 644 | sort-constraint | |
| 645 | sort-order)) | |
| 646 | ;; then | |
| 647 | (list terletox0) | |
| 648 | ;; else -- completely illegual | |
| 649 | nil))) | |
| 636 | (sort0 (term-sort chaos-term0)) | |
| 637 | (sort-order (module-sort-order module)) | |
| 638 | ;; add chaos-term0 in the set of solutions if its sort is correct: | |
| 639 | (terletox-sublist-prime (if (or | |
| 640 | ;; (term-ill-defined chaos-term0) | |
| 641 | (parser-in-same-connected-component | |
| 642 | sort0 | |
| 643 | sort-constraint | |
| 644 | sort-order)) | |
| 645 | ;; then | |
| 646 | (list terletox0) | |
| 647 | ;; else -- completely illegual | |
| 648 | nil))) | |
| 650 | 649 | ;; |
| 651 | 650 | (when *on-parse-debug* |
| 652 | 651 | (format t "~%[continue-check]: const=") |
| 657 | 656 | (print-chaos-object terletox-sublist-prime)) |
| 658 | 657 | ;; |
| 659 | 658 | (nconc terletox-sublist-prime |
| 660 | (parser-continue terletox0 module level-constraint sort-constraint)))) | |
| 659 | (parser-continue terletox0 module level-constraint sort-constraint)))) | |
| 661 | 660 | |
| 662 | 661 | ;;; PARSER-CONTINUE : |
| 663 | 662 | ;;; ( ( ChaosTerm . PrecedenceLevel ) . TokenList ) |
| 689 | 688 | |
| 690 | 689 | (defun parser-continue (terletox0 module level-constraint sort-constraint) |
| 691 | 690 | (declare (type list terletox0) |
| 692 | (type module module) | |
| 693 | (type fixnum level-constraint) | |
| 694 | (type sort* sort-constraint)) | |
| 691 | (type module module) | |
| 692 | (type fixnum level-constraint) | |
| 693 | (type sort* sort-constraint)) | |
| 695 | 694 | (let ((token-list (cdr terletox0)) ) ;possibly emtpy |
| 696 | 695 | (declare (type list token-list)) |
| 697 | 696 | (if (null token-list) |
| 698 | nil | |
| 697 | nil | |
| 699 | 698 | (let* ((token1 (car token-list)) |
| 700 | (term-level0 (car terletox0))) | |
| 701 | (multiple-value-bind (choice mod-token) | |
| 702 | (choose-operators-from-token term-level0 | |
| 703 | token1 | |
| 704 | module | |
| 705 | level-constraint) | |
| 706 | (if (null choice) | |
| 707 | nil ;return a void solution | |
| 708 | (progn | |
| 709 | (when mod-token | |
| 710 | (setf (car token-list) mod-token)) | |
| 711 | (parser-continue-for-operators token-list | |
| 712 | (car term-level0) ;chaos-term0 | |
| 713 | choice | |
| 714 | module | |
| 715 | level-constraint | |
| 716 | sort-constraint)))))))) | |
| 699 | (term-level0 (car terletox0))) | |
| 700 | (multiple-value-bind (choice mod-token) | |
| 701 | (choose-operators-from-token term-level0 | |
| 702 | token1 | |
| 703 | module | |
| 704 | level-constraint) | |
| 705 | (if (null choice) | |
| 706 | nil ;return a void solution | |
| 707 | (progn | |
| 708 | (when mod-token | |
| 709 | (setf (car token-list) mod-token)) | |
| 710 | (parser-continue-for-operators token-list | |
| 711 | (car term-level0) ;chaos-term0 | |
| 712 | choice | |
| 713 | module | |
| 714 | level-constraint | |
| 715 | sort-constraint)))))))) | |
| 717 | 716 | |
| 718 | 717 | ; ------------------------------------------------------------------------- |
| 719 | 718 | |
| 750 | 749 | ;;; level-constraint, sort-constraint) . |
| 751 | 750 | ;;; |
| 752 | 751 | (defun parser-continue-for-operators (token-list |
| 753 | chaos-term0 | |
| 754 | late-juxt-operator-list | |
| 755 | module level-constraint sort-constraint) | |
| 752 | chaos-term0 | |
| 753 | late-juxt-operator-list | |
| 754 | module level-constraint sort-constraint) | |
| 756 | 755 | (declare (type list token-list late-juxt-operator-list) |
| 757 | (type t chaos-term0) | |
| 758 | (type module module) | |
| 759 | (type fixnum level-constraint) | |
| 760 | (type sort* sort-constraint)) | |
| 761 | (let ((terletox-list-prime nil)) ;initialization--to be returned in the end | |
| 756 | (type t chaos-term0) | |
| 757 | (type module module) | |
| 758 | (type fixnum level-constraint) | |
| 759 | (type sort* sort-constraint)) | |
| 760 | (let ((terletox-list-prime nil)) ;initialization--to be returned in the end | |
| 762 | 761 | (dolist (late-juxt-operator late-juxt-operator-list terletox-list-prime) |
| 763 | 762 | (when *on-parse-debug* |
| 764 | (format t "~&continue : try method ") | |
| 765 | (print-chaos-object late-juxt-operator)) | |
| 763 | (format t "~%continue : try method ") | |
| 764 | (print-chaos-object late-juxt-operator)) | |
| 766 | 765 | (setq terletox-list-prime |
| 767 | 766 | (nconc (parser-continue-for-operator token-list |
| 768 | chaos-term0 | |
| 769 | late-juxt-operator | |
| 770 | module | |
| 771 | level-constraint | |
| 772 | sort-constraint) | |
| 767 | chaos-term0 | |
| 768 | late-juxt-operator | |
| 769 | module | |
| 770 | level-constraint | |
| 771 | sort-constraint) | |
| 773 | 772 | terletox-list-prime))))) |
| 774 | 773 | |
| 775 | 774 | ;;; op parser-continue-for-operator : |
| 807 | 806 | ;;; -- and is so far an acceptable operator. |
| 808 | 807 | |
| 809 | 808 | (defun parser-continue-for-operator (token-list |
| 810 | chaos-term0 | |
| 811 | late-juxt-operator | |
| 812 | module level-constraint sort-constraint) | |
| 809 | chaos-term0 | |
| 810 | late-juxt-operator | |
| 811 | module level-constraint sort-constraint) | |
| 813 | 812 | (declare (type list token-list) |
| 814 | (type method late-juxt-operator) | |
| 815 | (type t chaos-term0) | |
| 816 | (type module module) | |
| 817 | (type fixnum level-constraint) | |
| 818 | (type sort* sort-constraint)) | |
| 813 | (type method late-juxt-operator) | |
| 814 | (type t chaos-term0) | |
| 815 | (type module module) | |
| 816 | (type fixnum level-constraint) | |
| 817 | (type sort* sort-constraint)) | |
| 819 | 818 | (let ((first-result-list (parser-finish-term-for-operator token-list |
| 820 | chaos-term0 | |
| 821 | late-juxt-operator | |
| 822 | module))) | |
| 819 | chaos-term0 | |
| 820 | late-juxt-operator | |
| 821 | module))) | |
| 823 | 822 | (if (null first-result-list) |
| 824 | nil ;return an empty solution | |
| 823 | nil ;return an empty solution | |
| 825 | 824 | (parser-continuing first-result-list |
| 826 | module | |
| 827 | level-constraint | |
| 828 | sort-constraint)))) | |
| 825 | module | |
| 826 | level-constraint | |
| 827 | sort-constraint)))) | |
| 829 | 828 | |
| 830 | 829 | ;;; op parser-finish-term-for-operator : |
| 831 | 830 | ;;; TokenList |
| 838 | 837 | ;;; |
| 839 | 838 | ;;;-- Notes: |
| 840 | 839 | ;;;-- 1. This procedure is not called, unless: |
| 841 | ;;;-- a. the next token to swallow is the first token part of the latefix | |
| 840 | ;;;-- a. the next token to swallow is the first token part of the latefix | |
| 842 | 841 | ;;;-- operator given as input argument; or refers to a variable, a |
| 843 | 842 | ;;;-- constant, a function, a prefix part of an operator or is "("; |
| 844 | ;;;-- b. the latefix or juxtaposition operator given as input is | |
| 843 | ;;;-- b. the latefix or juxtaposition operator given as input is | |
| 845 | 844 | ;;;-- acceptable so far, i.e. with regard to sort and precedence of |
| 846 | 845 | ;;;-- the subterm obtained so far. |
| 847 | 846 | ;;; |
| 857 | 856 | ;;;-- "_ _", e.g. "_ _", "_ _ _ ", "_ _ _ foo _". |
| 858 | 857 | ;;; |
| 859 | 858 | (defun parser-finish-term-for-operator (token-list chaos-term0 |
| 860 | late-juxt-operator module) | |
| 859 | late-juxt-operator module) | |
| 861 | 860 | (declare (type list token-list) |
| 862 | (type t chaos-term0 late-juxt-operator) | |
| 863 | (type module module)) | |
| 861 | (type t chaos-term0 late-juxt-operator) | |
| 862 | (type module module)) | |
| 864 | 863 | ;; |
| 865 | 864 | (let* ((form (method-form late-juxt-operator)) |
| 866 | (rest-form (cdr form)) ;we already got the first argument | |
| 867 | (arg-acc-list (list (cons (list chaos-term0) token-list))) ;initialization | |
| 868 | (arg-acc-list-prime ;possibly nil | |
| 869 | (parser-collect-arguments arg-acc-list | |
| 870 | module | |
| 871 | rest-form))) | |
| 865 | (rest-form (cdr form)) ;we already got the first argument | |
| 866 | (arg-acc-list (list (cons (list chaos-term0) token-list))) ;initialization | |
| 867 | (arg-acc-list-prime ;possibly nil | |
| 868 | (parser-collect-arguments arg-acc-list | |
| 869 | module | |
| 870 | rest-form))) | |
| 872 | 871 | (if (null arg-acc-list-prime) |
| 873 | ;; illegal | |
| 874 | ;; (parser-make-terms late-juxt-operator arg-acc-list module) | |
| 875 | nil | |
| 872 | ;; illegal | |
| 873 | ;; (parser-make-terms late-juxt-operator arg-acc-list module) | |
| 874 | nil | |
| 876 | 875 | (parser-make-terms late-juxt-operator arg-acc-list-prime module)))) |
| 877 | 876 | |
| 878 | 877 | ;;; op parser-get-term : |
| 884 | 883 | ;;; -- possibly empty |
| 885 | 884 | |
| 886 | 885 | (defun parser-get-term (token-list module level-constraint |
| 887 | &optional sort-constraint) | |
| 886 | &optional sort-constraint) | |
| 888 | 887 | (declare (type list token-list) |
| 889 | (type module module) | |
| 890 | (type fixnum level-constraint)) | |
| 891 | (let ((token1 (car token-list)) ;token-list non null | |
| 892 | (token-list-prime (cdr token-list))) | |
| 888 | (type module module) | |
| 889 | (type fixnum level-constraint)) | |
| 890 | (let ((token1 (car token-list)) ;token-list non null | |
| 891 | (token-list-prime (cdr token-list))) | |
| 893 | 892 | (when *on-parse-debug* |
| 894 | 893 | (format t "~%[parser-get-term]: token-list=~s" token-list) |
| 895 | 894 | (format t " sort-constraint: ~a" (if sort-constraint |
| 896 | (string (sort-name sort-constraint)) | |
| 897 | "None"))) | |
| 895 | (string (sort-name sort-constraint)) | |
| 896 | "None"))) | |
| 898 | 897 | (when (and (symbolp token1) |
| 899 | (memq token1 '(%slisp %glisp |%Chaos|))) | |
| 898 | (memq token1 '(%slisp %glisp |%Chaos|))) | |
| 900 | 899 | (return-from parser-get-term nil)) |
| 901 | 900 | ;;what first token have we got ? |
| 902 | 901 | (cond ((equal token1 "(") |
| 903 | ;;* Reserved tokens | |
| 904 | ;;* Parenthesized expression | |
| 905 | (if (null token-list-prime) | |
| 906 | nil ;return an empty set of solutions | |
| 907 | (parser-get-rest-of-parenthesized-expr token-list-prime | |
| 908 | module))) | |
| 909 | (;; (member token1 '( ")" "," ) :test #'equal) | |
| 910 | (equal token1 ")") | |
| 911 | ;;* Unacceptable reserved tokens | |
| 912 | nil ) ;return empty set of solutions | |
| 913 | ;;* Regular tokens | |
| 914 | ;; They have to have been declared operators or variables: | |
| 915 | (t (get-term-for-regular-token token1 | |
| 916 | token-list-prime | |
| 917 | module | |
| 918 | level-constraint | |
| 919 | sort-constraint))))) | |
| 902 | ;;* Reserved tokens | |
| 903 | ;;* Parenthesized expression | |
| 904 | (if (null token-list-prime) | |
| 905 | nil ;return an empty set of solutions | |
| 906 | (parser-get-rest-of-parenthesized-expr token-list-prime | |
| 907 | module))) | |
| 908 | (;; (member token1 '( ")" "," ) :test #'equal) | |
| 909 | (equal token1 ")") | |
| 910 | ;;* Unacceptable reserved tokens | |
| 911 | nil ) ;return empty set of solutions | |
| 912 | ;;* Regular tokens | |
| 913 | ;; They have to have been declared operators or variables: | |
| 914 | (t (get-term-for-regular-token token1 | |
| 915 | token-list-prime | |
| 916 | module | |
| 917 | level-constraint | |
| 918 | sort-constraint))))) | |
| 920 | 919 | |
| 921 | 920 | ;;; op parser-get-rest-of-parenthesized-expr : |
| 922 | 921 | ;;; TokenList -- not empty ! |
| 927 | 926 | ;;; |
| 928 | 927 | (defun parser-get-rest-of-parenthesized-expr (token-list module) |
| 929 | 928 | (declare (type list token-list) |
| 930 | (type module module)) | |
| 929 | (type module module)) | |
| 931 | 930 | (let ((terletox-list (parse-term token-list |
| 932 | module | |
| 933 | parser-max-precedence | |
| 934 | ;; sort-constraint | |
| 935 | *cosmos*)) | |
| 936 | (terletox-list-prime nil) ; accumulator--to be returned in the end | |
| 937 | terletox) | |
| 931 | module | |
| 932 | parser-max-precedence | |
| 933 | ;; sort-constraint | |
| 934 | *cosmos*)) | |
| 935 | (terletox-list-prime nil) ; accumulator--to be returned in the end | |
| 936 | terletox) | |
| 938 | 937 | (declare (type list terletox-list)) |
| 939 | 938 | ;; this is "over-general" |
| 940 | 939 | ;; group terms together with same remaining token list |
| 941 | 940 | ;; check for possible term qualification, if present treat |
| 942 | 941 | ;; group of terms as a unit |
| 943 | 942 | (loop (when (null terletox-list) (return terletox-list-prime)) |
| 944 | (setq terletox (car terletox-list)) | |
| 945 | (setq terletox-list (cdr terletox-list)) | |
| 946 | (let ((token-list (cdr terletox)) | |
| 947 | (chaos-terms (list (caar terletox))) | |
| 948 | (rest-terletox-list nil)) | |
| 949 | (dolist (tlt terletox-list) | |
| 950 | (if (eq (cdr tlt) token-list) | |
| 951 | (push (caar tlt) chaos-terms) ;use rplacd for space ?? | |
| 952 | (push tlt rest-terletox-list))) | |
| 953 | (setq terletox-list rest-terletox-list) | |
| 954 | ;; for each solution, try to swallow ")"; | |
| 955 | (if (equal (car token-list) ")") | |
| 956 | ;; token-list is not empty and begins with ")": | |
| 957 | ;; then swallow ")", set precedence level to 0, and accumulate: | |
| 958 | (if (and (cdr token-list) | |
| 959 | (let ((fst (char (the simple-string | |
| 960 | (cadr token-list)) | |
| 961 | 0)) | |
| 962 | (info (get-info-on-token | |
| 963 | (module-parse-dictionary *current-module*) | |
| 964 | (cadr token-list)))) | |
| 965 | (and (eql #\: fst) | |
| 966 | (not (equal (cadr token-list) ":is")) | |
| 967 | (dolist (in info t) | |
| 968 | (when (member (object-syntactic-type in) | |
| 969 | '(antefix juxtaposition latefix)) | |
| 970 | (return nil)))))) | |
| 971 | ;; !! might modify this last condition a bit | |
| 972 | (multiple-value-bind (terms toks) | |
| 973 | (parser-scan-qualification chaos-terms | |
| 974 | (cdr token-list)) | |
| 975 | (dolist (tm terms) | |
| 976 | (setq terletox-list-prime | |
| 977 | (cons (cons (cons tm parser-min-precedence) | |
| 978 | toks) | |
| 979 | terletox-list-prime)))) | |
| 980 | ;; else: there isn't a qualification; create continuations | |
| 981 | (dolist (tm chaos-terms) | |
| 982 | (setq terletox-list-prime | |
| 983 | (cons (cons (cons tm parser-min-precedence) | |
| 984 | (cdr token-list)) | |
| 985 | terletox-list-prime)))) | |
| 986 | nil))))) | |
| 943 | (setq terletox (car terletox-list)) | |
| 944 | (setq terletox-list (cdr terletox-list)) | |
| 945 | (let ((token-list (cdr terletox)) | |
| 946 | (chaos-terms (list (caar terletox))) | |
| 947 | (rest-terletox-list nil)) | |
| 948 | (dolist (tlt terletox-list) | |
| 949 | (if (eq (cdr tlt) token-list) | |
| 950 | (push (caar tlt) chaos-terms) ;use rplacd for space ?? | |
| 951 | (push tlt rest-terletox-list))) | |
| 952 | (setq terletox-list rest-terletox-list) | |
| 953 | ;; for each solution, try to swallow ")"; | |
| 954 | (if (equal (car token-list) ")") | |
| 955 | ;; token-list is not empty and begins with ")": | |
| 956 | ;; then swallow ")", set precedence level to 0, and accumulate: | |
| 957 | (if (and (cdr token-list) | |
| 958 | (let ((fst (char (the simple-string | |
| 959 | (cadr token-list)) | |
| 960 | 0)) | |
| 961 | (info (get-info-on-token | |
| 962 | (module-parse-dictionary *current-module*) | |
| 963 | (cadr token-list)))) | |
| 964 | (and (eql #\: fst) | |
| 965 | (not (equal (cadr token-list) ":is")) | |
| 966 | (dolist (in info t) | |
| 967 | (when (member (object-syntactic-type in) | |
| 968 | '(antefix juxtaposition latefix)) | |
| 969 | (return nil)))))) | |
| 970 | ;; !! might modify this last condition a bit | |
| 971 | (multiple-value-bind (terms toks) | |
| 972 | (parser-scan-qualification chaos-terms | |
| 973 | (cdr token-list)) | |
| 974 | (dolist (tm terms) | |
| 975 | (setq terletox-list-prime | |
| 976 | (cons (cons (cons tm parser-min-precedence) | |
| 977 | toks) | |
| 978 | terletox-list-prime)))) | |
| 979 | ;; else: there isn't a qualification; create continuations | |
| 980 | (dolist (tm chaos-terms) | |
| 981 | (setq terletox-list-prime | |
| 982 | (cons (cons (cons tm parser-min-precedence) | |
| 983 | (cdr token-list)) | |
| 984 | terletox-list-prime)))) | |
| 985 | nil))))) | |
| 987 | 986 | |
| 988 | 987 | ;;; op parser-scan-qualification : TermList TokenList -> TermList TokenList |
| 989 | 988 | ;;; Token list starts with the qualification; for ((x + y) . A) is (. A) |
| 992 | 991 | (defun parser-scan-qualification (chaos-terms token-list) |
| 993 | 992 | (declare (type list chaos-terms token-list)) |
| 994 | 993 | (let ((tokens (if (equal (car token-list) ":") |
| 995 | (cdr token-list) | |
| 996 | (cons (subseq (the simple-string (car token-list)) 1) | |
| 997 | (cdr token-list)))) | |
| 998 | (res nil) | |
| 999 | qualifier | |
| 1000 | rest) | |
| 994 | (cdr token-list) | |
| 995 | (cons (subseq (the simple-string (car token-list)) 1) | |
| 996 | (cdr token-list)))) | |
| 997 | (res nil) | |
| 998 | qualifier | |
| 999 | rest) | |
| 1001 | 1000 | (if (equal "(" (car tokens)) |
| 1002 | (let ((paren-pair (parser-scan-parenthesized-unit tokens))) | |
| 1003 | (declare (type list paren-pair)) | |
| 1004 | (if (null paren-pair) (setq res 'unbalanced) | |
| 1005 | (setq qualifier (if (atom (car paren-pair)) | |
| 1006 | (list (car paren-pair)) | |
| 1007 | (car paren-pair)) | |
| 1008 | rest (cdr paren-pair)))) | |
| 1009 | (setq qualifier (list (car tokens)) rest (cdr tokens))) | |
| 1001 | (let ((paren-pair (parser-scan-parenthesized-unit tokens))) | |
| 1002 | (declare (type list paren-pair)) | |
| 1003 | (if (null paren-pair) (setq res 'unbalanced) | |
| 1004 | (setq qualifier (if (atom (car paren-pair)) | |
| 1005 | (list (car paren-pair)) | |
| 1006 | (car paren-pair)) | |
| 1007 | rest (cdr paren-pair)))) | |
| 1008 | (setq qualifier (list (car tokens)) rest (cdr tokens))) | |
| 1010 | 1009 | (when *on-parse-debug* |
| 1011 | (format t "~&[scan-qualification] tokens=~a" tokens)) | |
| 1010 | (format t "~%[scan-qualification] tokens=~a" tokens)) | |
| 1012 | 1011 | (if (eq 'unbalanced res) |
| 1013 | (values chaos-terms token-list) | |
| 1014 | (let ((sorts (find-all-sorts-in *current-module* qualifier)) | |
| 1015 | (exact nil) | |
| 1016 | (res nil) | |
| 1017 | tm) | |
| 1018 | (when *on-parse-debug* | |
| 1019 | (format t "~&[scan-qualification] qualifier=~a" qualifier)) | |
| 1020 | (unless sorts ;; was qualifier | |
| 1021 | (with-output-chaos-error ('no-such-sort) | |
| 1022 | (format t "no such sort ~a" qualifier))) | |
| 1023 | ;; should give error message. and abort. | |
| 1024 | (loop (when (null chaos-terms) (return)) | |
| 1025 | (setq tm (car chaos-terms)) | |
| 1026 | (setq chaos-terms (cdr chaos-terms)) | |
| 1027 | (let ((t-sort (term-sort tm))) | |
| 1028 | (when (some #'(lambda (x) (sort<= t-sort x)) sorts) | |
| 1029 | (push tm res)) | |
| 1030 | (when (memq t-sort sorts) | |
| 1031 | ;; (setq exact tm) | |
| 1032 | (push tm exact)) | |
| 1033 | ;; (return nil) | |
| 1034 | )) | |
| 1035 | ;; | |
| 1036 | (when *on-parse-debug* | |
| 1037 | (format t "~& ...exect found: ") | |
| 1038 | (print-chaos-object exact)) | |
| 1039 | ;; | |
| 1040 | (if exact | |
| 1041 | ;; (values (list tm) rest) | |
| 1042 | (values exact rest) | |
| 1043 | (values res rest)))))) | |
| 1012 | (values chaos-terms token-list) | |
| 1013 | (let ((sorts (find-all-sorts-in *current-module* qualifier)) | |
| 1014 | (exact nil) | |
| 1015 | (res nil) | |
| 1016 | tm) | |
| 1017 | (when *on-parse-debug* | |
| 1018 | (format t "~%[scan-qualification] qualifier=~a" qualifier)) | |
| 1019 | (unless sorts ;; was qualifier | |
| 1020 | (with-output-chaos-error ('no-such-sort) | |
| 1021 | (format t "no such sort ~a" qualifier))) | |
| 1022 | ;; should give error message. and abort. | |
| 1023 | (loop (when (null chaos-terms) (return)) | |
| 1024 | (setq tm (car chaos-terms)) | |
| 1025 | (setq chaos-terms (cdr chaos-terms)) | |
| 1026 | (let ((t-sort (term-sort tm))) | |
| 1027 | (when (some #'(lambda (x) (sort<= t-sort x)) sorts) | |
| 1028 | (push tm res)) | |
| 1029 | (when (memq t-sort sorts) | |
| 1030 | ;; (setq exact tm) | |
| 1031 | (push tm exact)) | |
| 1032 | ;; (return nil) | |
| 1033 | )) | |
| 1034 | ;; | |
| 1035 | (when *on-parse-debug* | |
| 1036 | (format t "~% ...exact found: ") | |
| 1037 | (print-chaos-object exact)) | |
| 1038 | ;; | |
| 1039 | (if exact | |
| 1040 | ;; (values (list tm) rest) | |
| 1041 | (values exact rest) | |
| 1042 | (values res rest)))))) | |
| 1044 | 1043 | |
| 1045 | 1044 | (defun parser-scan-parenthesized-unit (tokens) |
| 1046 | 1045 | (declare (type list tokens)) |
| 1047 | 1046 | (if (equal "(" (car tokens)) |
| 1048 | 1047 | (let ((count 1) (lst (cdr tokens)) (res nil)) |
| 1049 | (declare (type fixnum count)) | |
| 1050 | (loop (when (null lst) (return 'unbalanced)) | |
| 1051 | (let ((tok (car lst))) | |
| 1052 | (setq lst (cdr lst)) | |
| 1053 | (when (and (= 1 count) (equal ")" tok)) | |
| 1054 | (return (cons (if (and res (null (cdr res))) | |
| 1055 | (car res) | |
| 1056 | (nreverse res)) | |
| 1057 | lst))) | |
| 1058 | (setq res (cons tok res)) | |
| 1059 | (if (equal "(" tok) (incf count) | |
| 1060 | (if (equal ")" tok) (decf count)))))) | |
| 1048 | (declare (type fixnum count)) | |
| 1049 | (loop (when (null lst) (return 'unbalanced)) | |
| 1050 | (let ((tok (car lst))) | |
| 1051 | (setq lst (cdr lst)) | |
| 1052 | (when (and (= 1 count) (equal ")" tok)) | |
| 1053 | (return (cons (if (and res (null (cdr res))) | |
| 1054 | (car res) | |
| 1055 | (nreverse res)) | |
| 1056 | lst))) | |
| 1057 | (setq res (cons tok res)) | |
| 1058 | (if (equal "(" tok) (incf count) | |
| 1059 | (if (equal ")" tok) (decf count)))))) | |
| 1061 | 1060 | tokens)) |
| 1062 | 1061 | |
| 1063 | 1062 | ;;; op get-term-for-regular-token : |
| 1070 | 1069 | ;;; -- possibly empty |
| 1071 | 1070 | |
| 1072 | 1071 | (defun get-term-for-regular-token (token token-list module level-constraint |
| 1073 | &optional sort-constraint) | |
| 1072 | &optional sort-constraint) | |
| 1074 | 1073 | (declare (type t token) |
| 1075 | (type list token-list) | |
| 1076 | (type module module) | |
| 1077 | (type fixnum level-constraint)) | |
| 1074 | (type list token-list) | |
| 1075 | (type module module) | |
| 1076 | (type fixnum level-constraint)) | |
| 1078 | 1077 | (flet ( |
| 1079 | #|| | |
| 1080 | (make-syntax-error () ; never used now | |
| 1081 | (list | |
| 1082 | (list | |
| 1083 | (list (make-applform | |
| 1084 | *op-err-sort* | |
| 1085 | *op-err-method* | |
| 1086 | (list (make-bconst-term *string-sort* token) | |
| 1087 | (make-bconst-term *universal-sort* | |
| 1088 | token-list))))))) | |
| 1089 | ||# | |
| 1090 | ) | |
| 1078 | #|| | |
| 1079 | (make-syntax-error () ; never used now | |
| 1080 | (list | |
| 1081 | (list | |
| 1082 | (list (make-applform | |
| 1083 | *op-err-sort* | |
| 1084 | *op-err-method* | |
| 1085 | (list (make-bconst-term *string-sort* token) | |
| 1086 | (make-bconst-term *universal-sort* | |
| 1087 | token-list))))))) | |
| 1088 | ||# | |
| 1089 | ) | |
| 1091 | 1090 | ;; |
| 1092 | (let ((terletox-list-prime nil)) ; accumulator | |
| 1091 | (let ((terletox-list-prime nil)) ; accumulator | |
| 1093 | 1092 | (multiple-value-bind (op-var-list mod-token) |
| 1094 | (get-info-on-token (module-parse-dictionary module) | |
| 1095 | token | |
| 1096 | ) | |
| 1097 | (declare (ignore mod-token)) | |
| 1098 | ;; list of Operators and Variables--token is the first token | |
| 1099 | ;; to appear in the pattern ! | |
| 1100 | ;; If choice between operators of | |
| 1101 | ;; comparable sorts ? ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
| 1102 | ;; for each operator or variable, go ahead and collect solutions | |
| 1103 | (if (and op-var-list | |
| 1104 | (not (equal op-var-list '(())))) | |
| 1105 | (dolist (op-var op-var-list | |
| 1106 | #|| | |
| 1107 | (if (null terletox-list-prime) | |
| 1108 | (make-syntax-error) | |
| 1109 | terletox-list-prime) | |
| 1110 | ||# | |
| 1111 | terletox-list-prime) | |
| 1112 | ;; (op-var op-var-list terletox-list-prime) | |
| 1113 | (let ((res (get-term-for-op-var op-var | |
| 1114 | token-list | |
| 1115 | module | |
| 1116 | level-constraint | |
| 1117 | sort-constraint))) | |
| 1118 | (when res | |
| 1119 | (when *on-parse-debug* | |
| 1120 | (format t "~%[get-term-for-regular-token]: ") | |
| 1121 | (format t "~% res = ") | |
| 1122 | (print-chaos-object res)) | |
| 1123 | (if (or ;; (not *fast-parse*) | |
| 1124 | (memq (object-syntactic-type op-var) | |
| 1125 | '(variable builtin lisp-form normal-term)) | |
| 1126 | (and (method-p op-var) | |
| 1127 | ;; (null (method-arity op-var)) | |
| 1128 | )) | |
| 1129 | (setq terletox-list-prime ; accumulate | |
| 1130 | (nconc res terletox-list-prime)) | |
| 1131 | (return-from get-term-for-regular-token | |
| 1132 | (nconc res terletox-list-prime))))))))))) | |
| 1093 | (get-info-on-token (module-parse-dictionary module) | |
| 1094 | token | |
| 1095 | ) | |
| 1096 | (declare (ignore mod-token)) | |
| 1097 | ;; list of Operators and Variables--token is the first token | |
| 1098 | ;; to appear in the pattern ! | |
| 1099 | ;; If choice between operators of | |
| 1100 | ;; comparable sorts ? ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
| 1101 | ;; for each operator or variable, go ahead and collect solutions | |
| 1102 | (if (and op-var-list | |
| 1103 | (not (equal op-var-list '(())))) | |
| 1104 | (dolist (op-var op-var-list | |
| 1105 | #|| | |
| 1106 | (if (null terletox-list-prime) | |
| 1107 | (make-syntax-error) | |
| 1108 | terletox-list-prime) | |
| 1109 | ||# | |
| 1110 | terletox-list-prime) | |
| 1111 | ;; (op-var op-var-list terletox-list-prime) | |
| 1112 | (let ((res (get-term-for-op-var op-var | |
| 1113 | token-list | |
| 1114 | module | |
| 1115 | level-constraint | |
| 1116 | sort-constraint))) | |
| 1117 | (when res | |
| 1118 | (when *on-parse-debug* | |
| 1119 | (format t "~%[get-term-for-regular-token]: ") | |
| 1120 | (format t "~% res = ") | |
| 1121 | (print-chaos-object res)) | |
| 1122 | (if (or ;; (not *fast-parse*) | |
| 1123 | (memq (object-syntactic-type op-var) | |
| 1124 | '(variable builtin lisp-form normal-term)) | |
| 1125 | (and (method-p op-var) | |
| 1126 | ;; (null (method-arity op-var)) | |
| 1127 | )) | |
| 1128 | (setq terletox-list-prime ; accumulate | |
| 1129 | (nconc res terletox-list-prime)) | |
| 1130 | (return-from get-term-for-regular-token | |
| 1131 | (nconc res terletox-list-prime))))))))))) | |
| 1133 | 1132 | |
| 1134 | 1133 | ;;; op get-term-for-op-var : |
| 1135 | 1134 | ;;; Operator(Mehotd) + Variable |
| 1140 | 1139 | ;;; LIST[ ( ( ChaosTerm . PrecedenceLevel ) . TokenList ) ] . |
| 1141 | 1140 | ;;; -- possibly empty |
| 1142 | 1141 | (defun get-term-for-op-var (op-var token-list module level-constraint |
| 1143 | &optional sort-constraint) | |
| 1142 | &optional sort-constraint) | |
| 1144 | 1143 | (declare (type t op-var) |
| 1145 | (type list token-list) | |
| 1146 | (type module module) | |
| 1147 | (type fixnum level-constraint)) | |
| 1144 | (type list token-list) | |
| 1145 | (type module module) | |
| 1146 | (type fixnum level-constraint)) | |
| 1148 | 1147 | (when *on-parse-debug* |
| 1149 | 1148 | (format t "~%[get-term-for-op-var]: op-var = ~s, syntactic-type = ~s" |
| 1150 | op-var (object-syntactic-type op-var)) | |
| 1149 | op-var (object-syntactic-type op-var)) | |
| 1151 | 1150 | (format t "~% sort constraint = ") |
| 1152 | 1151 | (print-chaos-object sort-constraint)) |
| 1153 | 1152 | (case (object-syntactic-type op-var) |
| 1158 | 1157 | (when (eq (object-syntactic-type op-var) 'variable) |
| 1159 | 1158 | (push (cons (variable-name op-var) op-var) *parse-variables*)) |
| 1160 | 1159 | (if (or (null sort-constraint) |
| 1161 | (sort<= (term-sort op-var) sort-constraint *current-sort-order*)) | |
| 1162 | (list (cons (cons op-var parser-min-precedence) token-list)) | |
| 1160 | (sort<= (term-sort op-var) sort-constraint *current-sort-order*)) | |
| 1161 | (list (cons (cons op-var parser-min-precedence) token-list)) | |
| 1163 | 1162 | nil)) |
| 1164 | 1163 | |
| 1165 | 1164 | ;; 2. Antefix |
| 1166 | 1165 | (antefix |
| 1167 | 1166 | (when sort-constraint |
| 1168 | 1167 | (unless (sort<= (method-coarity op-var) sort-constraint *current-sort-order*) |
| 1169 | (return-from get-term-for-op-var nil))) | |
| 1168 | (return-from get-term-for-op-var nil))) | |
| 1170 | 1169 | ;; is precedence of antefix operator acceptable ? |
| 1171 | 1170 | (unless (<= (the fixnum (get-method-precedence op-var)) |
| 1172 | level-constraint) | |
| 1171 | level-constraint) | |
| 1173 | 1172 | (return-from get-term-for-op-var nil)) |
| 1174 | 1173 | (let ((res (get-term-from-antefix-operator op-var token-list module))) |
| 1175 | 1174 | res)) |
| 1191 | 1190 | |
| 1192 | 1191 | (defun get-term-from-antefix-operator (method token-list module) |
| 1193 | 1192 | (declare (type method method) |
| 1194 | (type list token-list) | |
| 1195 | (type module module)) | |
| 1193 | (type list token-list) | |
| 1194 | (type module module)) | |
| 1196 | 1195 | (let* ((form (method-form method)) |
| 1197 | (rest-form (cdr form)) ;we already swallowed the first token | |
| 1198 | ;;rest-form possibly empty | |
| 1199 | (arg-acc-list (list (cons nil token-list))) ;initialization | |
| 1200 | (arg-acc-list-prime (parser-collect-arguments arg-acc-list | |
| 1201 | module | |
| 1202 | rest-form))) | |
| 1196 | (rest-form (cdr form)) ;we already swallowed the first token | |
| 1197 | ;;rest-form possibly empty | |
| 1198 | (arg-acc-list (list (cons nil token-list))) ;initialization | |
| 1199 | (arg-acc-list-prime (parser-collect-arguments arg-acc-list | |
| 1200 | module | |
| 1201 | rest-form))) | |
| 1203 | 1202 | (if (null arg-acc-list-prime) |
| 1204 | ;; return a void answer | |
| 1205 | ;; (parser-make-terms method arg-acc-list module) | |
| 1206 | nil | |
| 1203 | ;; return a void answer | |
| 1204 | ;; (parser-make-terms method arg-acc-list module) | |
| 1205 | nil | |
| 1207 | 1206 | (parser-make-terms method arg-acc-list-prime module)))) |
| 1208 | 1207 | |
| 1209 | 1208 | ;;; AST |
| 1210 | 1209 | ;;; |
| 1211 | 1210 | (defun get-term-from-ast-operator (key token-list module) |
| 1212 | 1211 | (declare (type list key token-list) |
| 1213 | (type module module)) | |
| 1212 | (type module module)) | |
| 1214 | 1213 | (let* ((form (cdr key)) |
| 1215 | (rest-form (cdr form)) | |
| 1216 | (arg-acc-list (list (cons nil token-list))) | |
| 1217 | (arg-acc-list-prime (parser-collect-arguments arg-acc-list | |
| 1218 | module | |
| 1219 | rest-form))) | |
| 1214 | (rest-form (cdr form)) | |
| 1215 | (arg-acc-list (list (cons nil token-list))) | |
| 1216 | (arg-acc-list-prime (parser-collect-arguments arg-acc-list | |
| 1217 | module | |
| 1218 | rest-form))) | |
| 1220 | 1219 | (when *on-parse-debug* |
| 1221 | (format t "~& rest-form = ") | |
| 1220 | (format t "~% rest-form = ") | |
| 1222 | 1221 | (print-chaos-object rest-form)) |
| 1223 | ||
| 1224 | 1222 | (if (null arg-acc-list-prime) |
| 1225 | nil | |
| 1226 | (parser-make-terms key arg-acc-list-prime module)))) | |
| 1223 | nil | |
| 1224 | (parser-make-terms key arg-acc-list-prime module)))) | |
| 1227 | 1225 | |
| 1228 | 1226 | ;;; op choose-operators-from-token : |
| 1229 | 1227 | ;;; ( ChaosTerm . PrecedenceLevel ) |
| 1237 | 1235 | ;;; -- (i.e. of pattern { - - <etc> } ). |
| 1238 | 1236 | |
| 1239 | 1237 | (defun choose-operators-from-token (term-level0 token module level-constraint |
| 1240 | &optional sort-constraint) | |
| 1238 | &optional sort-constraint) | |
| 1241 | 1239 | (declare (type t term-level0 token) |
| 1242 | (type module module) | |
| 1243 | (type fixnum level-constraint)) | |
| 1240 | (type module module) | |
| 1241 | (type fixnum level-constraint)) | |
| 1244 | 1242 | (when *on-parse-debug* |
| 1245 | 1243 | (format t "~%[choose-operators-from-token]: token = ~s" token) |
| 1246 | 1244 | (format t "~% sort constraint = ") |
| 1247 | 1245 | (print-chaos-object sort-constraint)) |
| 1248 | 1246 | (cond ((equal token "(") |
| 1249 | (choose-juxtaposition-operators term-level0 module level-constraint)) | |
| 1250 | (;; (member token '( ")" "," ) :test #'equal) | |
| 1251 | (equal token ")") | |
| 1252 | nil ) | |
| 1253 | ; return a void answer | |
| 1254 | ;; Regular tokens | |
| 1255 | (t | |
| 1256 | (multiple-value-bind (op-var-list mod-token) | |
| 1257 | (get-info-on-token (module-parse-dictionary module) | |
| 1258 | token | |
| 1259 | sort-constraint) | |
| 1260 | (if (null op-var-list) | |
| 1261 | nil ; | |
| 1262 | (values (parser-choosing-operators term-level0 | |
| 1263 | op-var-list | |
| 1264 | module | |
| 1265 | level-constraint) | |
| 1266 | mod-token)))))) | |
| 1247 | (choose-juxtaposition-operators term-level0 module level-constraint)) | |
| 1248 | (;; (member token '( ")" "," ) :test #'equal) | |
| 1249 | (equal token ")") | |
| 1250 | nil ) | |
| 1251 | ; return a void answer | |
| 1252 | ;; Regular tokens | |
| 1253 | (t | |
| 1254 | (multiple-value-bind (op-var-list mod-token) | |
| 1255 | (get-info-on-token (module-parse-dictionary module) | |
| 1256 | token | |
| 1257 | sort-constraint) | |
| 1258 | (if (null op-var-list) | |
| 1259 | nil ; | |
| 1260 | (values (parser-choosing-operators term-level0 | |
| 1261 | op-var-list | |
| 1262 | module | |
| 1263 | level-constraint) | |
| 1264 | mod-token)))))) | |
| 1267 | 1265 | |
| 1268 | 1266 | ;;; op parser-choosing-operators : |
| 1269 | 1267 | ;;; ( ChaosTerm . PrecedenceLevel ) |
| 1275 | 1273 | |
| 1276 | 1274 | (defun parser-choosing-operators (term-level0 op-var-list module level-constraint) |
| 1277 | 1275 | (declare (type t term-level0) |
| 1278 | (type list op-var-list) | |
| 1279 | (type module module) | |
| 1280 | (type fixnum level-constraint)) | |
| 1276 | (type list op-var-list) | |
| 1277 | (type module module) | |
| 1278 | (type fixnum level-constraint)) | |
| 1281 | 1279 | (let ((late-juxt-op-list-prime nil)) |
| 1282 | 1280 | (dolist (op-var op-var-list |
| 1283 | (progn (when *on-parse-debug* | |
| 1284 | (format t "~%[parser-choosing-operators]:~%-- selected ops : ") | |
| 1285 | (print-chaos-object late-juxt-op-list-prime)) | |
| 1286 | late-juxt-op-list-prime)) | |
| 1281 | (progn (when *on-parse-debug* | |
| 1282 | (format t "~%[parser-choosing-operators]:~%-- selected ops : ") | |
| 1283 | (print-chaos-object late-juxt-op-list-prime)) | |
| 1284 | late-juxt-op-list-prime)) | |
| 1287 | 1285 | (setq late-juxt-op-list-prime ;accumulate |
| 1288 | (union (choose-operators term-level0 | |
| 1289 | op-var | |
| 1290 | module | |
| 1291 | level-constraint) | |
| 1292 | late-juxt-op-list-prime))))) | |
| 1286 | (union (choose-operators term-level0 | |
| 1287 | op-var | |
| 1288 | module | |
| 1289 | level-constraint) | |
| 1290 | late-juxt-op-list-prime))))) | |
| 1293 | 1291 | |
| 1294 | 1292 | ;;; op choose-operators : |
| 1295 | 1293 | ;;; ( ChaosTerm . PrecedenceLevel ) |
| 1301 | 1299 | ;;; |
| 1302 | 1300 | (defun choose-operators (term-level0 op-var module level-constraint) |
| 1303 | 1301 | (declare (type t term-level0 op-var) |
| 1304 | (type module module) | |
| 1305 | (type fixnum level-constraint)) | |
| 1302 | (type module module) | |
| 1303 | (type fixnum level-constraint)) | |
| 1306 | 1304 | (case (object-syntactic-type op-var) |
| 1307 | 1305 | ;; 1. |
| 1308 | 1306 | (variable (choose-juxtaposition-operators term-level0 |
| 1309 | module | |
| 1310 | level-constraint)) | |
| 1307 | module | |
| 1308 | level-constraint)) | |
| 1311 | 1309 | ;; 2. |
| 1312 | (antefix ; is op-var acceptable with regard to | |
| 1313 | ; level-constraint ? | |
| 1310 | (antefix ; is op-var acceptable with regard to | |
| 1311 | ; level-constraint ? | |
| 1314 | 1312 | (if (<= (the fixnum (get-method-precedence op-var)) |
| 1315 | level-constraint) | |
| 1316 | (choose-juxtaposition-operators term-level0 | |
| 1317 | module | |
| 1318 | level-constraint) | |
| 1319 | nil ;return a void answer | |
| 1320 | )) | |
| 1313 | level-constraint) | |
| 1314 | (choose-juxtaposition-operators term-level0 | |
| 1315 | module | |
| 1316 | level-constraint) | |
| 1317 | nil ;return a void answer | |
| 1318 | )) | |
| 1321 | 1319 | ;; 3. |
| 1322 | 1320 | (ast |
| 1323 | 1321 | (choose-juxtaposition-operators term-level0 module level-constraint)) |
| 1324 | 1322 | |
| 1325 | 1323 | ;; 4. |
| 1326 | 1324 | (latefix (choose-latefix-operators term-level0 |
| 1327 | op-var | |
| 1328 | module | |
| 1329 | level-constraint)) | |
| 1325 | op-var | |
| 1326 | module | |
| 1327 | level-constraint)) | |
| 1330 | 1328 | ;; 4. builtin |
| 1331 | 1329 | (builtin (choose-juxtaposition-operators term-level0 module level-constraint)) |
| 1332 | 1330 | ;; 5. others |
| 1346 | 1344 | |
| 1347 | 1345 | (defun choose-juxtaposition-operators (term-level0 module level-constraint) |
| 1348 | 1346 | (declare (type t term-level0) |
| 1349 | (type module module) | |
| 1350 | (type fixnum level-constraint)) | |
| 1347 | (type module module) | |
| 1348 | (type fixnum level-constraint)) | |
| 1351 | 1349 | (let ((juxt-op-list (module-juxtaposition module)) ) |
| 1352 | 1350 | (if (null juxt-op-list) |
| 1353 | nil ; return a void answer | |
| 1351 | nil ; return a void answer | |
| 1354 | 1352 | (let ((res nil)) |
| 1355 | (dolist (juxt-op juxt-op-list res) | |
| 1356 | (when (and (<= (the fixnum | |
| 1357 | (get-method-precedence juxt-op)) | |
| 1358 | level-constraint) | |
| 1359 | (parser-check-operator term-level0 juxt-op module)) | |
| 1360 | (setq res (cons juxt-op res)))))))) | |
| 1353 | (dolist (juxt-op juxt-op-list res) | |
| 1354 | (when (and (<= (the fixnum | |
| 1355 | (get-method-precedence juxt-op)) | |
| 1356 | level-constraint) | |
| 1357 | (parser-check-operator term-level0 juxt-op module)) | |
| 1358 | (setq res (cons juxt-op res)))))))) | |
| 1361 | 1359 | |
| 1362 | 1360 | ;;; op choose-latefix-operators : |
| 1363 | 1361 | ;;; ( ChaosTerm . PrecedenceLevel ) |
| 1374 | 1372 | |
| 1375 | 1373 | (defun choose-latefix-operators (term-level0 latefix-operator module level-constraint) |
| 1376 | 1374 | (declare (type t term-level0) |
| 1377 | (type method latefix-operator) | |
| 1378 | (type module module) | |
| 1379 | (type fixnum level-constraint)) | |
| 1375 | (type method latefix-operator) | |
| 1376 | (type module module) | |
| 1377 | (type fixnum level-constraint)) | |
| 1380 | 1378 | (if (and (<= (the fixnum (get-method-precedence latefix-operator)) |
| 1381 | level-constraint) | |
| 1382 | (parser-check-operator term-level0 | |
| 1383 | latefix-operator | |
| 1384 | module)) | |
| 1379 | level-constraint) | |
| 1380 | (parser-check-operator term-level0 | |
| 1381 | latefix-operator | |
| 1382 | module)) | |
| 1385 | 1383 | (list latefix-operator) |
| 1386 | 1384 | ;; return a void answer |
| 1387 | 1385 | nil)) |
| 1398 | 1396 | |
| 1399 | 1397 | (defun parser-check-operator (term-level0 late-juxt-op module) |
| 1400 | 1398 | (declare (type list term-level0) |
| 1401 | (type method late-juxt-op) | |
| 1402 | (type module module)) | |
| 1399 | (type method late-juxt-op) | |
| 1400 | (type module module)) | |
| 1403 | 1401 | (let* ((sort0 (term-sort (car term-level0))) |
| 1404 | (level0 (cdr term-level0)) | |
| 1405 | (form (method-form late-juxt-op)) | |
| 1406 | (first-arg-constraints (car form)) | |
| 1407 | (first-arg-level-constraint (or (cadr first-arg-constraints) 0)) | |
| 1408 | (first-arg-sort-constraint (car (method-arity late-juxt-op))) | |
| 1409 | (sort-order (module-sort-order module))) | |
| 1402 | (level0 (cdr term-level0)) | |
| 1403 | (form (method-form late-juxt-op)) | |
| 1404 | (first-arg-constraints (car form)) | |
| 1405 | (first-arg-level-constraint (or (cadr first-arg-constraints) 0)) | |
| 1406 | (first-arg-sort-constraint (car (method-arity late-juxt-op))) | |
| 1407 | (sort-order (module-sort-order module))) | |
| 1410 | 1408 | (declare (type fixnum level0 first-arg-level-constraint)) |
| 1411 | 1409 | (and (<= level0 first-arg-level-constraint) |
| 1412 | (parser-in-same-connected-component sort0 | |
| 1413 | first-arg-sort-constraint | |
| 1414 | sort-order)))) | |
| 1410 | (parser-in-same-connected-component sort0 | |
| 1411 | first-arg-sort-constraint | |
| 1412 | sort-order)))) | |
| 1415 | 1413 | |
| 1416 | 1414 | ;;; op parser-collect-arguments : |
| 1417 | 1415 | ;;; LIST[ ( ChaosTermList . TokenList ) ] -- not empty ! |
| 1442 | 1440 | ;;; |
| 1443 | 1441 | (defun parser-collect-arguments (arg-acc-list module rest-form) |
| 1444 | 1442 | (declare (type list arg-acc-list) |
| 1445 | (type module module) | |
| 1446 | (type list rest-form)) | |
| 1443 | (type module module) | |
| 1444 | (type list rest-form)) | |
| 1447 | 1445 | (let ((arg-acc-list-prime arg-acc-list)) |
| 1448 | 1446 | (dolist (form-item rest-form) |
| 1449 | 1447 | (case (car form-item) |
| 1450 | ;; 1. | |
| 1451 | (token (setq arg-acc-list-prime | |
| 1452 | (parser-scan-token arg-acc-list-prime (cdr form-item)))) | |
| 1453 | ;; 2. | |
| 1454 | (argument (setq arg-acc-list-prime | |
| 1455 | (parser-collect-one-argument arg-acc-list-prime | |
| 1456 | module | |
| 1457 | (cadr form-item) | |
| 1458 | (cddr form-item)))) | |
| 1459 | ;; 3. collect varargs. --- to be done. | |
| 1460 | ((argument* argument+) | |
| 1461 | (let ((limit 256)) ; for avoiding infinite loop | |
| 1462 | (declare (type fixnum limit)) | |
| 1463 | (loop | |
| 1464 | (decf limit) | |
| 1465 | (when (<= limit 0) | |
| 1466 | (with-output-chaos-warning () | |
| 1467 | (format t "over 256 arguments for argument*") | |
| 1468 | (return-from parser-collect-arguments nil))) | |
| 1469 | (when (eq 'argument+ (car form-item)) | |
| 1470 | (setf arg-acc-list-prime | |
| 1471 | (parser-collect-one-argument arg-acc-list-prime | |
| 1472 | module | |
| 1473 | (cadr form-item) | |
| 1474 | (cddr form-item))) | |
| 1475 | (unless arg-acc-list-prime (return))) | |
| 1476 | (let ((tok (parser-scan-token arg-acc-list-prime ")"))) | |
| 1477 | (if tok | |
| 1478 | (progn (setf arg-acc-list-prime tok) | |
| 1479 | (return)) | |
| 1480 | (setq arg-acc-list-prime | |
| 1481 | (parser-collect-one-argument arg-acc-list-prime | |
| 1482 | module | |
| 1483 | (cadr form-item) | |
| 1484 | (cddr form-item))))))))) | |
| 1448 | ;; 1. | |
| 1449 | (token (setq arg-acc-list-prime | |
| 1450 | (parser-scan-token arg-acc-list-prime (cdr form-item)))) | |
| 1451 | ;; 2. | |
| 1452 | (argument (setq arg-acc-list-prime | |
| 1453 | (parser-collect-one-argument arg-acc-list-prime | |
| 1454 | module | |
| 1455 | (cadr form-item) | |
| 1456 | (cddr form-item)))) | |
| 1457 | ;; 3. collect varargs. --- to be done. | |
| 1458 | ((argument* argument+) | |
| 1459 | (let ((limit 256)) ; for avoiding infinite loop | |
| 1460 | (declare (type fixnum limit)) | |
| 1461 | (loop | |
| 1462 | (decf limit) | |
| 1463 | (when (<= limit 0) | |
| 1464 | (with-output-chaos-warning () | |
| 1465 | (format t "over 256 arguments for argument*") | |
| 1466 | (return-from parser-collect-arguments nil))) | |
| 1467 | (when (eq 'argument+ (car form-item)) | |
| 1468 | (setf arg-acc-list-prime | |
| 1469 | (parser-collect-one-argument arg-acc-list-prime | |
| 1470 | module | |
| 1471 | (cadr form-item) | |
| 1472 | (cddr form-item))) | |
| 1473 | (unless arg-acc-list-prime (return))) | |
| 1474 | (let ((tok (parser-scan-token arg-acc-list-prime ")"))) | |
| 1475 | (if tok | |
| 1476 | (progn (setf arg-acc-list-prime tok) | |
| 1477 | (return)) | |
| 1478 | (setq arg-acc-list-prime | |
| 1479 | (parser-collect-one-argument arg-acc-list-prime | |
| 1480 | module | |
| 1481 | (cadr form-item) | |
| 1482 | (cddr form-item))))))))) | |
| 1485 | 1483 | (if (null arg-acc-list-prime) |
| 1486 | (return nil) | |
| 1487 | ;; to avoid unnecessary additional loops, and to avoid calling | |
| 1488 | ;; either parser-scan-token or | |
| 1489 | ;; parser-collect-one-argument with void arguments. | |
| 1490 | )) | |
| 1484 | (return nil) | |
| 1485 | ;; to avoid unnecessary additional loops, and to avoid calling | |
| 1486 | ;; either parser-scan-token or | |
| 1487 | ;; parser-collect-one-argument with void arguments. | |
| 1488 | )) | |
| 1491 | 1489 | ;; a bit optimization |
| 1492 | 1490 | #|| |
| 1493 | 1491 | (let ((res nil)) |
| 1494 | 1492 | (when *on-parse-debug* |
| 1495 | (dotimes (x (length arg-acc-list-prime)) | |
| 1496 | (format t "~%*** acc-arg #~D : " x) | |
| 1497 | (print-chaos-object (car (nth x arg-acc-list-prime))) | |
| 1498 | (format t "|| tokens ~a" (cdr (nth x arg-acc-list-prime))))) | |
| 1493 | (dotimes (x (length arg-acc-list-prime)) | |
| 1494 | (format t "~%*** acc-arg #~D : " x) | |
| 1495 | (print-chaos-object (car (nth x arg-acc-list-prime))) | |
| 1496 | (format t "|| tokens ~a" (cdr (nth x arg-acc-list-prime))))) | |
| 1499 | 1497 | (setq res (remove-if #'(lambda (x) |
| 1500 | (not (term-is-really-well-defined (car x)))) | |
| 1501 | arg-acc-list-prime)) | |
| 1498 | (not (term-is-really-well-defined (car x)))) | |
| 1499 | arg-acc-list-prime)) | |
| 1502 | 1500 | (when (< (length res) (length arg-acc-list-prime)) |
| 1503 | (print-in-progress "!")) | |
| 1501 | (print-in-progress "!")) | |
| 1504 | 1502 | (or res arg-acc-list-prime)) |
| 1505 | 1503 | ||# |
| 1506 | 1504 | arg-acc-list-prime)) |
| 1514 | 1512 | ;;; LIST[ ( ChaosTermList . TokenList ) ] |
| 1515 | 1513 | |
| 1516 | 1514 | (defun parser-collect-one-argument (arg-acc-list module |
| 1517 | level-constraint sort-constraint) | |
| 1515 | level-constraint sort-constraint) | |
| 1518 | 1516 | (declare (type list arg-acc-list) |
| 1519 | (type module module) | |
| 1520 | (type fixnum level-constraint) | |
| 1521 | (type sort* sort-constraint)) | |
| 1517 | (type module module) | |
| 1518 | (type fixnum level-constraint) | |
| 1519 | (type sort* sort-constraint)) | |
| 1522 | 1520 | (let ((arg-acc-list-prime nil)) |
| 1523 | 1521 | (dolist (arg-acc arg-acc-list (delete-duplicates arg-acc-list-prime :test #'equal)) |
| 1524 | 1522 | (let ((token-list (cdr arg-acc)) ) |
| 1525 | 1523 | (if (null token-list) |
| 1526 | nil ;this iteration is finished | |
| 1527 | (let* ((arg-list (car arg-acc)) | |
| 1528 | (terletox-list (parse-term token-list | |
| 1529 | module | |
| 1530 | level-constraint | |
| 1531 | sort-constraint))) | |
| 1532 | ;; notice that parser is not called with | |
| 1533 | ;; token-list empty | |
| 1534 | (dolist (terletox terletox-list) | |
| 1535 | ;; if terletox-list empty, no effect | |
| 1536 | (let* ((arg-prime (caar terletox)) | |
| 1537 | (token-list-prime (cdr terletox)) | |
| 1538 | (arg-list-prime (cons arg-prime arg-list)) | |
| 1539 | ;; notice that we accumulate arguments in reverse order | |
| 1540 | (arg-acc-prime (cons arg-list-prime token-list-prime))) | |
| 1541 | (setq arg-acc-list-prime | |
| 1542 | (cons arg-acc-prime arg-acc-list-prime)))))))))) | |
| 1524 | nil ;this iteration is finished | |
| 1525 | (let* ((arg-list (car arg-acc)) | |
| 1526 | (terletox-list (parse-term token-list | |
| 1527 | module | |
| 1528 | level-constraint | |
| 1529 | sort-constraint))) | |
| 1530 | ;; notice that parser is not called with | |
| 1531 | ;; token-list empty | |
| 1532 | (dolist (terletox terletox-list) | |
| 1533 | ;; if terletox-list empty, no effect | |
| 1534 | (let* ((arg-prime (caar terletox)) | |
| 1535 | (token-list-prime (cdr terletox)) | |
| 1536 | (arg-list-prime (cons arg-prime arg-list)) | |
| 1537 | ;; notice that we accumulate arguments in reverse order | |
| 1538 | (arg-acc-prime (cons arg-list-prime token-list-prime))) | |
| 1539 | (setq arg-acc-list-prime | |
| 1540 | (cons arg-acc-prime arg-acc-list-prime)))))))))) | |
| 1543 | 1541 | |
| 1544 | 1542 | ;;; op parser-scan-token : |
| 1545 | 1543 | ;;; LIST[ ( ChaosTermList . TokenList ) ] -- not empty ! |
| 1549 | 1547 | ;;; |
| 1550 | 1548 | (defun parser-scan-token (arg-acc-list token) |
| 1551 | 1549 | (declare (type list arg-acc-list) |
| 1552 | (type t token)) | |
| 1550 | (type t token)) | |
| 1553 | 1551 | (let ((arg-acc-list-prime nil)) |
| 1554 | 1552 | (dolist (arg-acc arg-acc-list arg-acc-list-prime) |
| 1555 | 1553 | (let ((token-list (cdr arg-acc))) |
| 1556 | 1554 | (if (equal token (car token-list)) |
| 1557 | ;; token-list is not empty and begins with expected token | |
| 1555 | ;; token-list is not empty and begins with expected token | |
| 1558 | 1556 | (let* ((token-list-prime (cdr token-list)) |
| 1559 | (arg-list (car arg-acc)) | |
| 1560 | (arg-acc-prime (cons arg-list token-list-prime))) | |
| 1557 | (arg-list (car arg-acc)) | |
| 1558 | (arg-acc-prime (cons arg-list token-list-prime))) | |
| 1561 | 1559 | (setq arg-acc-list-prime |
| 1562 | 1560 | (cons arg-acc-prime arg-acc-list-prime))) |
| 1563 | nil))))) | |
| 1561 | nil))))) | |
| 1564 | 1562 | |
| 1565 | 1563 | ;;; op parser-in-same-connected-component : |
| 1566 | 1564 | ;;; Sort Sort SortOrder -> Bool |
| 1573 | 1571 | (sort= sort1 *bottom-sort*) |
| 1574 | 1572 | (sort= sort2 *bottom-sort*) |
| 1575 | 1573 | (if (err-sort-p sort2) |
| 1576 | (sort= sort2 (the-err-sort sort1 sort-order)) | |
| 1577 | (and (eq (sort-hidden sort1) (sort-hidden sort2)) | |
| 1578 | (or (if (sort-is-hidden sort1) | |
| 1579 | (sort= sort2 *huniversal-sort*) | |
| 1580 | (sort= sort2 *universal-sort*)) | |
| 1581 | (sort< sort1 sort2 sort-order) | |
| 1582 | (sort< sort2 sort1 sort-order) | |
| 1583 | (is-in-same-connected-component sort1 sort2 sort-order)))))) | |
| 1574 | (sort= sort2 (the-err-sort sort1 sort-order)) | |
| 1575 | (and (eq (sort-hidden sort1) (sort-hidden sort2)) | |
| 1576 | (or (if (sort-is-hidden sort1) | |
| 1577 | (sort= sort2 *huniversal-sort*) | |
| 1578 | (sort= sort2 *universal-sort*)) | |
| 1579 | (sort< sort1 sort2 sort-order) | |
| 1580 | (sort< sort2 sort1 sort-order) | |
| 1581 | (is-in-same-connected-component sort1 sort2 sort-order)))))) | |
| 1584 | 1582 | |
| 1585 | 1583 | ;;; op parser-make-terms : |
| 1586 | 1584 | ;;; Operator |
| 1594 | 1592 | |
| 1595 | 1593 | (defun parser-make-terms (method arg-acc-list module) |
| 1596 | 1594 | (declare (type t method) |
| 1597 | (type list arg-acc-list) | |
| 1598 | (type module module)) | |
| 1595 | (type list arg-acc-list) | |
| 1596 | (type module module)) | |
| 1599 | 1597 | (when *on-parse-debug* |
| 1600 | (format t "~&make term~% : method = ") | |
| 1598 | (format t "~%make term~% : method = ") | |
| 1601 | 1599 | (print-chaos-object method) |
| 1602 | (format t "~& : arg-acc-list = ") | |
| 1600 | (format t " : arg-acc-list = ") | |
| 1603 | 1601 | (map nil #'print-chaos-object arg-acc-list) |
| 1604 | 1602 | (force-output)) |
| 1605 | 1603 | (let ((terletox-list nil)) |
| 1607 | 1605 | ;; arg-acc ::= (LIST[ChaosTerm] . TokenList) |
| 1608 | 1606 | (block iteration |
| 1609 | 1607 | (let* ((arg-list (car arg-acc)) |
| 1610 | (direct-arg-list (reverse arg-list)) | |
| 1611 | ;; arguments were accumulated in reverse order ! | |
| 1612 | (arg-sort-list (mapcar #'(lambda (x) (term-sort x)) direct-arg-list)) | |
| 1613 | ;; arg-sort-list: list of argument sorts | |
| 1614 | (method-prime method) ;initialization | |
| 1615 | (chaos-term nil) ;reservation | |
| 1616 | (precedence-level (get-method-precedence method)) | |
| 1617 | (token-list (cdr arg-acc)) | |
| 1618 | (terletox nil) ) ;reservation | |
| 1619 | (declare (type fixnum precedence-level)) | |
| 1620 | (when *on-parse-debug* | |
| 1621 | (format t "~& : method prime = ") | |
| 1622 | (print-chaos-object method-prime) | |
| 1623 | (force-output)) | |
| 1608 | (direct-arg-list (reverse arg-list)) | |
| 1609 | ;; arguments were accumulated in reverse order ! | |
| 1610 | (arg-sort-list (mapcar #'(lambda (x) (term-sort x)) direct-arg-list)) | |
| 1611 | ;; arg-sort-list: list of argument sorts | |
| 1612 | (method-prime method) ;initialization | |
| 1613 | (chaos-term nil) ;reservation | |
| 1614 | (precedence-level (get-method-precedence method)) | |
| 1615 | (token-list (cdr arg-acc)) | |
| 1616 | (terletox nil) ) ;reservation | |
| 1617 | (declare (type fixnum precedence-level)) | |
| 1618 | (when *on-parse-debug* | |
| 1619 | (format t "~% : method prime = ") | |
| 1620 | (print-chaos-object method-prime) | |
| 1621 | (force-output)) | |
| 1624 | 1622 | (if (are-argumentsorts-correct method arg-sort-list module) |
| 1625 | (progn | |
| 1626 | ;; ordinal term | |
| 1627 | (when (or (method-is-universal* method) | |
| 1628 | (method-is-error-method method)) | |
| 1629 | (setq method-prime | |
| 1630 | (lowest-method! method arg-sort-list)) | |
| 1631 | (when *on-parse-debug* | |
| 1632 | (format t "~& : arg sort list = ~a" arg-sort-list) | |
| 1633 | (format t "~& : lowest method = ") | |
| 1634 | (print-chaos-object method-prime) | |
| 1635 | (force-output)) | |
| 1636 | (unless method-prime | |
| 1637 | ;; then no result this iteration; do not accumulate: | |
| 1638 | (return-from iteration nil)) | |
| 1639 | ) | |
| 1640 | ;; | |
| 1641 | (setq chaos-term | |
| 1642 | (if (are-well-defined-terms direct-arg-list) | |
| 1643 | (parser-make-applform (method-coarity method-prime) | |
| 1644 | method-prime | |
| 1645 | direct-arg-list) | |
| 1646 | (make-inheritedly-ill-term | |
| 1647 | method-prime direct-arg-list))) | |
| 1648 | ;; check for _:is_, sortmembership predicate | |
| 1649 | #|| | |
| 1650 | (when (eq *sort-membership* method-prime) | |
| 1651 | (unless (test-sort-memb-predicate chaos-term) | |
| 1652 | (setq chaos-term | |
| 1653 | (make-directly-ill-term method-prime | |
| 1654 | direct-arg-list)))) | |
| 1655 | ||# | |
| 1656 | ) | |
| 1657 | ;; | |
| 1658 | ;; incorrect argument(s). | |
| 1659 | (progn | |
| 1660 | (when *on-parse-debug* | |
| 1661 | (format t "~&incorrenct args, meth= ") | |
| 1662 | (print-chaos-object method) | |
| 1663 | (print-chaos-object arg-sort-list)) | |
| 1664 | (setq chaos-term | |
| 1665 | (make-directly-ill-term method direct-arg-list)))) | |
| 1666 | ||
| 1667 | ;; accummlate possible parses. | |
| 1668 | ;; | |
| 1669 | (when chaos-term | |
| 1670 | (setq terletox (cons (cons chaos-term precedence-level) token-list) | |
| 1671 | terletox-list (cons terletox terletox-list))) | |
| 1672 | ;; | |
| 1673 | (when *on-parse-debug* | |
| 1674 | (format t "~& : chaos-term=") | |
| 1675 | (term-print chaos-term) | |
| 1676 | (format t "~& : terletox=") | |
| 1677 | (print-terletox terletox)) | |
| 1678 | )) ; block iteration | |
| 1679 | ) ; dolist | |
| 1623 | (progn | |
| 1624 | ;; ordinal term | |
| 1625 | (when (or (method-is-universal* method) | |
| 1626 | (method-is-error-method method)) | |
| 1627 | (setq method-prime | |
| 1628 | (lowest-method! method arg-sort-list)) | |
| 1629 | (when *on-parse-debug* | |
| 1630 | (format t "~% : arg sort list = ~a" arg-sort-list) | |
| 1631 | (format t "~& : lowest method = ") | |
| 1632 | (print-chaos-object method-prime) | |
| 1633 | (force-output)) | |
| 1634 | (unless method-prime | |
| 1635 | ;; then no result this iteration; do not accumulate: | |
| 1636 | (return-from iteration nil)) | |
| 1637 | ) | |
| 1638 | ;; | |
| 1639 | (setq chaos-term | |
| 1640 | (if (are-well-defined-terms direct-arg-list) | |
| 1641 | (parser-make-applform (method-coarity method-prime) | |
| 1642 | method-prime | |
| 1643 | direct-arg-list) | |
| 1644 | (make-inheritedly-ill-term | |
| 1645 | method-prime direct-arg-list))) | |
| 1646 | ;; check for _:is_, sortmembership predicate | |
| 1647 | #|| | |
| 1648 | (when (eq *sort-membership* method-prime) | |
| 1649 | (unless (test-sort-memb-predicate chaos-term) | |
| 1650 | (setq chaos-term | |
| 1651 | (make-directly-ill-term method-prime | |
| 1652 | direct-arg-list)))) | |
| 1653 | ||# | |
| 1654 | ) | |
| 1655 | ;; | |
| 1656 | ;; incorrect argument(s). | |
| 1657 | (progn | |
| 1658 | (when *on-parse-debug* | |
| 1659 | (format t "~%incorrenct args, meth= ") | |
| 1660 | (print-chaos-object method) | |
| 1661 | (print-chaos-object arg-sort-list)) | |
| 1662 | (setq chaos-term | |
| 1663 | (make-directly-ill-term method direct-arg-list)))) | |
| 1664 | ||
| 1665 | ;; accummlate possible parses. | |
| 1666 | ;; | |
| 1667 | (when chaos-term | |
| 1668 | (setq terletox (cons (cons chaos-term precedence-level) token-list) | |
| 1669 | terletox-list (cons terletox terletox-list))) | |
| 1670 | ;; | |
| 1671 | (when *on-parse-debug* | |
| 1672 | (format t "~% : chaos-term=") | |
| 1673 | (term-print chaos-term) | |
| 1674 | (format t "~& : terletox=") | |
| 1675 | (print-terletox terletox)) | |
| 1676 | )) ; block iteration | |
| 1677 | ) ; dolist | |
| 1680 | 1678 | (when *on-parse-debug* |
| 1681 | (format t "~& : result = ") | |
| 1679 | (format t "~% : result = ") | |
| 1682 | 1680 | (print-terletox-list terletox-list)) |
| 1683 | 1681 | terletox-list)) |
| 1684 | 1682 | |
| 1685 | (defun test-sort-memb-predicate (term &optional (module (or *current-module* | |
| 1686 | *last-module*))) | |
| 1687 | (unless module | |
| 1688 | (with-output-chaos-error ('no-context) | |
| 1689 | (princ "checking _:_, no context module is given!"))) | |
| 1683 | (defun test-sort-memb-predicate (term &optional (module (get-context-module))) | |
| 1690 | 1684 | (with-in-module (module) |
| 1691 | 1685 | (let ((arg1 (term-arg-1 term)) |
| 1692 | (id-const (term-arg-2 term))) | |
| 1693 | ;; (format t "~&arg1 = ")(print arg1) | |
| 1694 | ;; (format t "~&id-const = ") (print id-const) | |
| 1686 | (id-const (term-arg-2 term))) | |
| 1695 | 1687 | (let ((sorts (gather-sorts-with-id id-const module)) |
| 1696 | (term-sort (term-sort arg1))) | |
| 1697 | (unless sorts | |
| 1698 | (with-output-chaos-error ('no-sort) | |
| 1699 | (format t "_:_, no such sort ~a in the current context." | |
| 1700 | (get-sort-id-value id-const)))) | |
| 1701 | (if (some #'(lambda (x) | |
| 1702 | (parser-in-same-connected-component x | |
| 1703 | term-sort | |
| 1704 | *current-sort-order*)) | |
| 1705 | sorts) | |
| 1706 | t | |
| 1707 | nil))))) | |
| 1688 | (term-sort (term-sort arg1))) | |
| 1689 | (unless sorts | |
| 1690 | (with-output-chaos-error ('no-sort) | |
| 1691 | (format t "_:_, no such sort ~a in the current context." | |
| 1692 | (get-sort-id-value id-const)))) | |
| 1693 | (if (some #'(lambda (x) | |
| 1694 | (parser-in-same-connected-component x | |
| 1695 | term-sort | |
| 1696 | *current-sort-order*)) | |
| 1697 | sorts) | |
| 1698 | t | |
| 1699 | nil))))) | |
| 1708 | 1700 | |
| 1709 | 1701 | (defun print-terletox (x) |
| 1710 | (format t "~&term = ") | |
| 1702 | (format t "~%terletox: term = ") | |
| 1711 | 1703 | (term-print (caar x) t t) |
| 1712 | 1704 | ;; (print-chaos-object (caar x)) |
| 1713 | 1705 | (format t ", prec=~d" (cdar x)) |
| 1741 | 1733 | |
| 1742 | 1734 | (defun parser-make-applform (sort method arg-list) |
| 1743 | 1735 | (declare (type sort* sort) |
| 1744 | (type method method) | |
| 1745 | (type list arg-list)) | |
| 1736 | (type method method) | |
| 1737 | (type list arg-list)) | |
| 1746 | 1738 | (macrolet ((not-lowest-p-fast (sort) |
| 1747 | `(or (eq ,sort *universal-sort*) | |
| 1748 | (eq ,sort *huniversal-sort*) | |
| 1749 | (eq ,sort *cosmos-sort*) | |
| 1750 | (eq (sort-type ,sort) '%err-sort)))) | |
| 1739 | `(or (eq ,sort *universal-sort*) | |
| 1740 | (eq ,sort *huniversal-sort*) | |
| 1741 | (eq ,sort *cosmos-sort*) | |
| 1742 | (eq (sort-type ,sort) '%err-sort)))) | |
| 1751 | 1743 | (flet ((make-form (sort method arg-list) |
| 1752 | (make-applform sort method arg-list))) | |
| 1744 | (make-applform sort method arg-list))) | |
| 1753 | 1745 | (let ((result nil)) |
| 1754 | (if *fill-rc-attribute* | |
| 1755 | (let ((attrpos nil) | |
| 1756 | (class nil)) | |
| 1757 | (if (method-is-object-constructor method) | |
| 1758 | (progn (setf attrpos 2) (setf class t)) | |
| 1759 | (when (method-is-record-constructor method) | |
| 1760 | (setf attrpos 1))) | |
| 1761 | (if attrpos | |
| 1762 | (let ((attrs (nth attrpos arg-list)) | |
| 1763 | (cr-sort (method-coarity method))) | |
| 1764 | (when class | |
| 1765 | (replace-class-id-with-var cr-sort arg-list)) | |
| 1766 | (if attrs | |
| 1767 | (cond ((sort= (term-sort attrs) *attribute-list-sort*) | |
| 1768 | (let* ((attr-method (term-head attrs)) | |
| 1769 | (sv-pairs (list-ac-subterms attrs | |
| 1770 | attr-method)) | |
| 1771 | (flg nil)) | |
| 1772 | (dolist (sv-pair sv-pairs) | |
| 1773 | (block next | |
| 1774 | (when (sort= (term-sort sv-pair) | |
| 1775 | *attribute-list-sort*) | |
| 1776 | (setf flg t) | |
| 1777 | (return-from next nil)) | |
| 1778 | ;; normal sv-pair | |
| 1779 | (replace-attr-id-with-var cr-sort sv-pair))) | |
| 1780 | (unless flg | |
| 1781 | (when (or *parsing-axiom-lhs* | |
| 1782 | *parse-lhs-attr-vars*) | |
| 1783 | ;; (break "1") | |
| 1784 | (setq *parse-lhs-attr-vars* t) | |
| 1785 | (setf (nth attrpos arg-list) | |
| 1786 | (make-right-assoc-normal-form | |
| 1787 | attr-method | |
| 1788 | (nconc sv-pairs | |
| 1789 | (list | |
| 1790 | *attribute-list-aux-variable*)))))) | |
| 1791 | (setq result (make-form sort method arg-list)) | |
| 1792 | result)) | |
| 1793 | (t ;; single sv-pair & not list of attribure. | |
| 1794 | (replace-attr-id-with-var cr-sort attrs) | |
| 1795 | (when (or *parsing-axiom-lhs* | |
| 1796 | *parse-lhs-attr-vars*) | |
| 1797 | ;; (break "2") | |
| 1798 | (setq *parse-lhs-attr-vars* t) | |
| 1799 | (setf (nth attrpos arg-list) | |
| 1800 | (make-applform | |
| 1801 | *attribute-list-sort* | |
| 1802 | *attribute-list-constructor* | |
| 1803 | (list attrs | |
| 1804 | *attribute-list-aux-variable*)))) | |
| 1805 | (setq result (make-form sort method arg-list)) | |
| 1806 | result)) | |
| 1807 | ;; no attributes | |
| 1808 | (progn | |
| 1809 | (setq result (make-form sort method arg-list)) | |
| 1810 | ))) | |
| 1811 | (progn | |
| 1812 | (setq result (make-form sort method arg-list)) | |
| 1813 | ))) | |
| 1814 | ;; normal term | |
| 1815 | (setq result (make-form sort method arg-list))) | |
| 1816 | ;; special treatment of if_then_else_fi | |
| 1817 | ;; special treatment of generic operators | |
| 1818 | (when (eq (term-head result) *bool-if*) | |
| 1819 | (set-if-then-else-sort result)) | |
| 1820 | result)))) | |
| 1746 | (if *fill-rc-attribute* | |
| 1747 | (let ((attrpos nil) | |
| 1748 | (class nil)) | |
| 1749 | (if (method-is-object-constructor method) | |
| 1750 | (progn (setf attrpos 2) (setf class t)) | |
| 1751 | (when (method-is-record-constructor method) | |
| 1752 | (setf attrpos 1))) | |
| 1753 | (if attrpos | |
| 1754 | (let ((attrs (nth attrpos arg-list)) | |
| 1755 | (cr-sort (method-coarity method))) | |
| 1756 | (when class | |
| 1757 | (replace-class-id-with-var cr-sort arg-list)) | |
| 1758 | (if attrs | |
| 1759 | (cond ((sort= (term-sort attrs) *attribute-list-sort*) | |
| 1760 | (let* ((attr-method (term-head attrs)) | |
| 1761 | (sv-pairs (list-ac-subterms attrs | |
| 1762 | attr-method)) | |
| 1763 | (flg nil)) | |
| 1764 | (dolist (sv-pair sv-pairs) | |
| 1765 | (block next | |
| 1766 | (when (sort= (term-sort sv-pair) | |
| 1767 | *attribute-list-sort*) | |
| 1768 | (setf flg t) | |
| 1769 | (return-from next nil)) | |
| 1770 | ;; normal sv-pair | |
| 1771 | (replace-attr-id-with-var cr-sort sv-pair))) | |
| 1772 | (unless flg | |
| 1773 | (when (or *parsing-axiom-lhs* | |
| 1774 | *parse-lhs-attr-vars*) | |
| 1775 | ;; (break "1") | |
| 1776 | (setq *parse-lhs-attr-vars* t) | |
| 1777 | (setf (nth attrpos arg-list) | |
| 1778 | (make-right-assoc-normal-form | |
| 1779 | attr-method | |
| 1780 | (nconc sv-pairs | |
| 1781 | (list | |
| 1782 | *attribute-list-aux-variable*)))))) | |
| 1783 | (setq result (make-form sort method arg-list)) | |
| 1784 | result)) | |
| 1785 | (t ;; single sv-pair & not list of attribure. | |
| 1786 | (replace-attr-id-with-var cr-sort attrs) | |
| 1787 | (when (or *parsing-axiom-lhs* | |
| 1788 | *parse-lhs-attr-vars*) | |
| 1789 | ;; (break "2") | |
| 1790 | (setq *parse-lhs-attr-vars* t) | |
| 1791 | (setf (nth attrpos arg-list) | |
| 1792 | (make-applform | |
| 1793 | *attribute-list-sort* | |
| 1794 | *attribute-list-constructor* | |
| 1795 | (list attrs | |
| 1796 | *attribute-list-aux-variable*)))) | |
| 1797 | (setq result (make-form sort method arg-list)) | |
| 1798 | result)) | |
| 1799 | ;; no attributes | |
| 1800 | (progn | |
| 1801 | (setq result (make-form sort method arg-list)) | |
| 1802 | ))) | |
| 1803 | (progn | |
| 1804 | (setq result (make-form sort method arg-list)) | |
| 1805 | ))) | |
| 1806 | ;; normal term | |
| 1807 | (setq result (make-form sort method arg-list))) | |
| 1808 | ;; special treatment of if_then_else_fi | |
| 1809 | ;; special treatment of generic operators | |
| 1810 | (when (eq (term-head result) *bool-if*) | |
| 1811 | (set-if-then-else-sort result)) | |
| 1812 | result)))) | |
| 1821 | 1813 | |
| 1822 | 1814 | (defun replace-class-id-with-var (cr-sort arg-list) |
| 1823 | 1815 | (declare (type sort* cr-sort) |
| 1824 | (type list arg-list)) | |
| 1816 | (type list arg-list)) | |
| 1825 | 1817 | (let ((class-id (second arg-list)) |
| 1826 | (id-var nil)) | |
| 1818 | (id-var nil)) | |
| 1827 | 1819 | (unless (term-is-variable? class-id) |
| 1828 | 1820 | (setf id-var (crsort-id-variable cr-sort)) |
| 1829 | 1821 | (unless id-var |
| 1830 | (with-output-panic-message () | |
| 1831 | (format t "could not find Class id variable for class ~s" | |
| 1832 | (sort-id cr-sort)) | |
| 1833 | ;; (break) | |
| 1834 | (chaos-error 'panic))) | |
| 1822 | (with-output-panic-message () | |
| 1823 | (format t "could not find Class id variable for class ~s" | |
| 1824 | (sort-id cr-sort)) | |
| 1825 | ;; (break) | |
| 1826 | (chaos-error 'panic))) | |
| 1835 | 1827 | (if *parsing-axiom-lhs* |
| 1836 | (pushnew id-var *lhs-attrid-vars*) | |
| 1837 | (unless (memq id-var *lhs-attrid-vars*) | |
| 1838 | (return-from replace-class-id-with-var nil))) | |
| 1828 | (pushnew id-var *lhs-attrid-vars*) | |
| 1829 | (unless (memq id-var *lhs-attrid-vars*) | |
| 1830 | (return-from replace-class-id-with-var nil))) | |
| 1839 | 1831 | ;; |
| 1840 | 1832 | (setf (second arg-list) id-var)) |
| 1841 | 1833 | arg-list)) |
| 1842 | 1834 | |
| 1843 | 1835 | (defun replace-attr-id-with-var (cr-sort sv-pair) |
| 1844 | 1836 | (declare (type sort* cr-sort) |
| 1845 | (type term sv-pair)) | |
| 1837 | (type term sv-pair)) | |
| 1846 | 1838 | (let ((attr-id (term-arg-1 sv-pair)) |
| 1847 | id-var) | |
| 1839 | id-var) | |
| 1848 | 1840 | (unless (term-is-variable? attr-id) |
| 1849 | 1841 | (setf id-var (get-attribute-id-variable |
| 1850 | (car (method-symbol (term-method attr-id))) | |
| 1851 | cr-sort)) | |
| 1842 | (car (method-symbol (term-method attr-id))) | |
| 1843 | cr-sort)) | |
| 1852 | 1844 | (unless id-var |
| 1853 | (with-output-panic-message () | |
| 1854 | (format t "could not find id variable for slot ~a of sort ~a" | |
| 1855 | (car (method-symbol (term-method attr-id))) | |
| 1856 | (sort-id cr-sort)) | |
| 1857 | (print-next) | |
| 1858 | (princ "id term = ") | |
| 1859 | (term-print attr-id) | |
| 1860 | (print-next) | |
| 1861 | (princ " sv pair = ") | |
| 1862 | (print-chaos-object sv-pair) | |
| 1863 | ;; (break) | |
| 1864 | (chaos-error 'panic) | |
| 1865 | )) | |
| 1845 | (with-output-panic-message () | |
| 1846 | (format t "could not find id variable for slot ~a of sort ~a" | |
| 1847 | (car (method-symbol (term-method attr-id))) | |
| 1848 | (sort-id cr-sort)) | |
| 1849 | (print-next) | |
| 1850 | (princ "id term = ") | |
| 1851 | (term-print attr-id) | |
| 1852 | (print-next) | |
| 1853 | (princ " sv pair = ") | |
| 1854 | (print-chaos-object sv-pair) | |
| 1855 | ;; (break) | |
| 1856 | (chaos-error 'panic) | |
| 1857 | )) | |
| 1866 | 1858 | (if *parsing-axiom-lhs* |
| 1867 | (pushnew id-var *lhs-attrid-vars*) | |
| 1868 | (unless (memq id-var *lhs-attrid-vars*) | |
| 1869 | (return-from replace-attr-id-with-var nil))) | |
| 1859 | (pushnew id-var *lhs-attrid-vars*) | |
| 1860 | (unless (memq id-var *lhs-attrid-vars*) | |
| 1861 | (return-from replace-attr-id-with-var nil))) | |
| 1870 | 1862 | ;; |
| 1871 | 1863 | (setf (term-arg-1 sv-pair) id-var)) |
| 1872 | 1864 | sv-pair)) |
| 1896 | 1888 | ;;; !!! to optimize !!! |
| 1897 | 1889 | (defun are-argumentsorts-correct (method sort-list module) |
| 1898 | 1890 | (declare (type method method) |
| 1899 | (type list sort-list) | |
| 1900 | (type module module)) | |
| 1891 | (type list sort-list) | |
| 1892 | (type module module)) | |
| 1901 | 1893 | (if (null sort-list) |
| 1902 | 1894 | t |
| 1903 | 1895 | (if (check-universally-defined-builtins method sort-list module) |
| 1904 | (let* ((reference-sort-list (method-arity method)) | |
| 1905 | (sort-order (module-sort-order module)) | |
| 1906 | (result t) | |
| 1907 | (sort-list-prime sort-list) | |
| 1908 | (sort nil)) | |
| 1909 | (dolist (reference-sort reference-sort-list result) | |
| 1910 | (setq sort (car sort-list-prime) | |
| 1911 | sort-list-prime (cdr sort-list-prime)) ;for next iteration | |
| 1912 | (if (or (sort= reference-sort *universal-sort*) | |
| 1913 | (sort= reference-sort *huniversal-sort*) | |
| 1914 | (sort= reference-sort *cosmos*) | |
| 1915 | (err-sort-p reference-sort) | |
| 1916 | (sort<= sort reference-sort sort-order)) | |
| 1917 | ;;then do nothing; go to next iteration: | |
| 1918 | nil | |
| 1919 | ;; else abort looping; return false: | |
| 1920 | (progn | |
| 1921 | (when *on-parse-debug* | |
| 1922 | (format t "~&incorrect argument sort ~a" (sort-id sort))) | |
| 1923 | (return nil))))) | |
| 1896 | (let* ((reference-sort-list (method-arity method)) | |
| 1897 | (sort-order (module-sort-order module)) | |
| 1898 | (result t) | |
| 1899 | (sort-list-prime sort-list) | |
| 1900 | (sort nil)) | |
| 1901 | (dolist (reference-sort reference-sort-list result) | |
| 1902 | (setq sort (car sort-list-prime) | |
| 1903 | sort-list-prime (cdr sort-list-prime)) ;for next iteration | |
| 1904 | (if (or (sort= reference-sort *universal-sort*) | |
| 1905 | (sort= reference-sort *huniversal-sort*) | |
| 1906 | (sort= reference-sort *cosmos*) | |
| 1907 | (err-sort-p reference-sort) | |
| 1908 | (sort<= sort reference-sort sort-order)) | |
| 1909 | ;;then do nothing; go to next iteration: | |
| 1910 | nil | |
| 1911 | ;; else abort looping; return false: | |
| 1912 | (progn | |
| 1913 | (when *on-parse-debug* | |
| 1914 | (format t "~%incorrect argument sort ~a" (sort-id sort))) | |
| 1915 | (return nil))))) | |
| 1924 | 1916 | nil))) |
| 1925 | 1917 | |
| 1926 | 1918 | (defun arity-contains-universal-sort (method) |
| 1927 | 1919 | (if (cdr (method-arity method)) |
| 1928 | 1920 | (and (or (eq method *bool-if*) |
| 1929 | (dolist (s (method-arity method) t) | |
| 1930 | (unless (or (eq s *cosmos*) | |
| 1931 | (eq s *universal-sort*) | |
| 1932 | (eq s *huniversal-sort*)) | |
| 1933 | (return-from arity-contains-universal-sort nil)))) | |
| 1934 | ;;(every #'(lambda (x y) (eq x y)) (method-arity method)) | |
| 1935 | ) | |
| 1921 | (dolist (s (method-arity method) t) | |
| 1922 | (unless (or (eq s *cosmos*) | |
| 1923 | (eq s *universal-sort*) | |
| 1924 | (eq s *huniversal-sort*)) | |
| 1925 | (return-from arity-contains-universal-sort nil)))) | |
| 1926 | ;;(every #'(lambda (x y) (eq x y)) (method-arity method)) | |
| 1927 | ) | |
| 1936 | 1928 | nil)) |
| 1937 | 1929 | |
| 1938 | 1930 | (defun check-universally-defined-builtins (method sort-list module) |
| 1939 | 1931 | (let ((so (module-sort-order module))) |
| 1940 | 1932 | (if ;; (memq method *bi-universal-operators*) |
| 1941 | (arity-contains-universal-sort method) | |
| 1942 | (cond ((eq method *bool-if*) | |
| 1943 | ;; if_then_else_fi | |
| 1944 | (parser-in-same-connected-component (second sort-list) | |
| 1945 | (third sort-list) | |
| 1946 | so)) | |
| 1947 | #|| | |
| 1948 | ((eq method *rwl-predicate2*) | |
| 1949 | ;; _=()=>_ | |
| 1950 | (parser-in-same-connected-component (first sort-list) | |
| 1951 | (third sort-list) | |
| 1952 | so)) | |
| 1953 | ||# | |
| 1954 | ((eq method *sort-membership*) | |
| 1955 | ;; _:is_, the first argument is a term and the second | |
| 1956 | ;; argument is built-in constant of SortId. | |
| 1957 | ;; thus, anyhing is OK. | |
| 1958 | t) | |
| 1959 | (t | |
| 1960 | ;; other binary universal operators | |
| 1961 | (parser-in-same-connected-component (first sort-list) | |
| 1962 | (second sort-list) | |
| 1963 | so))) | |
| 1964 | t))) | |
| 1933 | (arity-contains-universal-sort method) | |
| 1934 | (cond ((eq method *bool-if*) | |
| 1935 | ;; if_then_else_fi | |
| 1936 | (parser-in-same-connected-component (second sort-list) | |
| 1937 | (third sort-list) | |
| 1938 | so)) | |
| 1939 | #|| | |
| 1940 | ((eq method *rwl-predicate2*) | |
| 1941 | ;; _=()=>_ | |
| 1942 | (parser-in-same-connected-component (first sort-list) | |
| 1943 | (third sort-list) | |
| 1944 | so)) | |
| 1945 | ||# | |
| 1946 | ((eq method *sort-membership*) | |
| 1947 | ;; _:is_, the first argument is a term and the second | |
| 1948 | ;; argument is built-in constant of SortId. | |
| 1949 | ;; thus, anyhing is OK. | |
| 1950 | t) | |
| 1951 | (t | |
| 1952 | ;; other binary universal operators | |
| 1953 | (parser-in-same-connected-component (first sort-list) | |
| 1954 | (second sort-list) | |
| 1955 | so))) | |
| 1956 | t))) | |
| 1965 | 1957 | |
| 1966 | 1958 | ;;; op are-well-defined-terms : |
| 1967 | 1959 | ;;; LIST[ ChaosTerm ] -- possibly empty |
| 1974 | 1966 | (let ((result t)) |
| 1975 | 1967 | (dolist (chaos-term chaos-term-list result) |
| 1976 | 1968 | (if (term-ill-defined chaos-term) |
| 1977 | ;; abort looping and return false | |
| 1978 | (return nil))))) | |
| 1969 | ;; abort looping and return false | |
| 1970 | (return nil))))) | |
| 1979 | 1971 | |
| 1980 | 1972 | |
| 1981 | 1973 | ;;; EOF |
| 0 | 0 | ;;-*-Mode:LISP; Package: CHAOS; Base:10; Syntax:Common-lisp -*- |
| 1 | 1 | ;;; |
| 2 | ;;; Copyright (c) 2000-2014, Toshimi Sawada. All rights reserved. | |
| 2 | ;;; Copyright (c) 2000-2015, Toshimi Sawada. All rights reserved. | |
| 3 | 3 | ;;; |
| 4 | 4 | ;;; Redistribution and use in source and binary forms, with or without |
| 5 | 5 | ;;; modification, are permitted provided that the following conditions |
| 27 | 27 | ;;; |
| 28 | 28 | (in-package :chaos) |
| 29 | 29 | #|============================================================================== |
| 30 | System:Chaos | |
| 31 | Module:term-parser.chaos | |
| 32 | File: parse-macro.lisp | |
| 30 | System:Chaos | |
| 31 | Module:term-parser.chaos | |
| 32 | File: parse-macro.lisp | |
| 33 | 33 | ==============================================================================|# |
| 34 | 34 | #-:chaos-debug |
| 35 | 35 | (declaim (optimize (speed 3) (safety 0) #-GCL (debug 0))) |
| 45 | 45 | |
| 46 | 46 | (defun setup-macro-rule (macro module) |
| 47 | 47 | (add-macro-to-method macro |
| 48 | (term-head (macro-lhs macro)) | |
| 49 | (module-opinfo-table module))) | |
| 48 | (term-head (macro-lhs macro)) | |
| 49 | (module-opinfo-table module))) | |
| 50 | 50 | |
| 51 | 51 | (defun add-macro-to-method (macro method |
| 52 | &optional (opinfo-table *current-opinfo-table*)) | |
| 52 | &optional (opinfo-table *current-opinfo-table*)) | |
| 53 | 53 | (setf (method-macros method opinfo-table) |
| 54 | 54 | (adjoin-macro macro (method-macros method opinfo-table)))) |
| 55 | 55 | |
| 56 | 56 | (defun adjoin-macro (macro ms) |
| 57 | 57 | (do* ((lst ms (cdr lst)) |
| 58 | (r (car lst) (car lst))) | |
| 58 | (r (car lst) (car lst))) | |
| 59 | 59 | ((null lst) (cons macro ms)) |
| 60 | 60 | (when (macro-is-similar? macro r) |
| 61 | 61 | (let ((newlhs (macro-lhs macro)) |
| 62 | (oldlhs (macro-lhs r))) | |
| 63 | (when (and (not (term-is-variable? newlhs)) | |
| 64 | (not (term-is-variable? oldlhs)) | |
| 65 | (not (method= (term-method newlhs) (term-method oldlhs))) | |
| 66 | (sort<= (term-sort oldlhs) (term-sort newlhs))) | |
| 67 | (rplaca lst r)) | |
| 68 | (return-from adjoin-macro ms))))) | |
| 62 | (oldlhs (macro-lhs r))) | |
| 63 | (when (and (not (term-is-variable? newlhs)) | |
| 64 | (not (term-is-variable? oldlhs)) | |
| 65 | (not (method= (term-method newlhs) (term-method oldlhs))) | |
| 66 | (sort<= (term-sort oldlhs) (term-sort newlhs))) | |
| 67 | (rplaca lst r)) | |
| 68 | (return-from adjoin-macro ms))))) | |
| 69 | 69 | |
| 70 | 70 | (defun macro-is-similar? (macro1 macro2) |
| 71 | 71 | (and (term-is-congruent-2? (macro-lhs macro1) |
| 72 | (macro-lhs macro2)) | |
| 72 | (macro-lhs macro2)) | |
| 73 | 73 | (term-is-congruent-2? (macro-rhs macro1) |
| 74 | (macro-rhs macro2)))) | |
| 74 | (macro-rhs macro2)))) | |
| 75 | 75 | |
| 76 | (defun expand-macro (term &optional (module (or *current-module* | |
| 77 | *last-module*))) | |
| 76 | (defun expand-macro (term &optional (module (get-context-module))) | |
| 78 | 77 | (labels ((apply-macro-rule (macro term) |
| 79 | (block the-end | |
| 80 | (multiple-value-bind (global-state subst no-match E-equal) | |
| 81 | (first-match (macro-lhs macro) term) | |
| 82 | (declare (ignore global-state e-equal)) | |
| 83 | (when no-match (return-from the-end nil)) | |
| 84 | (catch 'rule-failure | |
| 85 | (term-replace term | |
| 86 | (substitute-image subst | |
| 87 | (macro-rhs macro))) | |
| 88 | (return-from the-end term)) | |
| 89 | nil))) | |
| 90 | ;; | |
| 91 | (substitute-image (sigma term) | |
| 92 | (declare (type list sigma) | |
| 93 | (type term)) | |
| 94 | (cond ((term-is-variable? term) | |
| 95 | (let ((im (variable-image sigma term))) | |
| 96 | (if im | |
| 97 | im | |
| 98 | term))) | |
| 99 | ((term-is-builtin-constant? term) term) | |
| 100 | ((term-is-lisp-form? term) | |
| 101 | (multiple-value-bind (new success) | |
| 102 | (funcall (lisp-form-function term) sigma) | |
| 103 | (if success | |
| 104 | new | |
| 105 | (throw 'rule-failure nil)))) | |
| 106 | ((term-is-applform? term) | |
| 107 | (let ((l-result nil)) | |
| 108 | (dolist (s-t (term-subterms term)) | |
| 109 | (push (substitute-image sigma s-t) l-result)) | |
| 110 | (make-term-with-sort-check (term-head term) | |
| 111 | (nreverse l-result)))) | |
| 112 | ))) | |
| 78 | (block the-end | |
| 79 | (multiple-value-bind (global-state subst no-match E-equal) | |
| 80 | (first-match (macro-lhs macro) term) | |
| 81 | (declare (ignore global-state e-equal)) | |
| 82 | (when no-match (return-from the-end nil)) | |
| 83 | (catch 'rule-failure | |
| 84 | (term-replace term | |
| 85 | (substitute-image subst | |
| 86 | (macro-rhs macro))) | |
| 87 | (return-from the-end term)) | |
| 88 | nil))) | |
| 89 | ;; | |
| 90 | (substitute-image (sigma term) | |
| 91 | (declare (type list sigma) | |
| 92 | (type term)) | |
| 93 | (cond ((term-is-variable? term) | |
| 94 | (let ((im (variable-image sigma term))) | |
| 95 | (if im | |
| 96 | im | |
| 97 | term))) | |
| 98 | ((term-is-builtin-constant? term) term) | |
| 99 | ((term-is-lisp-form? term) | |
| 100 | (multiple-value-bind (new success) | |
| 101 | (funcall (lisp-form-function term) sigma) | |
| 102 | (if success | |
| 103 | new | |
| 104 | (throw 'rule-failure nil)))) | |
| 105 | ((term-is-applform? term) | |
| 106 | (let ((l-result nil)) | |
| 107 | (dolist (s-t (term-subterms term)) | |
| 108 | (push (substitute-image sigma s-t) l-result)) | |
| 109 | (make-term-with-sort-check (term-head term) | |
| 110 | (nreverse l-result)))) | |
| 111 | ))) | |
| 113 | 112 | ;; |
| 114 | 113 | (unless (term-is-application-form? term) |
| 115 | 114 | (return-from expand-macro term)) |
| 116 | 115 | ;; |
| 117 | 116 | (with-in-module (module) |
| 118 | 117 | (let ((*debug-macro-nest* (1+ *debug-marco-nest*))) |
| 119 | (when *debug-macro* | |
| 120 | (format t "~%~D>[expand-macro]: " *debug-macro-nest*) | |
| 121 | (term-print term)) | |
| 122 | (dolist (sub (term-subterms term)) | |
| 123 | (expand-macro sub module)) | |
| 124 | (update-lowest-parse term) | |
| 125 | (let ((top (term-head term))) | |
| 126 | (if (block the-end | |
| 127 | (dolist (rule (method-macros top)) | |
| 128 | (if (apply-macro-rule rule term) | |
| 129 | (return-from the-end t)))) | |
| 130 | (expand-macro term module)) | |
| 131 | (update-lowest-parse term) | |
| 132 | (when *debug-macro* | |
| 133 | (format t "~%<~D " *debug-macro-nest*) | |
| 134 | (term-print term)) | |
| 135 | term) | |
| 136 | )))) | |
| 118 | (when *debug-macro* | |
| 119 | (format t "~%~D>[expand-macro]: " *debug-macro-nest*) | |
| 120 | (term-print term)) | |
| 121 | (dolist (sub (term-subterms term)) | |
| 122 | (expand-macro sub module)) | |
| 123 | (update-lowest-parse term) | |
| 124 | (let ((top (term-head term))) | |
| 125 | (if (block the-end | |
| 126 | (dolist (rule (method-macros top)) | |
| 127 | (if (apply-macro-rule rule term) | |
| 128 | (return-from the-end t)))) | |
| 129 | (expand-macro term module)) | |
| 130 | (update-lowest-parse term) | |
| 131 | (when *debug-macro* | |
| 132 | (format t "~%<~D " *debug-macro-nest*) | |
| 133 | (term-print term)) | |
| 134 | term) | |
| 135 | )))) | |
| 137 | 136 | |
| 138 | 137 | ;;; EOF |
| 0 | 0 | ;;;-*-Mode:LISP; Package: CHAOS; Base:10; Syntax:Common-lisp -*- |
| 1 | 1 | ;;; |
| 2 | ;;; Copyright (c) 2000-2014, Toshimi Sawada. All rights reserved. | |
| 2 | ;;; Copyright (c) 2000-2015, Toshimi Sawada. All rights reserved. | |
| 3 | 3 | ;;; |
| 4 | 4 | ;;; Redistribution and use in source and binary forms, with or without |
| 5 | 5 | ;;; modification, are permitted provided that the following conditions |
| 27 | 27 | ;;; |
| 28 | 28 | (in-package :chaos) |
| 29 | 29 | #|============================================================================== |
| 30 | System:Chaos | |
| 31 | Module:term-parser.chaos | |
| 32 | File: parse-engine.lisp | |
| 30 | System:Chaos | |
| 31 | Module:term-parser.chaos | |
| 32 | File: parse-engine.lisp | |
| 33 | 33 | ==============================================================================|# |
| 34 | 34 | #-:chaos-debug |
| 35 | 35 | (declaim (optimize (speed 3) (safety 0) #-GCL (debug 0))) |
| 36 | 36 | #+:chaos-debug |
| 37 | 37 | (declaim (optimize (speed 1) (safety 3) #-GCL (debug 3))) |
| 38 | 38 | |
| 39 | ;;; SIMPLE PARSER TOP LEVEL ROUTINES | |
| 39 | ;;; SIMPLE PARSER TOP LEVEL ROUTINES | |
| 40 | 40 | |
| 41 | 41 | (defun simple-parse-from-string (string &optional |
| 42 | (module *current-module*) | |
| 43 | (sort *cosmos*)) | |
| 42 | (module *current-module*) | |
| 43 | (sort *cosmos*)) | |
| 44 | 44 | (declare ;; (type simple-string string) |
| 45 | (type module module) | |
| 46 | (type sort* sort)) | |
| 45 | (type module module) | |
| 46 | (type sort* sort)) | |
| 47 | 47 | (with-in-module (module) |
| 48 | 48 | (setf string (read-term-from-string string)) |
| 49 | 49 | ;; (prepare-for-parsing module) |
| 51 | 51 | (simple-parse module string sort)))) |
| 52 | 52 | |
| 53 | 53 | (defun simple-parse-from-string* (string &optional |
| 54 | (module *current-module*) | |
| 55 | (sort *cosmos*)) | |
| 54 | (module *current-module*) | |
| 55 | (sort *cosmos*)) | |
| 56 | 56 | ;; (prepare-for-parsing module) |
| 57 | 57 | (simple-parse module string sort)) |
| 58 | 58 | |
| 60 | 60 | |
| 61 | 61 | (defvar .saved-ambiguous. nil) |
| 62 | 62 | |
| 63 | ;;; ** NOTE : MUST BE CALLED in `with-in-module' | |
| 63 | ;;; SIMPLE-PARSE : module list-of-tokens &optional sort-constraint -> term | |
| 64 | 64 | ;;; |
| 65 | 65 | (defun simple-parse (module preterm &optional (sort *cosmos*)) |
| 66 | 66 | (declare (type module module) |
| 67 | (type (or string list) preterm) | |
| 68 | (type sort* sort)) | |
| 67 | (type (or string list) preterm) | |
| 68 | (type sort* sort)) | |
| 69 | 69 | (with-in-module (module) |
| 70 | 70 | (when (stringp preterm) |
| 71 | 71 | (setf preterm (read-term-from-string preterm))) |
| 72 | 72 | (if (null preterm) |
| 73 | (progn | |
| 74 | (with-output-simple-msg () | |
| 75 | (princ "[Error] empty input, no parse.")) | |
| 76 | (make-bconst-term *syntax-err-sort* '(the input is empty))) | |
| 73 | (progn | |
| 74 | (with-output-simple-msg () | |
| 75 | (princ "[Error] empty input, no parse.")) | |
| 76 | (make-bconst-term *syntax-err-sort* '(the input is empty))) | |
| 77 | 77 | (let ((res nil)) |
| 78 | (setq res (catch :parse-error | |
| 79 | (parse-term preterm module parser-max-precedence sort))) | |
| 80 | (when *on-parse-debug* | |
| 81 | (format t "~&simple-parse, preterm= ~s, parsed term = " preterm) | |
| 82 | (print-terletox-list res)) | |
| 83 | (let* ((final-well-defined (mapcan #'(lambda (e) | |
| 84 | (when (and (null (cdr e)) | |
| 85 | (not (term-ill-defined | |
| 86 | (caar e)))) | |
| 87 | (list (caar e)))) | |
| 88 | res)) | |
| 89 | (final (if final-well-defined | |
| 90 | final-well-defined | |
| 91 | (mapcan #'(lambda (e) | |
| 92 | (unless (cdr e) | |
| 93 | (list (caar e)))) | |
| 94 | res))) | |
| 95 | (partial (if final | |
| 96 | nil | |
| 97 | (let ((len 0) | |
| 98 | (val nil)) | |
| 99 | (dolist (e res val) | |
| 100 | (if (< len (length (the list (cdr e)))) | |
| 101 | (setf val (cons (caar e) (cdr e)))))))) | |
| 102 | (result nil)) | |
| 103 | ;; | |
| 104 | (cond (partial (setf result | |
| 105 | (make-applform *syntax-err-sort* | |
| 106 | *partial-method* | |
| 107 | (list (car partial) | |
| 108 | (make-bconst-term *universal-sort* | |
| 109 | (cdr partial)))))) | |
| 110 | (final (if (term-ill-defined (car final)) | |
| 111 | (setf result (car final)) | |
| 112 | (setf result | |
| 113 | (if (null (cdr final)) | |
| 114 | (car final) | |
| 115 | (select-parse module final t))))) | |
| 116 | (t (setf result (make-bconst-term *syntax-err-sort* | |
| 117 | (if res | |
| 118 | res | |
| 119 | preterm))) | |
| 120 | )) | |
| 121 | ;; | |
| 122 | (setq *parse-raw-parse* result) | |
| 123 | (when (term-ill-defined result) | |
| 124 | (with-output-simple-msg () | |
| 125 | (format t "~&[Error] no successful parse") | |
| 126 | (print-next) | |
| 127 | ;; (print-term-tree result t) | |
| 128 | ;; (term-print result) | |
| 129 | )) | |
| 130 | (parse-convert result module)))) | |
| 131 | )) | |
| 78 | (setq res (catch :parse-error | |
| 79 | (parse-term preterm module parser-max-precedence sort))) | |
| 80 | (when *on-parse-debug* | |
| 81 | (format t "~%[simple-parse] preterm= ~s, parsed term = " preterm) | |
| 82 | (print-terletox-list res)) | |
| 83 | (let* ((final-well-defined (mapcan #'(lambda (e) | |
| 84 | ;; e ::= ((term . prec) . remaning-tokens) | |
| 85 | (when (and (null (cdr e)) ; no remaining tokens | |
| 86 | (not (term-ill-defined | |
| 87 | (caar e)))) | |
| 88 | (list (caar e)))) | |
| 89 | res)) | |
| 90 | (final (if final-well-defined | |
| 91 | final-well-defined | |
| 92 | (mapcan #'(lambda (e) | |
| 93 | ;; gather ones without remaining tokens | |
| 94 | (unless (cdr e) | |
| 95 | (list (caar e)))) | |
| 96 | res))) | |
| 97 | (partial (if final | |
| 98 | nil | |
| 99 | (let ((len 0) | |
| 100 | ;; gather partially parsed ones | |
| 101 | (val nil)) | |
| 102 | (dolist (e res val) | |
| 103 | (if (< len (length (the list (cdr e)))) | |
| 104 | (setf val (cons (caar e) (cdr e)))))))) | |
| 105 | (result nil)) | |
| 106 | ;; | |
| 107 | (cond (partial (setf result | |
| 108 | ;; syntax error: partially parsed | |
| 109 | (make-applform *syntax-err-sort* | |
| 110 | *partial-method* | |
| 111 | (list (car partial) | |
| 112 | (make-bconst-term *universal-sort* | |
| 113 | (cdr partial)))))) | |
| 114 | (final (if (term-ill-defined (car final)) | |
| 115 | (setf result (car final)) | |
| 116 | (setf result | |
| 117 | (if (null (cdr final)) | |
| 118 | (car final) | |
| 119 | (select-parse module final t))))) | |
| 120 | (t (setf result (make-bconst-term *syntax-err-sort* | |
| 121 | ;; whole term could not be parsed | |
| 122 | (if res | |
| 123 | res | |
| 124 | preterm))))) | |
| 125 | ;; | |
| 126 | (setq *parse-raw-parse* result) | |
| 127 | (when (term-ill-defined result) | |
| 128 | (with-output-simple-msg () | |
| 129 | (format t "~&[Error] no successful parse"))) | |
| 130 | (parse-convert result module)))))) | |
| 132 | 131 | |
| 133 | 132 | (defun select-parse (module final &optional print-warning) |
| 134 | 133 | (declare (type module module) |
| 135 | (type list final) | |
| 136 | (type t print-warning)) | |
| 134 | (type list final) | |
| 135 | (type t print-warning)) | |
| 137 | 136 | (let ((*print-with-sort* t) |
| 138 | (*fancy-print* nil)) | |
| 137 | (*fancy-print* nil)) | |
| 139 | 138 | (setq .saved-ambiguous. final) |
| 140 | 139 | ;; minimize the ambiguity. |
| 141 | 140 | (setq final (pre-choose-final module final)) |
| 144 | 143 | ;; |
| 145 | 144 | (when print-warning |
| 146 | 145 | (with-output-chaos-warning () |
| 147 | (princ "Ambiguous term:") | |
| 148 | (print-next) | |
| 149 | (princ "please try `check regularity' command.") | |
| 150 | (print-next) | |
| 151 | (princ "if the signature is regular, there possibly be ") | |
| 152 | (print-next) | |
| 153 | (princ "some name conflicts between operators and variables.") | |
| 154 | )) | |
| 146 | (princ "Ambiguous term:") | |
| 147 | (print-next) | |
| 148 | (princ "please try `check regularity' command.") | |
| 149 | (print-next) | |
| 150 | (princ "if the signature is regular, there possibly be ") | |
| 151 | (print-next) | |
| 152 | (princ "some name conflicts between operators and variables."))) | |
| 155 | 153 | ;; |
| 156 | 154 | (print-next) |
| 157 | 155 | (if *select-ambig-term* |
| 158 | (progn | |
| 159 | (princ "* Please select a term from the followings:") | |
| 160 | (print-next) | |
| 161 | (parse-show-diff final) | |
| 162 | (print-next) | |
| 163 | ;; select a term | |
| 164 | (let ((choise 1) | |
| 165 | user-choise | |
| 166 | (num (length final))) | |
| 167 | (declare (type fixnum choise num)) | |
| 168 | ;; query user | |
| 169 | (setq user-choise | |
| 170 | (query-input | |
| 171 | 1 | |
| 172 | 60 | |
| 173 | "* Please input your choice (a number from 1 to ~d, default is 1)? " | |
| 174 | num)) | |
| 175 | (cond ((and (numberp user-choise) (<= (the fixnum user-choise) num)) | |
| 176 | (setf choise user-choise) | |
| 177 | (format t "Taking the ~:R as correct.~%" choise)) | |
| 178 | (t (format t "Arbitrarily taking the ~:R as correct.~%" choise))) | |
| 179 | (nth (1- choise) final))) | |
| 156 | (progn | |
| 157 | (princ "* Please select a term from the followings:") | |
| 158 | (print-next) | |
| 159 | (parse-show-diff final) | |
| 160 | (print-next) | |
| 161 | ;; select a term | |
| 162 | (let ((choise 1) | |
| 163 | user-choise | |
| 164 | (num (length final))) | |
| 165 | (declare (type fixnum choise num)) | |
| 166 | ;; query user | |
| 167 | (setq user-choise | |
| 168 | (query-input | |
| 169 | 1 | |
| 170 | 60 | |
| 171 | "* Please input your choice (a number from 1 to ~d, default is 1)? " | |
| 172 | num)) | |
| 173 | (cond ((and (numberp user-choise) (<= (the fixnum user-choise) num)) | |
| 174 | (setf choise user-choise) | |
| 175 | (format t "Taking the ~:R as correct.~%" choise)) | |
| 176 | (t (format t "Arbitrarily taking the ~:R as correct.~%" choise))) | |
| 177 | (nth (1- choise) final))) | |
| 180 | 178 | (progn |
| 181 | (parse-show-diff final) | |
| 182 | (make-bconst-term *syntax-err-sort* "ambiguous term") | |
| 183 | )) | |
| 184 | )) | |
| 179 | (parse-show-diff final) | |
| 180 | (make-bconst-term *syntax-err-sort* "ambiguous term"))))) | |
| 185 | 181 | |
| 186 | 182 | (defun pre-choose-final-sub (module final) |
| 187 | 183 | (declare (type module module) |
| 188 | (type list final)) | |
| 184 | (type list final)) | |
| 189 | 185 | ;; here we minimize the set of candidates of possible result of parsing. |
| 190 | ;; | |
| 191 | 186 | (let ((well ) |
| 192 | (min nil) | |
| 193 | (so (module-sort-order module)) | |
| 194 | (res nil)) | |
| 187 | (min nil) | |
| 188 | (so (module-sort-order module)) | |
| 189 | (res nil)) | |
| 195 | 190 | (declare (type list well res min) |
| 196 | (type sort-order so)) | |
| 197 | ;; due to our parsing algorithm (no flames are welcom), possibly | |
| 198 | ;; the same (in a sense of term-is-similar?) terms can co-exist. | |
| 199 | (setq final (delete-duplicates final :test #'term-is-similar?)) | |
| 200 | ||
| 191 | (type sort-order so)) | |
| 201 | 192 | ;; of course, ill sorted terms detected during parsing procs. are |
| 202 | 193 | ;; out of our focus. |
| 203 | 194 | ;; miserablly terminates when all are ill-defined terms... |
| 204 | 195 | (setq well (remove-if #'(lambda (x) |
| 205 | (not (term-is-really-well-defined x))) | |
| 206 | final)) | |
| 196 | (not (term-is-really-well-defined x))) | |
| 197 | final)) | |
| 207 | 198 | (unless well (return-from pre-choose-final-sub final)) |
| 208 | 199 | |
| 209 | 200 | ;; select the lowest parses among possibilities. |
| 212 | 203 | ;; 2010/7/3: we must not eliminate variables!!!!!!!! |
| 213 | 204 | ;; |
| 214 | 205 | (setf min (minimal-sorts (mapcar #'(lambda (x) (term-sort x)) well) |
| 215 | so)) | |
| 216 | (dolist (f well) ; filter out terms with | |
| 217 | ; non-minimal sort. | |
| 206 | so)) | |
| 207 | (dolist (f well) ; filter out terms with | |
| 208 | ; non-minimal sort. | |
| 218 | 209 | (when (or (term-is-variable? f) |
| 219 | (memq (term-sort f) min)) | |
| 220 | (push f res))) | |
| 210 | (memq (term-sort f) min)) | |
| 211 | (push f res))) | |
| 221 | 212 | |
| 222 | 213 | ;; special case for terms of *universal-sort*, they may have some |
| 223 | 214 | ;;; ill-formed terms in their subterms. |
| 224 | 215 | |
| 225 | 216 | (if (or (sort= (car min) *cosmos*) |
| 226 | (sort= (car min) *universal-sort*) | |
| 227 | (sort= (car min) *huniversal-sort*)) | |
| 228 | (let ((pres (remove-if #'(lambda (x) | |
| 229 | (and (term-is-application-form? x) | |
| 230 | (some #'term-contains-error-method | |
| 231 | (term-subterms x)))) | |
| 232 | res))) | |
| 233 | (if pres | |
| 234 | ;; if there are some remaining terms serviving these | |
| 235 | ;; hard checks, they can be the result. | |
| 236 | pres | |
| 237 | ;; OK, we failed in a test. let ask users which we should | |
| 238 | ;; take as a result. | |
| 239 | res)) | |
| 217 | (sort= (car min) *universal-sort*) | |
| 218 | (sort= (car min) *huniversal-sort*)) | |
| 219 | (let ((pres (remove-if #'(lambda (x) | |
| 220 | (and (term-is-application-form? x) | |
| 221 | (some #'term-contains-error-method | |
| 222 | (term-subterms x)))) | |
| 223 | res))) | |
| 224 | (if pres | |
| 225 | ;; if there are some remaining terms serviving these | |
| 226 | ;; hard checks, they can be the result. | |
| 227 | pres | |
| 228 | ;; OK, we failed in a test. let ask users which we should | |
| 229 | ;; take as a result. | |
| 230 | res)) | |
| 240 | 231 | res))) |
| 241 | 232 | |
| 242 | 233 | (defun pre-choose-final (module final) |
| 243 | 234 | (declare (type module module) |
| 244 | (type list final)) | |
| 245 | (when (and (cdr final) (assoc *id-module* (module-all-submodules module))) | |
| 246 | ;; (format t "~%~s" final) | |
| 247 | (setq final | |
| 248 | (remove-if #'(lambda (x) (sort= *id-sort* (term-sort x))) final))) | |
| 249 | (when (every #'(lambda(x) (term-is-application-form? x)) final) | |
| 250 | (let ((mslist (mapcar #'(lambda (x) (term-head x)) final)) | |
| 251 | (least-op nil) | |
| 252 | (gen-op nil) | |
| 253 | (res nil)) | |
| 254 | (with-in-module (module) | |
| 255 | ;; | |
| 256 | ;; first find the lowest one | |
| 257 | (setq least-op (choose-lowest-op mslist)) | |
| 258 | (when least-op | |
| 259 | (push (find-if #'(lambda (x) (method= least-op (term-head x))) | |
| 260 | final) | |
| 261 | res) | |
| 262 | (return-from pre-choose-final res)) | |
| 263 | ;; then select most general one | |
| 264 | (setq gen-op (choose-most-general-op mslist)) | |
| 265 | (when gen-op | |
| 266 | (push (find-if #'(lambda (x) (method= gen-op (term-head x))) final) | |
| 267 | res) | |
| 268 | (return-from pre-choose-final res))))) | |
| 269 | ;; could not find | |
| 270 | (pre-choose-final-sub module final)) | |
| 235 | (type list final)) | |
| 236 | ;; due to our parsing algorithm (no flames are welcom), possibly | |
| 237 | ;; the same (in a sense of term-is-similar?) terms can co-exist. | |
| 238 | (setq final (delete-duplicates final :test #'term-is-similar?)) | |
| 239 | (let ((result final)) | |
| 240 | (when (and (cdr final) (assoc *id-module* (module-all-submodules module))) | |
| 241 | (setq result (remove-if #'(lambda (x) (sort= *id-sort* (term-sort x))) final))) | |
| 242 | (when (every #'(lambda(x) (term-is-application-form? x)) result) | |
| 243 | (when *on-operator-debug* | |
| 244 | (format t "~%[pre-choose-final]") | |
| 245 | (dolist (tx final) | |
| 246 | (terpri) | |
| 247 | (print-chaos-object (term-head tx)) | |
| 248 | (princ ": ") | |
| 249 | (term-print-with-sort tx))) | |
| 250 | (let ((mslist (mapcar #'(lambda (x) (term-head x)) result)) | |
| 251 | (least-op nil) | |
| 252 | (gen-op nil) | |
| 253 | (res nil)) | |
| 254 | (with-in-module (module) | |
| 255 | (cond ((null (cdr mslist)) | |
| 256 | ;; do nothing | |
| 257 | ) | |
| 258 | ((null (cdr (remove-duplicates mslist :test #'(lambda (x y) (method= x y))))) | |
| 259 | ;; check subterms and select one | |
| 260 | (setq result (choose-most-apropreate-term result))) | |
| 261 | (t ;; first find the lowest one | |
| 262 | (setq least-op (choose-lowest-op mslist)) | |
| 263 | (cond (least-op | |
| 264 | (if (method= *bool-if* least-op) | |
| 265 | (setq res (select-if-then-least result (module-sort-order module))) | |
| 266 | (push (find-if #'(lambda (x) (method= least-op (term-head x))) | |
| 267 | result) | |
| 268 | res)) | |
| 269 | (setq result res)) | |
| 270 | (t (setq gen-op (choose-most-general-op mslist)) | |
| 271 | ;; then select most general one | |
| 272 | (when gen-op | |
| 273 | (push (find-if #'(lambda (x) (method= gen-op (term-head x))) result) | |
| 274 | res) | |
| 275 | (setq result res))))))))) | |
| 276 | (if result | |
| 277 | (pre-choose-final-sub module result) | |
| 278 | (pre-choose-final-sub module final)))) | |
| 279 | ||
| 280 | ;;; select a one among terms with the same top operator | |
| 281 | (defun choose-most-apropreate-term (terms) | |
| 282 | (unless (term-subterms (car terms)) | |
| 283 | ;; this is very strange case | |
| 284 | (return-from choose-most-apropreate-term nil)) | |
| 285 | (let ((res nil)) | |
| 286 | (dolist (term terms) | |
| 287 | (when (every #'(lambda (x) (not (term-head-is-error x))) (term-subterms term)) | |
| 288 | (push term res))) | |
| 289 | res)) | |
| 271 | 290 | |
| 272 | 291 | ;;; NOT USED NOW. |
| 273 | 292 | (defun parser-diagnose (module preterm sort) |
| 274 | 293 | (declare (type module module) |
| 275 | (type list preterm) | |
| 276 | (type sort* sort)) | |
| 294 | (type list preterm) | |
| 295 | (type sort* sort)) | |
| 277 | 296 | (if (null preterm) |
| 278 | 297 | (format t "-- !Input is empty~%.") |
| 279 | 298 | (progn |
| 280 | (print-simple-princ-open preterm) (print-next) | |
| 281 | (let ((prefix nil) | |
| 282 | (suffix preterm) | |
| 283 | (flags (make-list (length preterm))) | |
| 284 | (len (length preterm))) | |
| 285 | (declare (type fixnum len)) | |
| 286 | (when *chaos-verbose* | |
| 287 | (princ "[ partial parses ]: ") | |
| 288 | (print-next) | |
| 289 | (let ((indent *print-indent*)) | |
| 290 | (declare (type fixnum indent)) | |
| 291 | (loop | |
| 292 | (incf indent) | |
| 293 | (let ((*print-indent* indent)) | |
| 294 | (when (null suffix) (return)) | |
| 295 | (when *chaos-verbose* | |
| 296 | (princ " ") | |
| 297 | (when prefix (print-simple-princ-open prefix)) | |
| 298 | (princ " @ ") | |
| 299 | (when suffix (print-simple-princ-open suffix)) | |
| 300 | (print-next)) | |
| 301 | (let ((res (catch :parse-error | |
| 302 | (parse-term suffix module | |
| 303 | parser-max-precedence ; ******* | |
| 304 | sort)))) | |
| 305 | (mapc #'(lambda (e) | |
| 306 | (let ((lenp (length prefix))) | |
| 307 | (dotimes (i (- len (+ lenp (length (cdr e))))) | |
| 308 | (setf (nth (+ lenp i) flags) t) | |
| 309 | )) | |
| 310 | (when *chaos-verbose* | |
| 311 | (princ " ==> ") | |
| 312 | (when prefix | |
| 313 | (print-simple-princ-open prefix) (princ " <<< ")) | |
| 314 | (let ((tm (caar e))) | |
| 315 | (princ "(") | |
| 316 | (term-print tm) | |
| 317 | (princ ").") | |
| 318 | (print-sort-name (term-sort tm) | |
| 319 | module)) | |
| 320 | (when (cdr e) | |
| 321 | (princ " >>> ") | |
| 322 | (print-simple-princ-open (cdr e))) | |
| 323 | (print-next))) | |
| 324 | res) | |
| 325 | ) | |
| 326 | (setq prefix (append prefix (list (car suffix)))) | |
| 327 | (setq suffix (cdr suffix)) | |
| 328 | )))) | |
| 329 | (princ "[ partial descriptions ]: ") | |
| 330 | (let ((*print-indent* (+ *print-indent* 2))) | |
| 331 | (print-next) | |
| 332 | (dotimes (i len) | |
| 333 | (if (nth i flags) | |
| 334 | (princ " !") | |
| 335 | (progn | |
| 336 | (princ " ") | |
| 337 | (princ (nth i preterm))))) | |
| 338 | (print-next) | |
| 339 | (dotimes (i len) | |
| 340 | (if (and (null (nth i flags)) | |
| 341 | (or (= 0 i) | |
| 342 | (nth (1- i) flags))) | |
| 343 | (princ " -[") | |
| 344 | (if (and (not (= 0 i)) | |
| 345 | (nth i flags) | |
| 346 | (null (nth (1- i) flags))) | |
| 347 | (princ "]- ") | |
| 348 | (princ " "))) | |
| 349 | (princ (nth i preterm)) | |
| 350 | (print-check)) | |
| 351 | (when (null (nth (1- len) flags)) (princ "]-")) | |
| 352 | (print-next) | |
| 353 | )) | |
| 354 | ))) | |
| 299 | (print-simple-princ-open preterm) (print-next) | |
| 300 | (let ((prefix nil) | |
| 301 | (suffix preterm) | |
| 302 | (flags (make-list (length preterm))) | |
| 303 | (len (length preterm))) | |
| 304 | (declare (type fixnum len)) | |
| 305 | (when *chaos-verbose* | |
| 306 | (princ "[ partial parses ]: ") | |
| 307 | (print-next) | |
| 308 | (let ((indent *print-indent*)) | |
| 309 | (declare (type fixnum indent)) | |
| 310 | (loop | |
| 311 | (incf indent) | |
| 312 | (let ((*print-indent* indent)) | |
| 313 | (when (null suffix) (return)) | |
| 314 | (when *chaos-verbose* | |
| 315 | (princ " ") | |
| 316 | (when prefix (print-simple-princ-open prefix)) | |
| 317 | (princ " @ ") | |
| 318 | (when suffix (print-simple-princ-open suffix)) | |
| 319 | (print-next)) | |
| 320 | (let ((res (catch :parse-error | |
| 321 | (parse-term suffix module | |
| 322 | parser-max-precedence ; ******* | |
| 323 | sort)))) | |
| 324 | (mapc #'(lambda (e) | |
| 325 | (let ((lenp (length prefix))) | |
| 326 | (dotimes (i (- len (+ lenp (length (cdr e))))) | |
| 327 | (setf (nth (+ lenp i) flags) t) | |
| 328 | )) | |
| 329 | (when *chaos-verbose* | |
| 330 | (princ " ==> ") | |
| 331 | (when prefix | |
| 332 | (print-simple-princ-open prefix) (princ " <<< ")) | |
| 333 | (let ((tm (caar e))) | |
| 334 | (princ "(") | |
| 335 | (term-print tm) | |
| 336 | (princ ").") | |
| 337 | (print-sort-name (term-sort tm) | |
| 338 | module)) | |
| 339 | (when (cdr e) | |
| 340 | (princ " >>> ") | |
| 341 | (print-simple-princ-open (cdr e))) | |
| 342 | (print-next))) | |
| 343 | res) | |
| 344 | ) | |
| 345 | (setq prefix (append prefix (list (car suffix)))) | |
| 346 | (setq suffix (cdr suffix)) | |
| 347 | )))) | |
| 348 | (princ "[ partial descriptions ]: ") | |
| 349 | (let ((*print-indent* (+ *print-indent* 2))) | |
| 350 | (print-next) | |
| 351 | (dotimes (i len) | |
| 352 | (if (nth i flags) | |
| 353 | (princ " !") | |
| 354 | (progn | |
| 355 | (princ " ") | |
| 356 | (princ (nth i preterm))))) | |
| 357 | (print-next) | |
| 358 | (dotimes (i len) | |
| 359 | (if (and (null (nth i flags)) | |
| 360 | (or (= 0 i) | |
| 361 | (nth (1- i) flags))) | |
| 362 | (princ " -[") | |
| 363 | (if (and (not (= 0 i)) | |
| 364 | (nth i flags) | |
| 365 | (null (nth (1- i) flags))) | |
| 366 | (princ "]- ") | |
| 367 | (princ " "))) | |
| 368 | (princ (nth i preterm)) | |
| 369 | (print-check)) | |
| 370 | (when (null (nth (1- len) flags)) (princ "]-")) | |
| 371 | (print-next) | |
| 372 | )) | |
| 373 | ))) | |
| 355 | 374 | |
| 356 | 375 | (defun simple-parse-ground (id module preterm &optional (sort *cosmos*)) |
| 357 | 376 | (declare (type t id) |
| 358 | (type module module) | |
| 359 | (type list preterm) | |
| 360 | (type sort* sort)) | |
| 377 | (type module module) | |
| 378 | (type list preterm) | |
| 379 | (type sort* sort)) | |
| 361 | 380 | (let ((trm (simple-parse module preterm sort))) |
| 362 | 381 | (unless (term-is-ground? trm) |
| 363 | 382 | (with-output-chaos-warning () |
| 364 | (format t "in ~a, term contains variable(s): " id) | |
| 365 | (term-print trm))) | |
| 383 | (format t "in ~a, term contains variable(s): " id) | |
| 384 | (term-print trm))) | |
| 366 | 385 | trm)) |
| 367 | 386 | |
| 368 | 387 | ;;; parse-convert : term -> term' |
| 369 | 388 | ;;; |
| 370 | 389 | (defun parse-convert (term |
| 371 | &optional (module (or *current-module* *last-module*))) | |
| 390 | &optional (module (get-context-module))) | |
| 372 | 391 | ;; #define macro expand |
| 373 | 392 | (when *macroexpand* |
| 374 | 393 | (setq term (expand-macro term module))) |
| 375 | 394 | (if *parse-normalize* |
| 376 | 395 | (with-in-module (module) |
| 377 | (right-associative-normal-form term)) | |
| 396 | (right-associative-normal-form term)) | |
| 378 | 397 | term)) |
| 379 | ||
| 398 | ||
| 380 | 399 | ;;; convert builtin constants to appropriate form |
| 381 | 400 | ;;; (cond ((term-is-variable? term) term) |
| 382 | ;;; ((term-is-builtin-constant? term) term) | |
| 383 | ;;; (t (re-assign-term-sort term) term)) | |
| 401 | ;;; ((term-is-builtin-constant? term) term) | |
| 402 | ;;; (t (re-assign-term-sort term) term)) | |
| 384 | 403 | |
| 385 | 404 | (defun parse-show-diff (terms) |
| 386 | 405 | (declare (type list terms)) |
| 387 | 406 | (let ((*fancy-print* nil) |
| 388 | ;; (*print-with-sort* t) | |
| 389 | ) | |
| 407 | ;; (*print-with-sort* t) | |
| 408 | ) | |
| 390 | 409 | (do* ((term-list terms (cdr term-list)) |
| 391 | (num 1 (1+ num)) | |
| 392 | (term (car term-list) (car term-list))) | |
| 393 | ((null term-list)) | |
| 410 | (num 1 (1+ num)) | |
| 411 | (term (car term-list) (car term-list))) | |
| 412 | ((null term-list)) | |
| 394 | 413 | (print-next) |
| 395 | 414 | (princ "[") (princ num) (princ "] ") |
| 396 | 415 | (if (term-is-variable? term) |
| 397 | (print-to-left | |
| 398 | (format nil "variable ~a:~a" | |
| 399 | (variable-name term) | |
| 400 | (sort-print-name (term-sort term))) | |
| 401 | "-") | |
| 402 | (if (term-is-builtin-constant? term) | |
| 403 | (print-to-left (bi-method-print-string term) "-") | |
| 404 | (print-to-left (method-print-string (term-head term)) "-") | |
| 405 | ) | |
| 406 | ) | |
| 416 | (print-to-left | |
| 417 | (format nil "variable ~a:~a" | |
| 418 | (variable-name term) | |
| 419 | (sort-print-name (term-sort term))) | |
| 420 | "-") | |
| 421 | (if (term-is-builtin-constant? term) | |
| 422 | (print-to-left (bi-method-print-string term) "-") | |
| 423 | (print-to-left (method-print-string (term-head term)) "-") | |
| 424 | ) | |
| 425 | ) | |
| 407 | 426 | (if *chaos-verbose* |
| 408 | (print-term-tree term t) | |
| 409 | (term-print term) )))) | |
| 427 | (print-term-tree term t) | |
| 428 | (term-print term) )))) | |
| 410 | 429 | |
| 411 | 430 | ;;; produces a list of initial complete parses given all parses as arg |
| 412 | 431 | ;;; |
| 413 | 432 | (defun parser-complete-parses (mod parselist) |
| 414 | 433 | (declare (type list parselist)) |
| 415 | 434 | (mapcan #'(lambda (x) (if (null (cdr x)) |
| 416 | (list (parse-convert (caar x) mod)) | |
| 417 | nil)) | |
| 418 | parselist)) | |
| 435 | (list (parse-convert (caar x) mod)) | |
| 436 | nil)) | |
| 437 | parselist)) | |
| 419 | 438 | |
| 420 | 439 | ;;; produces a list of initial complete parses; nil for error |
| 421 | 440 | ;;; |
| 422 | 441 | (defun parser-parses (module preterm &optional (sort *cosmos*)) |
| 423 | 442 | (declare (type module module) |
| 424 | (type (or list string) preterm) | |
| 425 | (type sort* sort)) | |
| 443 | (type (or list string) preterm) | |
| 444 | (type sort* sort)) | |
| 426 | 445 | (when (stringp preterm) |
| 427 | 446 | (setf preterm (read-term-from-string preterm))) |
| 428 | 447 | (if (null preterm) |
| 429 | 448 | nil |
| 430 | 449 | (with-in-module (module) |
| 431 | 450 | (let ((val (catch :parse-error |
| 432 | (parse-term preterm module | |
| 433 | parser-max-precedence sort)))) ; **** | |
| 434 | (let ((res (mapcan #'(lambda (x) (if (null (cdr x)) | |
| 435 | (list (parse-convert (caar x) | |
| 436 | module)) | |
| 437 | nil)) | |
| 438 | val))) | |
| 439 | (parser-find-parse module res *cosmos* t)))))) | |
| 451 | (parse-term preterm module | |
| 452 | parser-max-precedence sort)))) ; **** | |
| 453 | (let ((res (mapcan #'(lambda (x) (if (null (cdr x)) | |
| 454 | (list (parse-convert (caar x) | |
| 455 | module)) | |
| 456 | nil)) | |
| 457 | val))) | |
| 458 | (parser-find-parse module res *cosmos* t)))))) | |
| 440 | 459 | |
| 441 | 460 | ;;; takes list of first parses and a sort and comes back with |
| 442 | 461 | ;;; nil -- none; or a list of possible parses |
| 443 | 462 | ;;; (any well-defined preferred to ill-defined) |
| 444 | 463 | (defun parser-find-parse (module parses sort &optional try-remove-error-method) |
| 445 | 464 | (declare (ignore try-remove-error-method) |
| 446 | (type module module) | |
| 447 | (type list parses) | |
| 448 | (type sort* sort) | |
| 449 | (type (or null t) try-remove-error-method)) | |
| 450 | ; optional parameter is not used now, | |
| 451 | ; the work is done in pre-choose-final. | |
| 452 | ; callers should adapt to this change. | |
| 465 | (type module module) | |
| 466 | (type list parses) | |
| 467 | (type sort* sort) | |
| 468 | (type (or null t) try-remove-error-method)) | |
| 469 | ; optional parameter is not used now, | |
| 470 | ; the work is done in pre-choose-final. | |
| 471 | ; callers should adapt to this change. | |
| 453 | 472 | (let ((so (module-sort-order module)) |
| 454 | (well nil) | |
| 455 | (p-well nil) | |
| 456 | (any nil) | |
| 457 | (ill nil)) | |
| 473 | (well nil) | |
| 474 | (p-well nil) | |
| 475 | (any nil) | |
| 476 | (ill nil)) | |
| 458 | 477 | (declare (type sort-order so) |
| 459 | (type list well p-well any ill)) | |
| 478 | (type list well p-well any ill)) | |
| 460 | 479 | ;; filter out some |
| 461 | 480 | (setq parses (pre-choose-final module parses)) |
| 462 | 481 | ;; classify terms: |
| 467 | 486 | ;; ill = ill-defined terms of any kind. |
| 468 | 487 | (dolist (term parses) |
| 469 | 488 | (if (term-ill-defined term) |
| 470 | (push term ill) | |
| 471 | (if (sort<= (term-sort term) sort so) | |
| 472 | (push term well) | |
| 473 | (if (is-in-same-connected-component (term-sort term) | |
| 474 | sort | |
| 475 | so) | |
| 476 | (push term p-well) | |
| 477 | (push term any))))) | |
| 489 | (push term ill) | |
| 490 | (if (sort<= (term-sort term) sort so) | |
| 491 | (push term well) | |
| 492 | (if (is-in-same-connected-component (term-sort term) | |
| 493 | sort | |
| 494 | so) | |
| 495 | (push term p-well) | |
| 496 | (push term any))))) | |
| 478 | 497 | ;; the precedence is ofcource well > p-well > ill > any |
| 479 | 498 | (or well p-well ill any))) |
| 480 | 499 | |
| 484 | 503 | ;;; very similar to above, but is required to directly satisfy sort restriction |
| 485 | 504 | (defun parser-find-parse-strict (module parses sort) |
| 486 | 505 | (declare (type module module) |
| 487 | (type list parses) | |
| 488 | (type sort* sort)) | |
| 506 | (type list parses) | |
| 507 | (type sort* sort)) | |
| 489 | 508 | (let ((*current-module* module)) |
| 490 | 509 | (let ((so (module-sort-order module)) |
| 491 | (ill nil) (well nil)) | |
| 510 | (ill nil) (well nil)) | |
| 492 | 511 | (declare (type sort-order so)) |
| 493 | 512 | (dolist (tm parses) |
| 494 | (if (sort<= (term-sort tm) sort so) | |
| 495 | (if (term-ill-defined tm) | |
| 496 | (when (null well) (push tm ill)) | |
| 497 | (push tm well)))) | |
| 513 | (if (sort<= (term-sort tm) sort so) | |
| 514 | (if (term-ill-defined tm) | |
| 515 | (when (null well) (push tm ill)) | |
| 516 | (push tm well)))) | |
| 498 | 517 | (if well well |
| 499 | (if ill | |
| 500 | ill | |
| 501 | nil))))) | |
| 518 | (if ill | |
| 519 | ill | |
| 520 | nil))))) | |
| 502 | 521 | |
| 503 | 522 | ;;; takes list of first parses and a list of sorts and comes back with |
| 504 | 523 | ;;; nil -- none; or a list of possible parses |
| 507 | 526 | ;;; |
| 508 | 527 | (defun parser-find-parse-strict-sorts (module parses sorts) |
| 509 | 528 | (declare (type module module) |
| 510 | (type list parses sorts)) | |
| 529 | (type list parses sorts)) | |
| 511 | 530 | (let ((*current-module* module)) |
| 512 | 531 | (let ((so (module-sort-order module)) |
| 513 | (ill nil) (well nil)) | |
| 532 | (ill nil) (well nil)) | |
| 514 | 533 | (declare (type sort-order so)) |
| 515 | 534 | (dolist (tm parses) |
| 516 | (if (member (term-sort tm) sorts | |
| 517 | :test #'(lambda (x y) (sort<= x y so))) | |
| 518 | (if (term-ill-defined tm) | |
| 519 | (when (null well) (push tm ill)) | |
| 520 | (push tm well)))) | |
| 535 | (if (member (term-sort tm) sorts | |
| 536 | :test #'(lambda (x y) (sort<= x y so))) | |
| 537 | (if (term-ill-defined tm) | |
| 538 | (when (null well) (push tm ill)) | |
| 539 | (push tm well)))) | |
| 521 | 540 | (if well |
| 522 | well | |
| 523 | (if ill | |
| 524 | ill | |
| 525 | nil))))) | |
| 541 | well | |
| 542 | (if ill | |
| 543 | ill | |
| 544 | nil))))) | |
| 526 | 545 | |
| 527 | 546 | ;;; given list of parses of lhs and rhs (as from parser-parses) looks |
| 528 | 547 | ;;; for compatible pair |
| 529 | 548 | ;; |
| 530 | 549 | (defun parser-find-rule-pair (module lhslst rhslst) |
| 531 | 550 | (declare (type module module) |
| 532 | (type list lhslst rhslst)) | |
| 533 | (let ((*current-module* module)) | |
| 551 | (type list lhslst rhslst)) | |
| 552 | (with-in-module (module) | |
| 534 | 553 | (let ((so (module-sort-order module)) |
| 535 | (ok nil) | |
| 536 | (retr nil) | |
| 537 | (ill nil)) | |
| 554 | (ok nil) | |
| 555 | (retr nil)) | |
| 556 | ;; foreach lhs:lhslst { | |
| 557 | ;; foreach rhs:rhslst { | |
| 538 | 558 | (dolist (lhs lhslst) |
| 539 | (let ((sl (term-sort lhs))) | |
| 540 | (dolist (rhs rhslst) | |
| 541 | (let ((sr (term-sort rhs))) | |
| 542 | (if (term-ill-defined lhs) | |
| 543 | (push (list lhs rhs) ill) | |
| 544 | (if (term-head-is-error lhs) | |
| 545 | (if (is-in-same-connected-component sl sr so) | |
| 546 | (push (list lhs rhs) retr) | |
| 547 | ;; else, completely bad, unacceptable | |
| 548 | ()) | |
| 549 | ;; lhs is proper term | |
| 550 | (if (sort<= sr sl so) | |
| 551 | (if (term-ill-defined rhs) | |
| 552 | (push (list lhs rhs) ill) | |
| 553 | (push (list lhs rhs) ok)) | |
| 554 | (if (is-in-same-connected-component sl sr so) | |
| 555 | (if (term-ill-defined rhs) | |
| 556 | (push (list lhs rhs) ill) | |
| 557 | (push (list lhs rhs) retr)) | |
| 558 | ;; lhs and rhs is not in same compo. | |
| 559 | () | |
| 560 | ) | |
| 561 | )))) | |
| 562 | ))) | |
| 563 | (if ok | |
| 564 | ok | |
| 565 | (if retr | |
| 566 | retr | |
| 567 | nil)) | |
| 568 | ))) | |
| 559 | (block cont-lhs | |
| 560 | (when *on-axiom-debug* | |
| 561 | (format t "~%lhs: ") | |
| 562 | (term-print-with-sort lhs)) | |
| 563 | (when (term-ill-defined lhs) | |
| 564 | (return-from cont-lhs)) ; skip it and continue | |
| 565 | (let ((sl (term-sort lhs))) | |
| 566 | (dolist (rhs rhslst) | |
| 567 | (block cont-rhs | |
| 568 | (when *on-axiom-debug* | |
| 569 | (format t "~&rhs: ") | |
| 570 | (term-print-with-sort rhs)) | |
| 571 | (when (term-ill-defined rhs) | |
| 572 | (return-from cont-rhs)) ; continue it and continue | |
| 573 | (let ((sr (term-sort rhs))) | |
| 574 | (if (sort<= sr sl so) | |
| 575 | (push (list lhs rhs) ok) | |
| 576 | (when (is-in-same-connected-component sl sr so) | |
| 577 | (push (list lhs rhs) retr))))))))) | |
| 578 | ;; | |
| 579 | (or ok retr nil)))) | |
| 569 | 580 | |
| 570 | 581 | ;;; used in modexp-compute-op-mapping |
| 571 | 582 | ;;; |
| 572 | 583 | (defun parse-quiet-parse (module preterm &optional (sort *cosmos*)) |
| 573 | 584 | (declare (type module module) |
| 574 | (type list preterm) | |
| 575 | (type sort* sort)) | |
| 585 | (type list preterm) | |
| 586 | (type sort* sort)) | |
| 576 | 587 | (if (null preterm) |
| 577 | 588 | (make-bconst-term *syntax-err-sort* '(input empty)) |
| 578 | 589 | (with-in-module (module) |
| 579 | (let ((res (catch :parse-error | |
| 580 | (parse-term preterm module parser-max-precedence sort)))) ; **** | |
| 581 | (let ((final-well-defined (mapcan #'(lambda (e) | |
| 582 | (when (and (null (cdr e)) | |
| 583 | (not (term-ill-defined | |
| 584 | (caar e)))) | |
| 585 | (list (caar e)))) | |
| 586 | res))) | |
| 587 | (let ((final (if final-well-defined final-well-defined | |
| 588 | (mapcan #'(lambda (e) | |
| 589 | (when (null (cdr e)) (list (caar e)))) | |
| 590 | res)))) | |
| 591 | (if (null final) | |
| 592 | (make-bconst-term *syntax-err-sort* preterm) | |
| 593 | (let ((raw-parse (car final))) | |
| 594 | (parse-convert raw-parse module) | |
| 595 | ) | |
| 596 | ))))))) | |
| 590 | (let ((res (catch :parse-error | |
| 591 | (parse-term preterm module parser-max-precedence sort)))) ; **** | |
| 592 | (let ((final-well-defined (mapcan #'(lambda (e) | |
| 593 | (when (and (null (cdr e)) | |
| 594 | (not (term-ill-defined | |
| 595 | (caar e)))) | |
| 596 | (list (caar e)))) | |
| 597 | res))) | |
| 598 | (let ((final (if final-well-defined final-well-defined | |
| 599 | (mapcan #'(lambda (e) | |
| 600 | (when (null (cdr e)) (list (caar e)))) | |
| 601 | res)))) | |
| 602 | (if (null final) | |
| 603 | (make-bconst-term *syntax-err-sort* preterm) | |
| 604 | (let ((raw-parse (car final))) | |
| 605 | (parse-convert raw-parse module))))))))) | |
| 597 | 606 | |
| 598 | 607 | |
| 599 | 608 | |
| 607 | 616 | ;;; |
| 608 | 617 | (defun token-seq-to-str (tseq) |
| 609 | 618 | (reduce #'(lambda (x y) |
| 610 | (concatenate 'string x y)) | |
| 611 | (mapcar #'(lambda (x) | |
| 612 | (if (eq x t) | |
| 613 | "_" | |
| 614 | x)) | |
| 615 | tseq))) | |
| 619 | (concatenate 'string x y)) | |
| 620 | (mapcar #'(lambda (x) | |
| 621 | (if (eq x t) | |
| 622 | "_" | |
| 623 | x)) | |
| 624 | tseq))) | |
| 616 | 625 | |
| 617 | 626 | (defun update-parse-information (module) |
| 618 | 627 | (declare (type module module)) |
| 619 | 628 | (let ((opinfos (module-all-operators module)) |
| 620 | (variables (module-variables module))) | |
| 629 | (variables (module-variables module))) | |
| 621 | 630 | (let ((mod-dict (module-parse-dictionary module))) |
| 622 | 631 | ;; clean up |
| 623 | 632 | (initialize-parse-dictionary mod-dict) |
| 624 | 633 | ;; |
| 625 | 634 | (dolist (s (module-all-sorts module)) |
| 626 | (when (sort-is-builtin s) | |
| 627 | (dictionary-add-builtin-sort mod-dict s))) | |
| 635 | (when (sort-is-builtin s) | |
| 636 | (dictionary-add-builtin-sort mod-dict s))) | |
| 628 | 637 | (dolist (opinfo opinfos) |
| 629 | (let* ((op (opinfo-operator opinfo)) | |
| 630 | (syn-typ (operator-syntactic-type op)) | |
| 631 | (token-seq (operator-token-sequence op))) | |
| 632 | (dolist (meth (opinfo-methods opinfo)) | |
| 633 | (case syn-typ | |
| 634 | (antefix (dictionary-add-info-on-token mod-dict | |
| 635 | (car token-seq) | |
| 636 | meth)) | |
| 637 | (latefix (dictionary-add-info-on-token mod-dict | |
| 638 | (cadr token-seq) | |
| 639 | meth) | |
| 640 | ;;#|| | |
| 641 | (dictionary-add-info-on-token mod-dict | |
| 642 | (token-seq-to-str token-seq) | |
| 643 | meth) | |
| 644 | ;;||# | |
| 645 | ) | |
| 646 | (juxtaposition | |
| 647 | ;;#|| | |
| 648 | (dictionary-add-info-on-token | |
| 649 | mod-dict | |
| 650 | (token-seq-to-str token-seq) | |
| 651 | meth) | |
| 652 | ;;||# | |
| 653 | (pushnew meth (module-juxtaposition module) :test #'eq)) | |
| 654 | (otherwise (break "SNARK: update-parse-information")))) | |
| 655 | )) | |
| 638 | (let* ((op (opinfo-operator opinfo)) | |
| 639 | (syn-typ (operator-syntactic-type op)) | |
| 640 | (token-seq (operator-token-sequence op))) | |
| 641 | (dolist (meth (opinfo-methods opinfo)) | |
| 642 | (case syn-typ | |
| 643 | (antefix (dictionary-add-info-on-token mod-dict | |
| 644 | (car token-seq) | |
| 645 | meth)) | |
| 646 | (latefix (dictionary-add-info-on-token mod-dict | |
| 647 | (cadr token-seq) | |
| 648 | meth) | |
| 649 | ;;#|| | |
| 650 | (dictionary-add-info-on-token mod-dict | |
| 651 | (token-seq-to-str token-seq) | |
| 652 | meth) | |
| 653 | ;;||# | |
| 654 | ) | |
| 655 | (juxtaposition | |
| 656 | ;;#|| | |
| 657 | (dictionary-add-info-on-token | |
| 658 | mod-dict | |
| 659 | (token-seq-to-str token-seq) | |
| 660 | meth) | |
| 661 | ;;||# | |
| 662 | (pushnew meth (module-juxtaposition module) :test #'eq)) | |
| 663 | (otherwise (break "SNARK: update-parse-information")))) | |
| 664 | )) | |
| 656 | 665 | (dolist (var variables) |
| 657 | (dictionary-add-info-on-token mod-dict | |
| 658 | (string (car var)) | |
| 659 | (cdr var))) | |
| 666 | (dictionary-add-info-on-token mod-dict | |
| 667 | (string (car var)) | |
| 668 | (cdr var))) | |
| 660 | 669 | (compress-overloaded-methods module mod-dict) |
| 661 | 670 | (setf (module-juxtaposition module) |
| 662 | (method-compress-overloaded-set (module-juxtaposition module) | |
| 663 | (module-sort-order module))) | |
| 671 | (method-compress-overloaded-set (module-juxtaposition module) | |
| 672 | (module-sort-order module))) | |
| 664 | 673 | ;; set up MACRO rules |
| 665 | 674 | (dolist (macro (module-macros module)) |
| 666 | (setup-macro-rule macro module)) | |
| 675 | (setup-macro-rule macro module)) | |
| 667 | 676 | ;; |
| 668 | 677 | ))) |
| 669 | 678 | |
| 670 | 679 | (defun compress-overloaded-methods (module dict) |
| 671 | 680 | (declare (type module module) |
| 672 | (type parse-dictionary dict)) | |
| 681 | (type parse-dictionary dict)) | |
| 673 | 682 | (with-in-module (module) |
| 674 | 683 | (let ((table (dictionary-table dict)) |
| 675 | (compressed nil)) | |
| 684 | (compressed nil)) | |
| 676 | 685 | (maphash #'(lambda (ky val) |
| 677 | (push (cons ky | |
| 678 | (method-compress-overloaded-set val)) | |
| 679 | compressed)) | |
| 680 | table) | |
| 686 | (push (cons ky | |
| 687 | (method-compress-overloaded-set val)) | |
| 688 | compressed)) | |
| 689 | table) | |
| 681 | 690 | ;; |
| 682 | 691 | (dolist (comp compressed) |
| 683 | (setf (gethash (car comp) table) | |
| 684 | (cdr comp))) | |
| 692 | (setf (gethash (car comp) table) | |
| 693 | (cdr comp))) | |
| 685 | 694 | ;; |
| 686 | 695 | (mapcar #'(lambda (opinfo) |
| 687 | (let* ((op (opinfo-operator opinfo)) | |
| 688 | (token-seq (operator-token-sequence op)) | |
| 689 | (key (if (eq t (car token-seq)) | |
| 690 | (cadr token-seq) | |
| 691 | (car token-seq))) | |
| 692 | (val (gethash key table))) | |
| 693 | (unless (or (null val) | |
| 694 | (null (cdr val))) | |
| 695 | (setf (gethash key table) | |
| 696 | (method-compress-overloaded-set (gethash key table)))))) | |
| 697 | (module-all-operators module)) | |
| 696 | (let* ((op (opinfo-operator opinfo)) | |
| 697 | (token-seq (operator-token-sequence op)) | |
| 698 | (key (if (eq t (car token-seq)) | |
| 699 | (cadr token-seq) | |
| 700 | (car token-seq))) | |
| 701 | (val (gethash key table))) | |
| 702 | (unless (or (null val) | |
| 703 | (null (cdr val))) | |
| 704 | (setf (gethash key table) | |
| 705 | (method-compress-overloaded-set (gethash key table)))))) | |
| 706 | (module-all-operators module)) | |
| 698 | 707 | ))) |
| 699 | 708 | |
| 700 | 709 | ;;; ** NOTE: this has side-effects |
| 703 | 712 | ;;; |
| 704 | 713 | #|| |
| 705 | 714 | (defun method-compress-overloaded-set (items &optional |
| 706 | (sort-order *current-sort-order*) | |
| 707 | (opinfo-table *current-opinfo-table*) | |
| 708 | (module *current-module*)) | |
| 709 | ||
| 715 | (sort-order *current-sort-order*) | |
| 716 | (opinfo-table *current-opinfo-table*) | |
| 717 | (module *current-module*)) | |
| 718 | ||
| 710 | 719 | (let ((methods nil) |
| 711 | (res nil)) | |
| 712 | (dolist (i items) ; items may contain vairables | |
| 720 | (res nil)) | |
| 721 | (dolist (i items) ; items may contain vairables | |
| 713 | 722 | (if (and (operator-method-p i) |
| 714 | (method-arity i)) ; methods with more than 0 arities | |
| 715 | (push i methods) | |
| 716 | (push i res))) | |
| 723 | (method-arity i)) ; methods with more than 0 arities | |
| 724 | (push i methods) | |
| 725 | (push i res))) | |
| 717 | 726 | ;; compress methods |
| 718 | 727 | (dolist (method methods) |
| 719 | 728 | (block next-method |
| 720 | (let ((meth (method-select-most-general-version-of method | |
| 721 | methods | |
| 722 | sort-order | |
| 723 | opinfo-table | |
| 724 | module))) | |
| 725 | (unless (memq meth res) | |
| 726 | ;; set syntactic properties of the most general method used for parsing, | |
| 727 | ;; we consider `associativity' and `precedence'. | |
| 728 | (when (method-is-error-method meth) | |
| 729 | (let ((ms (method-lower-methods meth))) | |
| 730 | ;; assumption, lower methods (when the mehthod is strictly | |
| 731 | ;; overloaded) are ordered ... | |
| 732 | (when ms | |
| 733 | (let ((assoc (method-associativity (car ms))) | |
| 734 | (prec (get-method-precedence (car ms))) | |
| 735 | (form (method-form (car ms)))) | |
| 736 | (setf (method-associativity meth) assoc) | |
| 737 | (setf (method-precedence meth) prec) | |
| 738 | (setf (method-form meth) form))))) | |
| 739 | ;; | |
| 740 | (push meth res))))) | |
| 729 | (let ((meth (method-select-most-general-version-of method | |
| 730 | methods | |
| 731 | sort-order | |
| 732 | opinfo-table | |
| 733 | module))) | |
| 734 | (unless (memq meth res) | |
| 735 | ;; set syntactic properties of the most general method used for parsing, | |
| 736 | ;; we consider `associativity' and `precedence'. | |
| 737 | (when (method-is-error-method meth) | |
| 738 | (let ((ms (method-lower-methods meth))) | |
| 739 | ;; assumption, lower methods (when the mehthod is strictly | |
| 740 | ;; overloaded) are ordered ... | |
| 741 | (when ms | |
| 742 | (let ((assoc (method-associativity (car ms))) | |
| 743 | (prec (get-method-precedence (car ms))) | |
| 744 | (form (method-form (car ms)))) | |
| 745 | (setf (method-associativity meth) assoc) | |
| 746 | (setf (method-precedence meth) prec) | |
| 747 | (setf (method-form meth) form))))) | |
| 748 | ;; | |
| 749 | (push meth res))))) | |
| 741 | 750 | res)) |
| 742 | 751 | ||# |
| 743 | 752 | |
| 744 | 753 | (defun method-compress-overloaded-set (items &optional |
| 745 | (sort-order *current-sort-order*) | |
| 746 | (opinfo-table *current-opinfo-table*) | |
| 747 | (module *current-module*)) | |
| 754 | (sort-order *current-sort-order*) | |
| 755 | (opinfo-table *current-opinfo-table*) | |
| 756 | (module *current-module*)) | |
| 748 | 757 | (declare (type list items) |
| 749 | (type sort-order sort-order) | |
| 750 | (type hash-table opinfo-table) | |
| 751 | (type module module)) | |
| 758 | (type sort-order sort-order) | |
| 759 | (type hash-table opinfo-table) | |
| 760 | (type module module)) | |
| 752 | 761 | ;; |
| 753 | 762 | (let ((methods nil) |
| 754 | (res nil)) | |
| 755 | (dolist (i items) ; items may contain vairables | |
| 763 | (res nil)) | |
| 764 | (dolist (i items) ; items may contain vairables | |
| 756 | 765 | (if (and (operator-method-p i) |
| 757 | (method-arity i)) ; methods with more than 0 arities | |
| 758 | (push i methods) | |
| 759 | (push i res))) | |
| 766 | (method-arity i)) ; methods with more than 0 arities | |
| 767 | (push i methods) | |
| 768 | (push i res))) | |
| 760 | 769 | ;; compress methods |
| 761 | 770 | (dolist (method methods) |
| 762 | 771 | (block next-method |
| 763 | (let ((meth (method-select-most-general-version-of method | |
| 764 | methods | |
| 765 | sort-order | |
| 766 | opinfo-table | |
| 767 | module))) | |
| 768 | (unless (memq meth res) (push meth res))))) | |
| 772 | (let ((meth (method-select-most-general-version-of method | |
| 773 | methods | |
| 774 | sort-order | |
| 775 | opinfo-table | |
| 776 | module))) | |
| 777 | (unless (memq meth res) (push meth res))))) | |
| 769 | 778 | ;; |
| 770 | 779 | res)) |
| 771 | 780 | |
| 0 | 0 | ;;;-*-Mode:LISP; Package: CHAOS; Base:10; Syntax:Common-lisp -*- |
| 1 | 1 | ;;; |
| 2 | ;;; Copyright (c) 2000-2014, Toshimi Sawada. All rights reserved. | |
| 2 | ;;; Copyright (c) 2000-2015, Toshimi Sawada. All rights reserved. | |
| 3 | 3 | ;;; |
| 4 | 4 | ;;; Redistribution and use in source and binary forms, with or without |
| 5 | 5 | ;;; modification, are permitted provided that the following conditions |
| 27 | 27 | ;;; |
| 28 | 28 | (in-package :chaos) |
| 29 | 29 | #|============================================================================= |
| 30 | System:CHAOS | |
| 31 | Module:tools | |
| 32 | File:compat.lisp | |
| 30 | System:CHAOS | |
| 31 | Module:tools | |
| 32 | File:compat.lisp | |
| 33 | 33 | =============================================================================|# |
| 34 | 34 | #-:chaos-debug |
| 35 | 35 | (declaim (optimize (speed 3) (safety 0) #-GCL (debug 0))) |
| 39 | 39 | ;;; |
| 40 | 40 | ;;; CHECK COMPATIBILITY |
| 41 | 41 | ;;; |
| 42 | (defun check-compatibility (&optional (module (or *last-module* | |
| 43 | *current-module*))) | |
| 44 | (unless module | |
| 45 | (with-output-chaos-error ('no-context) | |
| 46 | (princ "no context (current) module is specified!") | |
| 47 | )) | |
| 48 | ;; | |
| 42 | (defun check-compatibility (&optional (module (get-context-module))) | |
| 49 | 43 | (unless *on-preparing-for-parsing* |
| 50 | 44 | (prepare-for-parsing module)) |
| 51 | ;; | |
| 52 | 45 | (with-in-module (module) |
| 53 | 46 | (let ((rules (module-all-rules module)) |
| 54 | (non-decreasing-rules nil)) | |
| 47 | (non-decreasing-rules nil)) | |
| 55 | 48 | ;; first, perform strong but light-weight check |
| 56 | 49 | (dolist (rule rules) |
| 57 | (unless (rule-is-builtin rule) | |
| 58 | (unless (sort<= (term-sort (rule-rhs rule)) | |
| 59 | (term-sort (rule-lhs rule))) | |
| 60 | (push rule non-decreasing-rules)))) | |
| 50 | (unless (rule-is-builtin rule) | |
| 51 | (unless (sort<= (term-sort (rule-rhs rule)) | |
| 52 | (term-sort (rule-lhs rule))) | |
| 53 | (push rule non-decreasing-rules)))) | |
| 61 | 54 | (unless non-decreasing-rules |
| 62 | (return-from check-compatibility nil)) | |
| 55 | (return-from check-compatibility nil)) | |
| 63 | 56 | ;; checks for each operations with non-decreasing rules. |
| 64 | 57 | (let ((ops (module-all-operators module)) |
| 65 | (non-compat-rules nil)) | |
| 66 | (dolist (rule non-decreasing-rules) | |
| 67 | (let ((lsort (term-sort (rule-lhs rule))) | |
| 68 | (rsort (term-sort (rule-rhs rule))) | |
| 69 | (e-methods nil)) | |
| 70 | (dolist (opinfo ops) | |
| 71 | (let* ((op (opinfo-operator opinfo)) | |
| 72 | (name (operator-symbol op))) | |
| 73 | (dolist (method (cdr (opinfo-methods opinfo))) | |
| 74 | (let ((pos-list nil) | |
| 75 | (m-arity (method-arity method))) | |
| 76 | (dotimes (x (length m-arity)) | |
| 77 | (when (sort<= lsort (nth x m-arity)) | |
| 78 | (push x pos-list))) | |
| 79 | (when pos-list | |
| 80 | (let ((new-arity (copy-list m-arity))) | |
| 81 | (dolist (x pos-list) | |
| 82 | (setf (nth x new-arity) rsort)) | |
| 83 | (unless (find-compat-method method name new-arity) | |
| 84 | (push method e-methods)))))))) | |
| 85 | (when e-methods | |
| 86 | (push (cons rule e-methods) non-compat-rules)) | |
| 87 | )) | |
| 88 | non-compat-rules)))) | |
| 58 | (non-compat-rules nil)) | |
| 59 | (dolist (rule non-decreasing-rules) | |
| 60 | (let ((lsort (term-sort (rule-lhs rule))) | |
| 61 | (rsort (term-sort (rule-rhs rule))) | |
| 62 | (e-methods nil)) | |
| 63 | (dolist (opinfo ops) | |
| 64 | (let* ((op (opinfo-operator opinfo)) | |
| 65 | (name (operator-symbol op))) | |
| 66 | (dolist (method (cdr (opinfo-methods opinfo))) | |
| 67 | (let ((pos-list nil) | |
| 68 | (m-arity (method-arity method))) | |
| 69 | (dotimes (x (length m-arity)) | |
| 70 | (when (sort<= lsort (nth x m-arity)) | |
| 71 | (push x pos-list))) | |
| 72 | (when pos-list | |
| 73 | (let ((new-arity (copy-list m-arity))) | |
| 74 | (dolist (x pos-list) | |
| 75 | (setf (nth x new-arity) rsort)) | |
| 76 | (unless (find-compat-method method name new-arity) | |
| 77 | (push method e-methods)))))))) | |
| 78 | (when e-methods | |
| 79 | (push (cons rule e-methods) non-compat-rules)) | |
| 80 | )) | |
| 81 | non-compat-rules)))) | |
| 89 | 82 | |
| 90 | 83 | (defun find-compat-method (method name arity) |
| 91 | 84 | (when *on-debug* |
| 92 | (format t "~&[find-compat-method] name = ~a, arity= " name) | |
| 85 | (format t "~%[find-compat-method] name = ~a, arity= " name) | |
| 93 | 86 | (print-sort-list arity)) |
| 94 | 87 | ;; |
| 95 | 88 | (let ((len (length arity))) |
| 96 | 89 | (dolist (opinfo (find-operators-in-module name len *current-module*) nil) |
| 97 | 90 | (dolist (meth (opinfo-methods opinfo)) |
| 98 | (let ((m-ari (method-arity meth))) | |
| 99 | (when (and (not (eq method meth)) | |
| 100 | (= len (length m-ari)) | |
| 101 | (every #'(lambda (x y) (sort<= x y)) | |
| 102 | arity | |
| 103 | (method-arity meth)) | |
| 104 | (not (method-is-error-method meth))) | |
| 105 | (when *on-debug* | |
| 106 | (format t "~&* found ") | |
| 107 | (print-chaos-object meth)) | |
| 108 | (return-from find-compat-method meth))))))) | |
| 91 | (let ((m-ari (method-arity meth))) | |
| 92 | (when (and (not (eq method meth)) | |
| 93 | (= len (length m-ari)) | |
| 94 | (every #'(lambda (x y) (sort<= x y)) | |
| 95 | arity | |
| 96 | (method-arity meth)) | |
| 97 | (not (method-is-error-method meth))) | |
| 98 | (when *on-debug* | |
| 99 | (format t "~%* found ") | |
| 100 | (print-chaos-object meth)) | |
| 101 | (return-from find-compat-method meth))))))) | |
| 109 | 102 | |
| 110 | 103 | ;;; EOF |
| 0 | 0 | ;;;-*- Mode:LISP; Package:CHAOS; Base:10; Syntax:Common-lisp -*- |
| 1 | 1 | ;;; |
| 2 | ;;; Copyright (c) 2000-2014, Toshimi Sawada. All rights reserved. | |
| 2 | ;;; Copyright (c) 2000-2015, Toshimi Sawada. All rights reserved. | |
| 3 | 3 | ;;; |
| 4 | 4 | ;;; Redistribution and use in source and binary forms, with or without |
| 5 | 5 | ;;; modification, are permitted provided that the following conditions |
| 27 | 27 | ;;; |
| 28 | 28 | (in-package :chaos) |
| 29 | 29 | #|============================================================================== |
| 30 | System: CHAOS | |
| 31 | Module: tools | |
| 32 | File: describe.lisp | |
| 30 | System: CHAOS | |
| 31 | Module: tools | |
| 32 | File: describe.lisp | |
| 33 | 33 | ==============================================================================|# |
| 34 | 34 | #-:chaos-debug |
| 35 | 35 | (declaim (optimize (speed 3) (safety 0) #-GCL (debug 0))) |
| 44 | 44 | ;;; |
| 45 | 45 | (defun filter-hard-sorts (sort-list) |
| 46 | 46 | (remove-if #'(lambda (x) (module-is-hard-wired (sort-module x))) |
| 47 | sort-list)) | |
| 47 | sort-list)) | |
| 48 | 48 | |
| 49 | 49 | (defun filter-hard-opinfos (opinfo-list) |
| 50 | 50 | (remove-if #'(lambda (x) (module-is-hard-wired |
| 51 | (operator-module (car x)))) | |
| 52 | opinfo-list)) | |
| 51 | (operator-module (car x)))) | |
| 52 | opinfo-list)) | |
| 53 | 53 | |
| 54 | 54 | (defparameter .separator-bold. |
| 55 | 55 | "======================================================================") |
| 74 | 74 | (princ .separator-bold.) |
| 75 | 75 | (print-next) |
| 76 | 76 | (let ((title |
| 77 | (with-output-to-string (str) | |
| 78 | (let ((*standard-output* str)) | |
| 79 | (princ "module ") | |
| 80 | (print-mod-name mod)) | |
| 81 | str))) | |
| 82 | (print-centering title)) | |
| 77 | (with-output-to-string (str) | |
| 78 | (let ((*standard-output* str)) | |
| 79 | (princ "module ") | |
| 80 | (print-mod-name mod)) | |
| 81 | str))) | |
| 82 | (print-centering title)) | |
| 83 | 83 | (print-next) |
| 84 | 84 | ;; ---------- kind |
| 85 | 85 | (case (module-kind mod) |
| 86 | (:theory (print-centering "kind: theory")) | |
| 87 | (:object (print-centering "kind: object")) | |
| 88 | (otherwise (print-centering "kind: loose"))) | |
| 86 | (:theory (print-centering "kind: theory")) | |
| 87 | (:object (print-centering "kind: object")) | |
| 88 | (otherwise (print-centering "kind: loose"))) | |
| 89 | 89 | (print-next) |
| 90 | 90 | ;;---------- type |
| 91 | 91 | (case (module-type mod) |
| 92 | (:user (print-centering "type: user defined")) | |
| 93 | (:system (print-centering "type: built-in module")) | |
| 94 | (:hard (print-centering "type: hard wired built-in")) | |
| 95 | (otherwise (print-centering "type: user defined"))) | |
| 92 | (:user (print-centering "type: user defined")) | |
| 93 | (:system (print-centering "type: built-in module")) | |
| 94 | (:hard (print-centering "type: hard wired built-in")) | |
| 95 | (otherwise (print-centering "type: user defined"))) | |
| 96 | 96 | (print-next) |
| 97 | 97 | ;; ---------- creation date |
| 98 | 98 | (if (module-creation-date mod) |
| 99 | (print-centering (concatenate 'string "created: " | |
| 100 | (get-time-string (module-creation-date mod)))) | |
| 101 | (print-centering "date defined: unknown")) | |
| 99 | (print-centering (concatenate 'string "created: " | |
| 100 | (get-time-string (module-creation-date mod)))) | |
| 101 | (print-centering "date defined: unknown")) | |
| 102 | 102 | (print-next) |
| 103 | 103 | ;; ---------- protected? |
| 104 | 104 | (when (module-is-write-protected mod) |
| 105 | (print-centering "* module is protected (disable redefinition) *") | |
| 106 | (print-next)) | |
| 105 | (print-centering "* module is protected (disable redefinition) *") | |
| 106 | (print-next)) | |
| 107 | 107 | ;; |
| 108 | 108 | (princ .separator-thin.) |
| 109 | 109 | (terpri) |
| 116 | 116 | ;; (print-module-parameters mod)) |
| 117 | 117 | ;; (print-next)) |
| 118 | 118 | (when (get-module-parameters mod) |
| 119 | (terpri) | |
| 120 | (print-centering "<< parameters >>") | |
| 121 | (let ((*print-indent* (+ 2 *print-indent*))) | |
| 122 | (print-module-parameters mod)) | |
| 123 | (print-next)) | |
| 119 | (terpri) | |
| 120 | (print-centering "<< parameters >>") | |
| 121 | (let ((*print-indent* (+ 2 *print-indent*))) | |
| 122 | (print-module-parameters mod)) | |
| 123 | (print-next)) | |
| 124 | 124 | |
| 125 | 125 | ;; ---------- direct submodules |
| 126 | 126 | (let ((subs (get-non-parameter-submodules mod))) |
| 127 | (when subs | |
| 128 | (terpri) | |
| 129 | (print-centering "<< submodules >>") | |
| 130 | (let ((*print-indent* (+ 2 *print-indent*))) | |
| 131 | (print-submodule-list subs)) | |
| 132 | (print-next))) | |
| 127 | (when subs | |
| 128 | (terpri) | |
| 129 | (print-centering "<< submodules >>") | |
| 130 | (let ((*print-indent* (+ 2 *print-indent*))) | |
| 131 | (print-submodule-list subs)) | |
| 132 | (print-next))) | |
| 133 | 133 | ;; ---------- sorts |
| 134 | 134 | (let ((sorts (if (module-is-hard-wired mod) |
| 135 | (module-all-sorts mod) | |
| 136 | (filter-hard-sorts (module-all-sorts mod))))) | |
| 137 | (when sorts | |
| 138 | (terpri) | |
| 139 | (print-centering "<< sorts and subsort relations >>") | |
| 140 | (let ((*print-indent* (+ 2 *print-indent*))) | |
| 141 | (print-module-sorts mod nil t) | |
| 142 | ) | |
| 143 | (print-next))) | |
| 135 | (module-all-sorts mod) | |
| 136 | (filter-hard-sorts (module-all-sorts mod))))) | |
| 137 | (when sorts | |
| 138 | (terpri) | |
| 139 | (print-centering "<< sorts and subsort relations >>") | |
| 140 | (let ((*print-indent* (+ 2 *print-indent*))) | |
| 141 | (print-module-sorts mod nil t) | |
| 142 | ) | |
| 143 | (print-next))) | |
| 144 | 144 | ;; ---------- variables |
| 145 | 145 | (let ((vars (mapcar #'cdr (module-variables mod))) |
| 146 | (rvars nil) | |
| 147 | (pvars nil)) | |
| 148 | (dolist (v vars) | |
| 149 | (if (term-is-variable? v) | |
| 150 | (push v rvars) | |
| 151 | (push v pvars))) | |
| 152 | (when rvars | |
| 153 | (terpri) | |
| 154 | (print-centering "<< variables >>") | |
| 155 | (let ((*print-indent* (+ 4 *print-indent*)) | |
| 156 | (*print-with-sort* t)) | |
| 157 | (print-next) | |
| 158 | (print-obj-list rvars))) | |
| 159 | (when pvars | |
| 160 | (terpri) | |
| 161 | (print-centering "<< psued variables >>") | |
| 162 | (let ((*print-indent* (+ 4 *print-indent*)) | |
| 163 | (*print-with-sort* t)) | |
| 164 | (print-next) | |
| 165 | (print-obj-list pvars))) | |
| 166 | (when (or rvars pvars) | |
| 167 | (print-next))) | |
| 146 | (rvars nil) | |
| 147 | (pvars nil)) | |
| 148 | (dolist (v vars) | |
| 149 | (if (term-is-variable? v) | |
| 150 | (push v rvars) | |
| 151 | (push v pvars))) | |
| 152 | (when rvars | |
| 153 | (terpri) | |
| 154 | (print-centering "<< variables >>") | |
| 155 | (let ((*print-indent* (+ 4 *print-indent*)) | |
| 156 | (*print-with-sort* t)) | |
| 157 | (print-next) | |
| 158 | (print-obj-list rvars))) | |
| 159 | (when pvars | |
| 160 | (terpri) | |
| 161 | (print-centering "<< psued variables >>") | |
| 162 | (let ((*print-indent* (+ 4 *print-indent*)) | |
| 163 | (*print-with-sort* t)) | |
| 164 | (print-next) | |
| 165 | (print-obj-list pvars))) | |
| 166 | (when (or rvars pvars) | |
| 167 | (print-next))) | |
| 168 | 168 | ;; ---------- operators & axioms |
| 169 | 169 | (when (module-all-operators mod) |
| 170 | (terpri) | |
| 171 | (print-centering "<< operators and axioms >>") | |
| 172 | (terpri) | |
| 173 | (terpri) | |
| 174 | (print-module-ops mod nil t)) | |
| 170 | (terpri) | |
| 171 | (print-centering "<< operators and axioms >>") | |
| 172 | (terpri) | |
| 173 | (terpri) | |
| 174 | (print-module-ops mod nil t)) | |
| 175 | 175 | ;; |
| 176 | 176 | (fresh-line) |
| 177 | 177 | (values) |
| 183 | 183 | ;;; |
| 184 | 184 | (defun describe-operator-brief (opinfo) |
| 185 | 185 | (let* ((op (opinfo-operator opinfo)) |
| 186 | (methods (opinfo-methods opinfo)) | |
| 187 | (header (with-output-to-string (n) | |
| 188 | (let ((*standard-output* n)) | |
| 189 | (princ (operator-symbol op)) | |
| 190 | ;; (princ (operator-print-name op)) | |
| 191 | (when (and *on-debug* | |
| 192 | (not (eq (operator-module op) *current-module*))) | |
| 193 | (princ ".") | |
| 194 | (print-mod-name (operator-module op) | |
| 195 | *standard-output* t t)) | |
| 196 | ;; attribute | |
| 197 | (let ((strat (let ((val (operator-strategy op))) | |
| 198 | (if (print-check-bu op val) nil val))) | |
| 199 | (thy (operator-theory op))) | |
| 200 | (when (or strat (not (eq (theory-info thy) the-e-property))) | |
| 201 | (let ((flag nil)) | |
| 202 | (princ " default attributes") (princ " { ") | |
| 203 | (when (not (eq (theory-info thy) the-e-property)) | |
| 204 | (setq flag t) | |
| 205 | (print-theory-brief thy)) | |
| 206 | (print-check) | |
| 207 | (when strat | |
| 208 | (if flag (princ " ") (setq flag t)) | |
| 209 | (princ "strat: ") (print-simple strat)) | |
| 210 | (print-check) | |
| 211 | (princ " }"))))) | |
| 212 | n)) | |
| 213 | ;; (n-len (length header)) | |
| 214 | ) | |
| 186 | (methods (opinfo-methods opinfo)) | |
| 187 | (header (with-output-to-string (n) | |
| 188 | (let ((*standard-output* n)) | |
| 189 | (princ (operator-symbol op)) | |
| 190 | ;; (princ (operator-print-name op)) | |
| 191 | (when (and *on-debug* | |
| 192 | (not (eq (operator-module op) *current-module*))) | |
| 193 | (princ ".") | |
| 194 | (print-mod-name (operator-module op) | |
| 195 | *standard-output* t t)) | |
| 196 | ;; attribute | |
| 197 | (let ((strat (let ((val (operator-strategy op))) | |
| 198 | (if (print-check-bu op val) nil val))) | |
| 199 | (thy (operator-theory op))) | |
| 200 | (when (or strat (not (eq (theory-info thy) the-e-property))) | |
| 201 | (let ((flag nil)) | |
| 202 | (princ " default attributes") (princ " { ") | |
| 203 | (when (not (eq (theory-info thy) the-e-property)) | |
| 204 | (setq flag t) | |
| 205 | (print-theory-brief thy)) | |
| 206 | (print-check) | |
| 207 | (when strat | |
| 208 | (if flag (princ " ") (setq flag t)) | |
| 209 | (princ "strat: ") (print-simple strat)) | |
| 210 | (print-check) | |
| 211 | (princ " }"))))) | |
| 212 | n)) | |
| 213 | ;; (n-len (length header)) | |
| 214 | ) | |
| 215 | 215 | (print-next) |
| 216 | 216 | (print-centering header ".") |
| 217 | 217 | #|| |
| 218 | 218 | (format t "~a" header) |
| 219 | 219 | (if (< n-len (- *print-line-limit* *print-indent*)) |
| 220 | (dotimes (x (- *print-line-limit* n-len *print-indent*)) | |
| 221 | (princ "_")) | |
| 222 | (princ "*")) | |
| 220 | (dotimes (x (- *print-line-limit* n-len *print-indent*)) | |
| 221 | (princ "_")) | |
| 222 | (princ "*")) | |
| 223 | 223 | ||# |
| 224 | 224 | ;; declarations with axioms |
| 225 | 225 | (let ((*print-indent* (+ 2 *print-indent*))) |
| 226 | 226 | (dolist (meth (reverse methods)) |
| 227 | (when (or (not (method-is-error-method meth)) | |
| 228 | (method-is-user-defined-error-method meth)) | |
| 229 | (print-next) | |
| 230 | (princ "* rank: ") | |
| 231 | (let ((arity (method-arity meth)) | |
| 232 | (coarity (method-coarity meth))) | |
| 233 | (when arity | |
| 234 | (print-sort-list arity *current-module*) | |
| 235 | (princ " ")) | |
| 236 | (princ "-> ") | |
| 237 | (print-sort-name coarity *current-module*) | |
| 238 | (when (and *on-debug* (not (eq *current-module* (method-module meth)))) | |
| 239 | (princ " (<== ") | |
| 240 | (print-mod-name (method-module meth) *standard-output* t t) | |
| 241 | (princ ")"))) | |
| 242 | (print-method-attrs meth "- attributes: ") | |
| 243 | (let ((axioms (method-all-rules meth))) | |
| 244 | (let ((*print-indent* (+ 2 *print-indent*))) | |
| 245 | (when axioms | |
| 246 | (print-next) | |
| 247 | (princ "- axioms:") | |
| 248 | (let ((*print-indent* (+ 2 *print-indent*))) | |
| 249 | (dolist (rl axioms) | |
| 250 | (print-next) | |
| 251 | (print-axiom-brief rl))))))))) | |
| 227 | (when (or (not (method-is-error-method meth)) | |
| 228 | (method-is-user-defined-error-method meth)) | |
| 229 | (print-next) | |
| 230 | (princ "* rank: ") | |
| 231 | (let ((arity (method-arity meth)) | |
| 232 | (coarity (method-coarity meth))) | |
| 233 | (when arity | |
| 234 | (print-sort-list arity *current-module*) | |
| 235 | (princ " ")) | |
| 236 | (princ "-> ") | |
| 237 | (print-sort-name coarity *current-module*) | |
| 238 | (when (and *on-debug* (not (eq *current-module* (method-module meth)))) | |
| 239 | (princ " (<== ") | |
| 240 | (print-mod-name (method-module meth) *standard-output* t t) | |
| 241 | (princ ")"))) | |
| 242 | (let ((*print-indent* (+ 2 *print-indent*))) | |
| 243 | (print-method-attrs meth "- attributes: ")) | |
| 244 | (let ((axioms (method-all-rules meth))) | |
| 245 | (let ((*print-indent* (+ 2 *print-indent*))) | |
| 246 | (when axioms | |
| 247 | (print-next) | |
| 248 | (princ "- axioms:") | |
| 249 | (let ((*print-indent* (+ 2 *print-indent*))) | |
| 250 | (dolist (rl axioms) | |
| 251 | (print-next) | |
| 252 | (print-axiom-brief rl))))))))) | |
| 252 | 253 | (flush-all) |
| 253 | 254 | )) |
| 254 | 255 | |
| 263 | 264 | (princ " declared in the module ") |
| 264 | 265 | (print-mod-name (sort-module sort)) |
| 265 | 266 | (let ((subs (subsorts sort)) |
| 266 | (supers (supersorts-no-err sort)) | |
| 267 | (*print-indent* (+ 2 *print-indent*))) | |
| 267 | (supers (supersorts-no-err sort)) | |
| 268 | (*print-indent* (+ 2 *print-indent*))) | |
| 268 | 269 | (when (or subs supers) |
| 269 | 270 | (print-next) |
| 270 | 271 | (princ "- subsort relations :") |
| 292 | 293 | (defun describe-operator (opinfo &optional (module *current-module*)) |
| 293 | 294 | (with-in-module (module) |
| 294 | 295 | (let* ((op (opinfo-operator opinfo)) |
| 295 | (syntax (operator-syntax op)) | |
| 296 | (prec (opsyntax-prec syntax)) | |
| 297 | (cprec (opsyntax-cprec syntax)) | |
| 298 | (theory (operator-theory op)) | |
| 299 | (assoc (opsyntax-assoc syntax)) | |
| 300 | (strat (operator-strategy op)) | |
| 301 | (methods (opinfo-methods opinfo))) | |
| 296 | (syntax (operator-syntax op)) | |
| 297 | (prec (opsyntax-prec syntax)) | |
| 298 | (cprec (opsyntax-cprec syntax)) | |
| 299 | (theory (operator-theory op)) | |
| 300 | (assoc (opsyntax-assoc syntax)) | |
| 301 | (strat (operator-strategy op)) | |
| 302 | (methods (opinfo-methods opinfo))) | |
| 302 | 303 | (fresh-line) |
| 303 | 304 | (dotimes (x .terminal-width.) (princ "=")) |
| 304 | 305 | ;; (format t "~%name : ~a" (operator-symbol op)) |
| 307 | 308 | (format t "~%number of arguments : ~d" (operator-num-args op)) |
| 308 | 309 | (format t "~%default attributes :") |
| 309 | 310 | (format t "~% rewrite strategy : ~a" (if strat strat |
| 310 | "not specified")) | |
| 311 | "not specified")) | |
| 311 | 312 | (format t "~% syntax :") |
| 312 | 313 | (when *on-debug* |
| 313 | (format t "~% type : ~s" (opsyntax-type syntax)) | |
| 314 | (format t "~% mixfix : ~s" (operator-is-mixfix op))) | |
| 314 | (format t "~% type : ~s" (opsyntax-type syntax)) | |
| 315 | (format t "~% mixfix : ~s" (operator-is-mixfix op))) | |
| 315 | 316 | (format t "~% precedence : ~a" (if prec prec "not specified")) |
| 316 | 317 | (unless (eql prec cprec) |
| 317 | (format t "~% computed prec. : ~s" cprec)) | |
| 318 | (format t "~% computed prec. : ~s" cprec)) | |
| 318 | 319 | (if assoc |
| 319 | (format t "~% assoc : ~s" (if (eq assoc :right) | |
| 320 | 'right | |
| 321 | 'left))) | |
| 320 | (format t "~% assoc : ~s" (if (eq assoc :right) | |
| 321 | 'right | |
| 322 | 'left))) | |
| 322 | 323 | (format t "~% form : ") |
| 323 | 324 | (let ((m (car methods))) |
| 324 | (dolist (x (method-form m)) | |
| 325 | (cond ((and (consp x) (eq (car x) 'argument)) | |
| 326 | (princ "(") | |
| 327 | (princ "arg:") | |
| 328 | (princ (second x)) | |
| 329 | ;; (print-sort-name (cddr x)) | |
| 330 | (princ ")")) | |
| 331 | ((and (consp x) (eq (car x) 'token)) | |
| 332 | (prin1 (string (cdr x)))) | |
| 333 | (t (princ x))) | |
| 334 | (princ " "))) | |
| 335 | (format t "~& theory : ") (print-theory-brief theory) | |
| 325 | (dolist (x (method-form m)) | |
| 326 | (cond ((and (consp x) (eq (car x) 'argument)) | |
| 327 | (princ "(") | |
| 328 | (princ "arg:") | |
| 329 | (princ (second x)) | |
| 330 | ;; (print-sort-name (cddr x)) | |
| 331 | (princ ")")) | |
| 332 | ((and (consp x) (eq (car x) 'token)) | |
| 333 | (prin1 (string (cdr x)))) | |
| 334 | (t (princ x))) | |
| 335 | (princ " "))) | |
| 336 | (format t "~% theory : ") (print-theory-brief theory) | |
| 336 | 337 | (when *on-debug* |
| 337 | (format t "~%internal name : ~s" (operator-print-name op))) | |
| 338 | (format t "~%internal name : ~s" (operator-print-name op))) | |
| 338 | 339 | |
| 339 | 340 | (let ((*print-indent* (+ *print-indent* 2))) |
| 340 | (dolist (m methods) | |
| 341 | (terpri) | |
| 342 | (dotimes (x .terminal-width.)(princ "-")) | |
| 343 | (format t "~&rank : ") | |
| 344 | (when (method-arity m) | |
| 345 | (print-sort-list (method-arity m) *current-module*) | |
| 346 | (princ " ")) | |
| 347 | (princ "-> ") | |
| 348 | (print-sort-name (method-coarity m) *current-module*) | |
| 349 | (when (or (method-constructor m) | |
| 350 | (method-has-memo m)) | |
| 351 | (princ " { ") | |
| 352 | (when (method-constructor m) | |
| 353 | (princ "constr ")) | |
| 354 | (when (method-has-memo m) | |
| 355 | (princ "memo ")) | |
| 356 | (when (method-is-meta-demod m) | |
| 357 | (princ "demod ")) | |
| 358 | (princ "}")) | |
| 359 | (print-next) | |
| 360 | (format t "module : ") | |
| 361 | (print-mod-name (method-module m)) | |
| 362 | (print-next) | |
| 363 | (format t "theory : ") | |
| 364 | (print-theory-brief (method-theory m)) | |
| 365 | (print-next) | |
| 366 | (format t "rewrite strategy : ~s" (method-rewrite-strategy m)) | |
| 367 | (when (not (eql prec (get-method-precedence m))) | |
| 368 | (print-next) | |
| 369 | (format t "precedence : ~d" (get-method-precedence m)) | |
| 370 | ) | |
| 371 | (when (not (equal assoc (method-associativity m))) | |
| 372 | (print-next) | |
| 373 | (format t "associativity : ~a" | |
| 374 | (case (method-associativity m) | |
| 375 | (:right "right") | |
| 376 | (:left "left") | |
| 377 | (otherwise "not specified"))) | |
| 378 | ) | |
| 379 | ;; lower methods | |
| 380 | (when (method-lower-methods m) | |
| 381 | (print-next) | |
| 382 | ;; (format t "lower declarations:") | |
| 383 | (format t "lower operations :") | |
| 384 | (let ((*print-indent* (+ 2 *print-indent*))) | |
| 385 | (dolist (x (reverse (method-lower-methods m))) | |
| 386 | (print-next) | |
| 387 | (when (method-arity x) | |
| 388 | (print-sort-list (method-arity x) *current-module*) | |
| 389 | (princ " ")) | |
| 390 | (princ "-> ") | |
| 391 | (print-sort-name (method-coarity x) *current-module*)))) | |
| 392 | (when *on-debug* | |
| 393 | ;; overloaded methods | |
| 394 | (let ((ov (nreverse (remove m (method-overloaded-methods m))))) | |
| 395 | (when ov | |
| 396 | (print-next) | |
| 397 | (format t "overloaded ops. :") | |
| 398 | (let ((*print-indent* (+ 2 *print-indent*))) | |
| 399 | (dolist (x ov) | |
| 400 | (print-next) | |
| 401 | (when (method-arity x) | |
| 402 | (print-sort-list (method-arity x) *current-module*) | |
| 403 | (princ " ")) | |
| 404 | (princ "-> ") | |
| 405 | (print-sort-name (method-coarity x) *current-module*)))))) | |
| 406 | ;; | |
| 407 | (when (method-derived-from m) | |
| 408 | (let ((o-m (method-derived-from m))) | |
| 409 | (print-next) | |
| 410 | (format t "derived from : ~s of " (method-symbol o-m)) | |
| 411 | (print-mod-name (method-module o-m) *standard-output* t t))) | |
| 412 | ;; axioms | |
| 413 | (print-next) | |
| 414 | (format t "axioms :") | |
| 415 | (let ((*print-indent* *print-indent*) | |
| 416 | (r-ring (method-rules-with-same-top m))) | |
| 417 | (unless (rule-ring-is-empty r-ring) | |
| 418 | (do ((ax (initialize-rule-ring r-ring) (rule-ring-next r-ring))) | |
| 419 | ((eq (rule-ring-current r-ring) (rule-ring-mark r-ring))) | |
| 420 | (print-next) | |
| 421 | (print-rule ax) | |
| 422 | )) | |
| 423 | (dolist (ax (method-rules-with-different-top m)) | |
| 424 | (print-next) | |
| 425 | (print-rule ax) | |
| 426 | )) | |
| 427 | )))) | |
| 341 | (dolist (m methods) | |
| 342 | (terpri) | |
| 343 | (dotimes (x .terminal-width.)(princ "-")) | |
| 344 | (format t "~%rank : ") | |
| 345 | (when (method-arity m) | |
| 346 | (print-sort-list (method-arity m) *current-module*) | |
| 347 | (princ " ")) | |
| 348 | (princ "-> ") | |
| 349 | (print-sort-name (method-coarity m) *current-module*) | |
| 350 | (when (or (method-constructor m) | |
| 351 | (method-has-memo m)) | |
| 352 | (princ " { ") | |
| 353 | (when (method-constructor m) | |
| 354 | (princ "constr ")) | |
| 355 | (when (method-has-memo m) | |
| 356 | (princ "memo ")) | |
| 357 | (when (method-is-meta-demod m) | |
| 358 | (princ "demod ")) | |
| 359 | (princ "}")) | |
| 360 | (print-next) | |
| 361 | (format t "module : ") | |
| 362 | (print-mod-name (method-module m)) | |
| 363 | (print-next) | |
| 364 | (format t "theory : ") | |
| 365 | (print-theory-brief (method-theory m)) | |
| 366 | (print-next) | |
| 367 | (format t "rewrite strategy : ~s" (method-rewrite-strategy m)) | |
| 368 | (when (not (eql prec (get-method-precedence m))) | |
| 369 | (print-next) | |
| 370 | (format t "precedence : ~d" (get-method-precedence m)) | |
| 371 | ) | |
| 372 | (when (not (equal assoc (method-associativity m))) | |
| 373 | (print-next) | |
| 374 | (format t "associativity : ~a" | |
| 375 | (case (method-associativity m) | |
| 376 | (:right "right") | |
| 377 | (:left "left") | |
| 378 | (otherwise "not specified"))) | |
| 379 | ) | |
| 380 | ;; lower methods | |
| 381 | (when (method-lower-methods m) | |
| 382 | (print-next) | |
| 383 | ;; (format t "lower declarations:") | |
| 384 | (format t "lower operations :") | |
| 385 | (let ((*print-indent* (+ 2 *print-indent*))) | |
| 386 | (dolist (x (reverse (method-lower-methods m))) | |
| 387 | (print-next) | |
| 388 | (when (method-arity x) | |
| 389 | (print-sort-list (method-arity x) *current-module*) | |
| 390 | (princ " ")) | |
| 391 | (princ "-> ") | |
| 392 | (print-sort-name (method-coarity x) *current-module*)))) | |
| 393 | (when *on-debug* | |
| 394 | ;; overloaded methods | |
| 395 | (let ((ov (nreverse (remove m (method-overloaded-methods m))))) | |
| 396 | (when ov | |
| 397 | (print-next) | |
| 398 | (format t "overloaded ops. :") | |
| 399 | (let ((*print-indent* (+ 2 *print-indent*))) | |
| 400 | (dolist (x ov) | |
| 401 | (print-next) | |
| 402 | (when (method-arity x) | |
| 403 | (print-sort-list (method-arity x) *current-module*) | |
| 404 | (princ " ")) | |
| 405 | (princ "-> ") | |
| 406 | (print-sort-name (method-coarity x) *current-module*)))))) | |
| 407 | ;; | |
| 408 | (when (method-derived-from m) | |
| 409 | (let ((o-m (method-derived-from m))) | |
| 410 | (print-next) | |
| 411 | (format t "derived from : ~s of " (method-symbol o-m)) | |
| 412 | (print-mod-name (method-module o-m) *standard-output* t t))) | |
| 413 | ;; axioms | |
| 414 | (print-next) | |
| 415 | (format t "axioms :") | |
| 416 | (let ((*print-indent* *print-indent*) | |
| 417 | (r-ring (method-rules-with-same-top m))) | |
| 418 | (unless (rule-ring-is-empty r-ring) | |
| 419 | (do ((ax (initialize-rule-ring r-ring) (rule-ring-next r-ring))) | |
| 420 | ((eq (rule-ring-current r-ring) (rule-ring-mark r-ring))) | |
| 421 | (print-next) | |
| 422 | (print-rule ax) | |
| 423 | )) | |
| 424 | (dolist (ax (method-rules-with-different-top m)) | |
| 425 | (print-next) | |
| 426 | (print-rule ax) | |
| 427 | )) | |
| 428 | )))) | |
| 428 | 429 | (flush-all)) |
| 429 | 430 | |
| 430 | 431 | (defun print-merged (mod) |
| 444 | 445 | (:cafeobj (show-module-in-cafeobj-syntax mod)) |
| 445 | 446 | (:chaos (show-module-in-chaos-syntax mod)) |
| 446 | 447 | (otherwise (with-output-panic-message () |
| 447 | (format t "illegal show mode ~s" syntax)) | |
| 448 | (return-from show-module nil)))) | |
| 448 | (format t "illegal show mode ~s" syntax)) | |
| 449 | (return-from show-module nil)))) | |
| 449 | 450 | |
| 450 | 451 | (defun ignore-from-import-list (mod) |
| 451 | 452 | (or (module-hidden mod) |
| 454 | 455 | (defun show-module-in-cafeobj-syntax (mod) |
| 455 | 456 | (with-in-module (mod) |
| 456 | 457 | (let* ((merged (print-merged mod)) |
| 457 | (mod-name (with-output-to-string (m) | |
| 458 | (if merged | |
| 459 | (print-mod-name *open-module* m nil t) | |
| 460 | (print-mod-name mod m nil t)) | |
| 461 | m)) | |
| 462 | (kind (module-kind mod)) | |
| 463 | (type (module-type mod)) | |
| 464 | (omit (if (or (memq type '(:system :hard)) | |
| 465 | (and merged (module-p *open-module*) | |
| 466 | (memq (module-type *open-module*) | |
| 467 | '(:system :hard)))) | |
| 468 | *kernel-hard-wired-builtin-modules* | |
| 469 | *print-ignore-mods*)) | |
| 470 | (*print-line-limit* 80)) | |
| 458 | (mod-name (with-output-to-string (m) | |
| 459 | (if merged | |
| 460 | (print-mod-name *open-module* m nil t) | |
| 461 | (print-mod-name mod m nil t)) | |
| 462 | m)) | |
| 463 | (kind (module-kind mod)) | |
| 464 | (type (module-type mod)) | |
| 465 | (omit (if (or (memq type '(:system :hard)) | |
| 466 | (and merged (module-p *open-module*) | |
| 467 | (memq (module-type *open-module*) | |
| 468 | '(:system :hard)))) | |
| 469 | *kernel-hard-wired-builtin-modules* | |
| 470 | *print-ignore-mods*)) | |
| 471 | (*print-line-limit* 80)) | |
| 471 | 472 | ;; |
| 472 | 473 | (fresh-line) |
| 473 | 474 | (print-indent #\space) |
| 474 | 475 | (case kind |
| 475 | (:object (case type | |
| 476 | (:hard (princ "hwd:mod! ")) | |
| 477 | (:system (princ "sys:mod! ")) | |
| 478 | (otherwise (princ "module! ")))) | |
| 479 | (:theory (case type | |
| 480 | (:hard (princ "hwd:mod* ")) | |
| 481 | (:system (princ "sys:mod* ")) | |
| 482 | (otherwise (princ "module* ")))) | |
| 483 | (otherwise (case type | |
| 484 | (:hard (princ "hwd:mod ")) | |
| 485 | (:system (princ "sys:mod ")) | |
| 486 | (otherwise (princ "module "))))) | |
| 476 | (:object (case type | |
| 477 | (:hard (princ "hwd:mod! ")) | |
| 478 | (:system (princ "sys:mod! ")) | |
| 479 | (otherwise (princ "module! ")))) | |
| 480 | (:theory (case type | |
| 481 | (:hard (princ "hwd:mod* ")) | |
| 482 | (:system (princ "sys:mod* ")) | |
| 483 | (otherwise (princ "module* ")))) | |
| 484 | (otherwise (case type | |
| 485 | (:hard (princ "hwd:mod ")) | |
| 486 | (:system (princ "sys:mod ")) | |
| 487 | (otherwise (princ "module "))))) | |
| 487 | 488 | (princ mod-name) |
| 488 | 489 | ;; PARAMETERS |
| 489 | 490 | (let ((params (get-module-parameters mod))) |
| 490 | (when params | |
| 491 | (let ((*print-indent* (+ (length mod-name) 9 *print-indent*))) | |
| 492 | ;; (princ " [") | |
| 493 | (princ " (") | |
| 494 | (let ((flg nil)) | |
| 495 | (dolist (sb params) | |
| 496 | (if flg (princ ", ") (setf flg t)) | |
| 497 | (print-check) | |
| 498 | (let ((mode (string-downcase | |
| 499 | (string (parameter-imported-mode sb)))) | |
| 500 | (arg-name (parameter-arg-name sb)) | |
| 501 | (cntxt (parameter-context sb))) | |
| 502 | (unless (equal "protecting" mode) | |
| 503 | (format t "~a " mode)) | |
| 504 | (if (or (null cntxt) (eq mod cntxt)) | |
| 505 | (format t "~a :: " arg-name) | |
| 506 | (progn | |
| 507 | (format t "~a." arg-name) | |
| 508 | (print-mod-name cntxt *standard-output* t t) | |
| 509 | (princ " :: "))) | |
| 510 | ;; (print-mod-name (cdar sb)) | |
| 511 | (print-parameter-theory-name (parameter-theory-module sb) | |
| 512 | *standard-output* | |
| 513 | :simple | |
| 514 | :no-param) | |
| 515 | ))) | |
| 516 | ;; (princ "]") | |
| 517 | (princ ")")))) | |
| 491 | (when params | |
| 492 | (let ((*print-indent* (+ (length mod-name) 9 *print-indent*))) | |
| 493 | ;; (princ " [") | |
| 494 | (princ " (") | |
| 495 | (let ((flg nil)) | |
| 496 | (dolist (sb params) | |
| 497 | (if flg (princ ", ") (setf flg t)) | |
| 498 | (print-check) | |
| 499 | (let ((mode (string-downcase | |
| 500 | (string (parameter-imported-mode sb)))) | |
| 501 | (arg-name (parameter-arg-name sb)) | |
| 502 | (cntxt (parameter-context sb))) | |
| 503 | (unless (equal "protecting" mode) | |
| 504 | (format t "~a " mode)) | |
| 505 | (if (or (null cntxt) (eq mod cntxt)) | |
| 506 | (format t "~a :: " arg-name) | |
| 507 | (progn | |
| 508 | (format t "~a." arg-name) | |
| 509 | (print-mod-name cntxt *standard-output* t t) | |
| 510 | (princ " :: "))) | |
| 511 | ;; (print-mod-name (cdar sb)) | |
| 512 | (print-parameter-theory-name (parameter-theory-module sb) | |
| 513 | *standard-output* | |
| 514 | :simple | |
| 515 | :no-param) | |
| 516 | ))) | |
| 517 | ;; (princ "]") | |
| 518 | (princ ")")))) | |
| 518 | 519 | ;; principal sort |
| 519 | 520 | (when (module-principal-sort mod) |
| 520 | (fresh-line) | |
| 521 | (format t " principal-sort ") | |
| 522 | (print-sort-name (module-principal-sort mod) mod)) | |
| 521 | (fresh-line) | |
| 522 | (format t " principal-sort ") | |
| 523 | (print-sort-name (module-principal-sort mod) mod)) | |
| 523 | 524 | (fresh-line) |
| 524 | 525 | ;; module body |
| 525 | 526 | (princ "{") |
| 526 | 527 | (when merged (princ " ** opening")) |
| 527 | 528 | (let ((*print-indent* (+ *print-indent* 2))) |
| 528 | ;; IMPORTING MODULES | |
| 529 | (let ((subs nil) | |
| 530 | (skip (if merged | |
| 531 | (nconc (list *open-module*) omit) | |
| 532 | omit))) | |
| 533 | (dolist (sub (module-submodules mod)) | |
| 534 | (when (and (not (module-is-parameter-theory (car sub))) | |
| 535 | (if *chaos-verbose* | |
| 536 | t | |
| 537 | (not (member (car sub) skip :key #'(lambda(x) | |
| 538 | (module-name x))))) | |
| 539 | (not (eq (cdr sub) :using))) | |
| 540 | (push sub subs))) | |
| 541 | (when subs | |
| 542 | (print-next) | |
| 543 | (princ "imports {") | |
| 544 | (let ((*print-indent* (+ *print-indent* 2))) | |
| 545 | (let ((flg nil)) | |
| 546 | (print-next) | |
| 547 | (dolist (sb subs) | |
| 548 | (unless (ignore-from-import-list (car sb)) | |
| 549 | (if flg (print-next) (setf flg t)) | |
| 550 | (print-check) | |
| 551 | ;; importation-mode | |
| 552 | (format t "~a " (string-downcase (string (cdr sb)))) | |
| 553 | ;; alias | |
| 554 | (let ((a-name (cdr (assoc (car sb) (module-alias mod))))) | |
| 555 | (when a-name | |
| 556 | (format t "as ~a " a-name))) | |
| 557 | ;; modexpr | |
| 558 | (let ((*print-indent* (+ 4 *print-indent* (length (string (cdr sb)))))) | |
| 559 | (princ "(") (print-mod-name (car sb) | |
| 560 | *standard-output* | |
| 561 | t | |
| 562 | t) | |
| 563 | (princ ")")))))) | |
| 564 | (print-next) | |
| 565 | (princ "}"))) | |
| 566 | ;; SIGNATURE | |
| 567 | (let ((sorts (sorts-to-be-shown mod *chaos-verbose*)) | |
| 568 | (opinfos (ops-to-be-shown mod *chaos-verbose*))) | |
| 569 | (when (or sorts opinfos) | |
| 570 | (print-next) | |
| 571 | (princ "signature {") | |
| 572 | (let ((*print-indent* (+ 2 *print-indent*))) | |
| 573 | ;; SORTS | |
| 574 | (when sorts | |
| 575 | (let ((hidden (remove-if-not #'(lambda (x) | |
| 576 | (sort-is-hidden x)) | |
| 577 | sorts)) | |
| 578 | (visible (remove-if #'(lambda (x) | |
| 579 | (sort-is-hidden x)) | |
| 580 | sorts))) | |
| 581 | (when hidden | |
| 582 | (print-next) | |
| 583 | ;; (princ "hidden [ ") | |
| 584 | (princ "*[ ") | |
| 585 | (let ((*print-indent* (+ 8 *print-indent*))) | |
| 586 | ;; (print-out-sorts hidden mod 'print-sort-name) | |
| 587 | (do ((ss hidden (cdr ss))) | |
| 588 | ((null ss)) | |
| 589 | (print-out-sort (car ss) mod 'print-sort-name) | |
| 590 | (when (cdr ss) (princ ",") (print-next))) | |
| 591 | (princ " ]*"))) | |
| 592 | (when visible | |
| 593 | (print-next) | |
| 594 | (let ((*print-indent* (+ 2 *print-indent*))) | |
| 595 | (princ "[ ") | |
| 596 | (do ((ss visible (cdr ss))) | |
| 597 | ((null ss)) | |
| 598 | (print-out-sort (car ss) mod 'print-sort-name) | |
| 599 | (when (cdr ss) (princ ",") (print-next))) | |
| 600 | (princ " ]"))))) | |
| 601 | ;; | |
| 602 | (when opinfos | |
| 603 | (dolist (op-meth opinfos) | |
| 604 | (print-op-meth op-meth mod *chaos-verbose*)))) | |
| 605 | (print-next) | |
| 606 | (princ "}"))) | |
| 607 | ;; AXIOMS | |
| 608 | (when (or *chaos-verbose* | |
| 609 | *print-all-eqns* | |
| 610 | (module-equations mod) | |
| 611 | (module-rules mod)) | |
| 612 | (print-next) | |
| 613 | (princ "axioms {") | |
| 614 | (let ((*print-indent* (+ 2 *print-indent*))) | |
| 615 | (when (module-variables mod) | |
| 616 | (dolist (v (reverse (module-variables mod))) | |
| 617 | (print-next) | |
| 618 | (if (term-is-variable? (cdr v)) | |
| 619 | (princ "var ") | |
| 620 | (princ "pvar ")) | |
| 621 | (princ (string (variable-name (cdr v)))) | |
| 622 | (princ " : ") | |
| 623 | (print-sort-name (variable-sort (cdr v)) mod))) | |
| 624 | (if (module-is-ready-for-rewriting mod) | |
| 625 | (if (not (or *chaos-verbose* *print-all-eqns*)) | |
| 626 | (dolist (r (append (reverse (module-equations mod)) | |
| 627 | (reverse (module-rules mod)))) | |
| 628 | (print-next) | |
| 629 | (print-axiom-brief r) (princ " .") | |
| 630 | #|| | |
| 631 | (dolist (er (!axiom-A-extensions r)) | |
| 632 | (when er (print-next) (print-axiom-brief er) (princ " ."))) | |
| 633 | (dolist (er (!axiom-AC-extension r)) | |
| 634 | (when er (print-next) (print-axiom-brief er) (princ " ."))) | |
| 635 | ||# | |
| 636 | (dolist (er (axiom-extensions r)) | |
| 637 | (when er (print-next) (print-axiom-brief er) (princ " ."))) | |
| 638 | ) | |
| 639 | ;; | |
| 640 | (dolist (r (get-module-axioms mod t)) | |
| 641 | (print-next) | |
| 642 | (print-axiom-brief r) (princ " .") | |
| 643 | #|| | |
| 644 | (dolist (er (!axiom-A-extensions r)) | |
| 645 | (when er (print-next) (print-axiom-brief er) (princ " ."))) | |
| 646 | (dolist (er (!axiom-AC-extension r)) | |
| 647 | (when er (print-next) (print-axiom-brief er) (princ " ."))) | |
| 648 | ||# | |
| 649 | (dolist (er (axiom-extensions r)) | |
| 650 | (when er (print-next) (print-axiom-brief er) (princ " ."))) | |
| 651 | )))) | |
| 652 | (print-next) | |
| 653 | (princ "}")) | |
| 654 | ;; done | |
| 655 | ) | |
| 529 | ;; IMPORTING MODULES | |
| 530 | (let ((subs nil) | |
| 531 | (skip (if merged | |
| 532 | (nconc (list *open-module*) omit) | |
| 533 | omit))) | |
| 534 | (dolist (sub (module-submodules mod)) | |
| 535 | (when (and (not (module-is-parameter-theory (car sub))) | |
| 536 | (if *chaos-verbose* | |
| 537 | t | |
| 538 | (not (member (car sub) skip :key #'(lambda(x) | |
| 539 | (module-name x))))) | |
| 540 | (not (eq (cdr sub) :using))) | |
| 541 | (push sub subs))) | |
| 542 | (when subs | |
| 543 | (print-next) | |
| 544 | (princ "imports {") | |
| 545 | (let ((*print-indent* (+ *print-indent* 2))) | |
| 546 | (let ((flg nil)) | |
| 547 | (print-next) | |
| 548 | (dolist (sb subs) | |
| 549 | (unless (ignore-from-import-list (car sb)) | |
| 550 | (if flg (print-next) (setf flg t)) | |
| 551 | (print-check) | |
| 552 | ;; importation-mode | |
| 553 | (format t "~a " (string-downcase (string (cdr sb)))) | |
| 554 | ;; alias | |
| 555 | (let ((a-name (cdr (assoc (car sb) (module-alias mod))))) | |
| 556 | (when a-name | |
| 557 | (format t "as ~a " a-name))) | |
| 558 | ;; modexpr | |
| 559 | (let ((*print-indent* (+ 4 *print-indent* (length (string (cdr sb)))))) | |
| 560 | (princ "(") (print-mod-name (car sb) | |
| 561 | *standard-output* | |
| 562 | t | |
| 563 | t) | |
| 564 | (princ ")")))))) | |
| 565 | (print-next) | |
| 566 | (princ "}"))) | |
| 567 | ;; SIGNATURE | |
| 568 | (let ((sorts (sorts-to-be-shown mod *chaos-verbose*)) | |
| 569 | (opinfos (ops-to-be-shown mod *chaos-verbose*))) | |
| 570 | (when (or sorts opinfos) | |
| 571 | (print-next) | |
| 572 | (princ "signature {") | |
| 573 | (let ((*print-indent* (+ 2 *print-indent*))) | |
| 574 | ;; SORTS | |
| 575 | (when sorts | |
| 576 | (let ((hidden (remove-if-not #'(lambda (x) | |
| 577 | (sort-is-hidden x)) | |
| 578 | sorts)) | |
| 579 | (visible (remove-if #'(lambda (x) | |
| 580 | (sort-is-hidden x)) | |
| 581 | sorts))) | |
| 582 | (when hidden | |
| 583 | (print-next) | |
| 584 | ;; (princ "hidden [ ") | |
| 585 | (princ "*[ ") | |
| 586 | (let ((*print-indent* (+ 8 *print-indent*))) | |
| 587 | ;; (print-out-sorts hidden mod 'print-sort-name) | |
| 588 | (do ((ss hidden (cdr ss))) | |
| 589 | ((null ss)) | |
| 590 | (print-out-sort (car ss) mod 'print-sort-name) | |
| 591 | (when (cdr ss) (princ ",") (print-next))) | |
| 592 | (princ " ]*"))) | |
| 593 | (when visible | |
| 594 | (print-next) | |
| 595 | (let ((*print-indent* (+ 2 *print-indent*))) | |
| 596 | (princ "[ ") | |
| 597 | (do ((ss visible (cdr ss))) | |
| 598 | ((null ss)) | |
| 599 | (print-out-sort (car ss) mod 'print-sort-name) | |
| 600 | (when (cdr ss) (princ ",") (print-next))) | |
| 601 | (princ " ]"))))) | |
| 602 | ;; | |
| 603 | (when opinfos | |
| 604 | (dolist (op-meth opinfos) | |
| 605 | (print-op-meth op-meth mod *chaos-verbose*)))) | |
| 606 | (print-next) | |
| 607 | (princ "}"))) | |
| 608 | ;; AXIOMS | |
| 609 | (when (or *chaos-verbose* | |
| 610 | *print-all-eqns* | |
| 611 | (module-equations mod) | |
| 612 | (module-rules mod)) | |
| 613 | (print-next) | |
| 614 | (princ "axioms {") | |
| 615 | (let ((*print-indent* (+ 2 *print-indent*))) | |
| 616 | (when (module-variables mod) | |
| 617 | (dolist (v (reverse (module-variables mod))) | |
| 618 | (print-next) | |
| 619 | (if (term-is-variable? (cdr v)) | |
| 620 | (princ "var ") | |
| 621 | (princ "pvar ")) | |
| 622 | (princ (string (variable-name (cdr v)))) | |
| 623 | (princ " : ") | |
| 624 | (print-sort-name (variable-sort (cdr v)) mod))) | |
| 625 | (if (module-is-ready-for-rewriting mod) | |
| 626 | (if (not (or *chaos-verbose* *print-all-eqns*)) | |
| 627 | (dolist (r (append (reverse (module-equations mod)) | |
| 628 | (reverse (module-rules mod)))) | |
| 629 | (print-next) | |
| 630 | (print-axiom-brief r) (princ " .") | |
| 631 | #|| | |
| 632 | (dolist (er (!axiom-A-extensions r)) | |
| 633 | (when er (print-next) (print-axiom-brief er) (princ " ."))) | |
| 634 | (dolist (er (!axiom-AC-extension r)) | |
| 635 | (when er (print-next) (print-axiom-brief er) (princ " ."))) | |
| 636 | ||# | |
| 637 | (dolist (er (axiom-extensions r)) | |
| 638 | (when er (print-next) (print-axiom-brief er) (princ " ."))) | |
| 639 | ) | |
| 640 | ;; | |
| 641 | (dolist (r (get-module-axioms mod t)) | |
| 642 | (print-next) | |
| 643 | (print-axiom-brief r) (princ " .") | |
| 644 | #|| | |
| 645 | (dolist (er (!axiom-A-extensions r)) | |
| 646 | (when er (print-next) (print-axiom-brief er) (princ " ."))) | |
| 647 | (dolist (er (!axiom-AC-extension r)) | |
| 648 | (when er (print-next) (print-axiom-brief er) (princ " ."))) | |
| 649 | ||# | |
| 650 | (dolist (er (axiom-extensions r)) | |
| 651 | (when er (print-next) (print-axiom-brief er) (princ " ."))) | |
| 652 | )))) | |
| 653 | (print-next) | |
| 654 | (princ "}")) | |
| 655 | ;; done | |
| 656 | ) | |
| 656 | 657 | (print-next) |
| 657 | 658 | (princ "}") |
| 658 | 659 | (fresh-line) |
| 659 | 660 | (flush-all) |
| 660 | 661 | (values)))) |
| 661 | ||
| 662 | ||
| 662 | 663 | (defun show-module-in-chaos-syntax (mod) |
| 663 | 664 | (with-in-module (mod) |
| 664 | 665 | (let ((*print-pretty* t)) |
| 665 | (format t "~&~s" (object-decl-form mod))))) | |
| 666 | (format t "~%~s" (object-decl-form mod))))) | |
| 666 | 667 | |
| 667 | 668 | ;;; PRINT-MODULE-SORTS |
| 668 | 669 | ;;;----------------------------------------------------------------------------- |
| 669 | 670 | (defun sorts-to-be-shown (mod &optional all) |
| 670 | 671 | (let ((sorts (if all (module-all-sorts mod) |
| 671 | (module-sorts mod)))) | |
| 672 | (module-sorts mod)))) | |
| 672 | 673 | (if (or (module-is-hard-wired mod) |
| 673 | (module-is-system-module mod)) | |
| 674 | sorts | |
| 675 | (filter-hard-sorts sorts)))) | |
| 674 | (module-is-system-module mod)) | |
| 675 | sorts | |
| 676 | (filter-hard-sorts sorts)))) | |
| 676 | 677 | |
| 677 | 678 | (defun print-module-sorts (mod &optional describe all) |
| 678 | 679 | (with-in-module (mod) |
| 679 | 680 | (let ((sorts (reverse (sorts-to-be-shown mod all)))) |
| 680 | 681 | (cond ((not describe) |
| 681 | (when (module-principal-sort mod) | |
| 682 | (print-next) | |
| 683 | (princ "* principal sort : ") | |
| 684 | (print-out-sorts (list (module-principal-sort mod)) mod | |
| 685 | 'print-sort-name)) | |
| 686 | (let ((hidden (remove-if-not #'(lambda (x) (sort-is-hidden x)) sorts)) | |
| 687 | (visible (remove-if #'(lambda (x) (sort-is-hidden x)) sorts))) | |
| 688 | (when hidden | |
| 689 | (print-next) | |
| 690 | (princ "* hidden sorts :") | |
| 691 | (let ((*print-indent* (+ *print-indent* 2))) | |
| 692 | (print-next) | |
| 693 | (print-out-sorts hidden mod 'print-sort-name))) | |
| 694 | (when visible | |
| 695 | (print-next) | |
| 696 | (princ "* visible sorts :") | |
| 697 | (let ((*print-indent* (+ *print-indent* 2))) | |
| 698 | (print-next) | |
| 699 | (print-out-sorts visible mod 'print-sort-name))))) | |
| 700 | ;; | |
| 701 | (t ; describe | |
| 702 | (dolist (s sorts) | |
| 703 | (print-next) | |
| 704 | (princ "----------------------------------------------------------------------") | |
| 705 | (print-next) | |
| 706 | (describe-sort s))))) | |
| 682 | (when (module-principal-sort mod) | |
| 683 | (print-next) | |
| 684 | (princ "* principal sort : ") | |
| 685 | (print-out-sorts (list (module-principal-sort mod)) mod | |
| 686 | 'print-sort-name)) | |
| 687 | (let ((hidden (remove-if-not #'(lambda (x) (sort-is-hidden x)) sorts)) | |
| 688 | (visible (remove-if #'(lambda (x) (sort-is-hidden x)) sorts))) | |
| 689 | (when hidden | |
| 690 | (print-next) | |
| 691 | (princ "* hidden sorts :") | |
| 692 | (let ((*print-indent* (+ *print-indent* 2))) | |
| 693 | (print-next) | |
| 694 | (print-out-sorts hidden mod 'print-sort-name))) | |
| 695 | (when visible | |
| 696 | (print-next) | |
| 697 | (princ "* visible sorts :") | |
| 698 | (let ((*print-indent* (+ *print-indent* 2))) | |
| 699 | (print-next) | |
| 700 | (print-out-sorts visible mod 'print-sort-name))))) | |
| 701 | ;; | |
| 702 | (t ; describe | |
| 703 | (dolist (s sorts) | |
| 704 | (print-next) | |
| 705 | (princ "----------------------------------------------------------------------") | |
| 706 | (print-next) | |
| 707 | (describe-sort s))))) | |
| 707 | 708 | (flush-all))) |
| 708 | 709 | |
| 709 | 710 | (defun print-out-sorts (sort-list mod &optional (printer 'print-sort-name)) |
| 714 | 715 | |
| 715 | 716 | (defun print-out-sort (s mod printer) |
| 716 | 717 | (let ((subs (direct-subsorts s)) |
| 717 | (sups (direct-supersorts-no-err s))) | |
| 718 | (sups (direct-supersorts-no-err s))) | |
| 718 | 719 | (funcall printer s mod) |
| 719 | 720 | (when (or subs sups) |
| 720 | 721 | (let ((*print-indent* (+ 2 *print-indent*))) |
| 721 | (princ ", ") | |
| 722 | (dolist (sub subs) | |
| 723 | (funcall printer sub mod) | |
| 724 | (princ " ")) | |
| 725 | (when subs (princ "< ")) | |
| 726 | (funcall printer s mod) | |
| 727 | (when sups | |
| 728 | (princ " <") | |
| 729 | (dolist (super sups) | |
| 730 | (princ " ") | |
| 731 | (funcall printer super mod))))) | |
| 722 | (princ ", ") | |
| 723 | (dolist (sub subs) | |
| 724 | (funcall printer sub mod) | |
| 725 | (princ " ")) | |
| 726 | (when subs (princ "< ")) | |
| 727 | (funcall printer s mod) | |
| 728 | (when sups | |
| 729 | (princ " <") | |
| 730 | (dolist (super sups) | |
| 731 | (princ " ") | |
| 732 | (funcall printer super mod))))) | |
| 732 | 733 | )) |
| 733 | 734 | |
| 734 | 735 | ;;; PRINT-MODULE-OPS |
| 737 | 738 | (let ((res nil)) |
| 738 | 739 | (with-in-module (mod) |
| 739 | 740 | (dolist (opinfo (reverse (module-all-operators mod))) |
| 740 | (let ((meth nil)) | |
| 741 | (dolist (m (opinfo-methods opinfo)) | |
| 742 | (when (and (eq (method-module m) mod) | |
| 743 | (or (not (method-is-error-method m)) | |
| 744 | (method-is-user-defined-error-method m))) | |
| 745 | (push m meth))) | |
| 746 | (when meth | |
| 747 | (push (list (opinfo-operator opinfo) meth) res)))) | |
| 741 | (let ((meth nil)) | |
| 742 | (dolist (m (opinfo-methods opinfo)) | |
| 743 | (when (and (eq (method-module m) mod) | |
| 744 | (or (not (method-is-error-method m)) | |
| 745 | (method-is-user-defined-error-method m))) | |
| 746 | (push m meth))) | |
| 747 | (when meth | |
| 748 | (push (list (opinfo-operator opinfo) meth) res)))) | |
| 748 | 749 | (nreverse res)))) |
| 749 | ||
| 750 | ||
| 750 | 751 | (defun ops-to-be-shown (mod &optional all) |
| 751 | 752 | (let ((ops (if all |
| 752 | (reverse (module-all-operators mod)) | |
| 753 | (module-own-op-methods mod)))) | |
| 753 | (reverse (module-all-operators mod)) | |
| 754 | (module-own-op-methods mod)))) | |
| 754 | 755 | (if (module-is-hard-wired mod) |
| 755 | ops | |
| 756 | (filter-hard-opinfos ops)))) | |
| 756 | ops | |
| 757 | (filter-hard-opinfos ops)))) | |
| 757 | 758 | |
| 758 | 759 | (defun print-module-ops (mod &optional describe all) |
| 759 | 760 | (with-in-module (mod) |
| 760 | 761 | (let ((ops (ops-to-be-shown mod all))) |
| 761 | 762 | (dolist (opinfo ops) |
| 762 | (if describe | |
| 763 | (describe-operator opinfo) | |
| 764 | (progn | |
| 765 | (print-next) | |
| 766 | (describe-operator-brief opinfo))))))) | |
| 763 | (if describe | |
| 764 | (describe-operator opinfo) | |
| 765 | (progn | |
| 766 | (print-next) | |
| 767 | (describe-operator-brief opinfo))))))) | |
| 767 | 768 | |
| 768 | 769 | ;;; PRINT-MODULE-EQS |
| 769 | 770 | ;;;----------------------------------------------------------------------------- |
| 772 | 773 | (when (module-equations mod) |
| 773 | 774 | (princ "equations : ") |
| 774 | 775 | (let ((*print-indent* (+ 2 *print-indent*))) |
| 775 | (dolist (r (module-equations mod)) | |
| 776 | (print-next) | |
| 777 | (if describe | |
| 778 | (print-rule r) | |
| 779 | (print-axiom-brief r))))))) | |
| 776 | (dolist (r (module-equations mod)) | |
| 777 | (print-next) | |
| 778 | (if describe | |
| 779 | (print-rule r) | |
| 780 | (print-axiom-brief r))))))) | |
| 780 | 781 | |
| 781 | 782 | ;;; PRINT-MODULE-RLS |
| 782 | 783 | ;;;----------------------------------------------------------------------------- |
| 785 | 786 | (when (module-rules mod) |
| 786 | 787 | (princ "rules : ") |
| 787 | 788 | (let ((*print-indent* (+ 2 *print-indent*))) |
| 788 | (dolist (r (module-rules mod)) | |
| 789 | (if describe | |
| 790 | (print-rule r) | |
| 791 | (print-axiom-brief r))))))) | |
| 789 | (dolist (r (module-rules mod)) | |
| 790 | (if describe | |
| 791 | (print-rule r) | |
| 792 | (print-axiom-brief r))))))) | |
| 792 | 793 | |
| 793 | 794 | ;;; PRINT-MODULE-AXS |
| 794 | 795 | ;;;----------------------------------------------------------------------------- |
| 795 | 796 | (defun print-module-axs (mod &optional describe) |
| 796 | 797 | (with-in-module (mod) |
| 797 | 798 | (let ((own-axs (module-own-axioms-ordered mod nil)) |
| 798 | (imp-axs (if (or *print-all-eqns* *module-all-rules-every*) | |
| 799 | (module-imported-axioms mod nil) | |
| 800 | nil)) | |
| 801 | (flg1 nil) | |
| 802 | (flg2 nil) | |
| 803 | (*print-indent* (+ 2 *print-indent*))) | |
| 799 | (imp-axs (if (or *print-all-eqns* *module-all-rules-every*) | |
| 800 | (module-imported-axioms mod nil) | |
| 801 | nil)) | |
| 802 | (flg1 nil) | |
| 803 | (flg2 nil) | |
| 804 | (*print-indent* (+ 2 *print-indent*))) | |
| 804 | 805 | (dolist (ax own-axs) |
| 805 | (if (and (null flg1) (memq (axiom-type ax) '(:equation | |
| 806 | :pignose-axiom | |
| 807 | :pignose-goal))) | |
| 808 | (progn | |
| 809 | (decf *print-indent* 2) | |
| 810 | (format t "~&- Equations") | |
| 811 | (incf *print-indent* 2) | |
| 812 | (setq flg1 t)) | |
| 813 | (if (and (null flg2) (eq (axiom-type ax) :rule)) | |
| 814 | (progn | |
| 815 | (decf *print-indent* 2) | |
| 816 | (format t "~&- Transitions") | |
| 817 | (incf *print-indent* 2) | |
| 818 | (setq flg2 t)))) | |
| 819 | (print-next) | |
| 820 | (if describe | |
| 821 | (print-rule ax) | |
| 822 | (print-axiom-brief ax))) | |
| 806 | (if (and (null flg1) (memq (axiom-type ax) '(:equation | |
| 807 | :pignose-axiom | |
| 808 | :pignose-goal))) | |
| 809 | (progn | |
| 810 | (decf *print-indent* 2) | |
| 811 | (format t "~%- Equations") | |
| 812 | (incf *print-indent* 2) | |
| 813 | (setq flg1 t)) | |
| 814 | (if (and (null flg2) (eq (axiom-type ax) :rule)) | |
| 815 | (progn | |
| 816 | (decf *print-indent* 2) | |
| 817 | (format t "~%- Transitions") | |
| 818 | (incf *print-indent* 2) | |
| 819 | (setq flg2 t)))) | |
| 820 | (print-next) | |
| 821 | (if describe | |
| 822 | (print-rule ax) | |
| 823 | (print-axiom-brief ax))) | |
| 823 | 824 | (when imp-axs |
| 824 | (decf *print-indent* 2) | |
| 825 | (format t "~&- Imported axioms") | |
| 826 | (incf *print-indent* 2) | |
| 827 | (dolist (ax imp-axs) | |
| 828 | (print-next) | |
| 829 | (if describe | |
| 830 | (print-rule ax) | |
| 831 | (print-axiom-brief ax)))) | |
| 832 | ))) | |
| 825 | (decf *print-indent* 2) | |
| 826 | (format t "~%- Imported axioms") | |
| 827 | (incf *print-indent* 2) | |
| 828 | (dolist (ax imp-axs) | |
| 829 | (print-next) | |
| 830 | (if describe | |
| 831 | (print-rule ax) | |
| 832 | (print-axiom-brief ax))))))) | |
| 833 | 833 | |
| 834 | 834 | ;;; PRINT-MODULE-RULES |
| 835 | 835 | ;;;----------------------------------------------------------------------------- |
| 838 | 838 | (dolist (r (module-rewrite-rules mod)) |
| 839 | 839 | (print-next) |
| 840 | 840 | (if describe |
| 841 | (print-rule r) | |
| 842 | (print-axiom-brief r))))) | |
| 841 | (print-rule r) | |
| 842 | (print-axiom-brief r))))) | |
| 843 | 843 | |
| 844 | 844 | ;;; PRINT-MODULE-SUBMODUES |
| 845 | 845 | ;;;----------------------------------------------------------------------------- |
| 846 | 846 | (defun get-non-parameter-submodules (mod) |
| 847 | 847 | (with-in-module (mod) |
| 848 | 848 | (let ((skip (mapcar #'cdar (module-parameters mod))) |
| 849 | (res nil)) | |
| 849 | (res nil)) | |
| 850 | 850 | (if (print-merged mod) |
| 851 | (push *open-module* skip)) | |
| 851 | (push *open-module* skip)) | |
| 852 | 852 | (dolist (sb (module-submodules mod)) |
| 853 | (unless (member (car sb) skip) | |
| 854 | (push sb res))) | |
| 853 | (unless (member (car sb) skip) | |
| 854 | (push sb res))) | |
| 855 | 855 | res))) |
| 856 | 856 | |
| 857 | 857 | (defun print-submodule-list (subs &optional describe) |
| 868 | 868 | (dolist (sb (get-non-parameter-submodules mod)) |
| 869 | 869 | (print-next) |
| 870 | 870 | (if (eq :using (cdr sb)) |
| 871 | (format t "-- ~a(" (string-downcase (string (cdr sb)))) | |
| 872 | (format t "~a(" (string-downcase (string (cdr sb))))) | |
| 871 | (format t "-- ~a(" (string-downcase (string (cdr sb)))) | |
| 872 | (format t "~a(" (string-downcase (string (cdr sb))))) | |
| 873 | 873 | (let ((*print-indent* (+ 2 *print-indent*))) |
| 874 | 874 | (print-mod-name (car sb) *standard-output* nil t)) |
| 875 | 875 | (princ ")"))) |
| 877 | 877 | ;;; PRINT-MODULE-PARAMETERS |
| 878 | 878 | ;;;----------------------------------------------------------------------------- |
| 879 | 879 | (defun print-module-parameters (mod &optional |
| 880 | (stream *standard-output*) | |
| 881 | (abbrev t)) | |
| 880 | (stream *standard-output*) | |
| 881 | (abbrev t)) | |
| 882 | 882 | (declare (ignore abbrev)) |
| 883 | 883 | (with-in-module (mod) |
| 884 | 884 | (let ((params (get-module-parameters mod))) |
| 885 | 885 | (if params |
| 886 | (progn | |
| 887 | (print-next) | |
| 888 | (let ((flag nil)) | |
| 889 | (dolist (x params) | |
| 890 | (let ((arg-name (parameter-arg-name x)) | |
| 891 | (cntxt (parameter-context x))) | |
| 892 | (if flag (print-next) (setq flag t)) | |
| 893 | (if (or (null cntxt) | |
| 894 | (eq mod cntxt)) | |
| 895 | (format t "* argument ~a : " arg-name) | |
| 896 | (progn | |
| 897 | (format t "* argument ~a." arg-name) | |
| 898 | (print-mod-name cntxt stream t t) | |
| 899 | (princ " : "))) | |
| 900 | (princ (string-downcase (string (parameter-imported-mode x)))) | |
| 901 | (princ " ") | |
| 902 | (force-output) | |
| 903 | (print-parameter-theory-name (parameter-theory-module x) | |
| 904 | stream | |
| 905 | nil | |
| 906 | :no-param))))) | |
| 907 | (princ "NONE."))) | |
| 886 | (progn | |
| 887 | (print-next) | |
| 888 | (let ((flag nil)) | |
| 889 | (dolist (x params) | |
| 890 | (let ((arg-name (parameter-arg-name x)) | |
| 891 | (cntxt (parameter-context x))) | |
| 892 | (if flag (print-next) (setq flag t)) | |
| 893 | (if (or (null cntxt) | |
| 894 | (eq mod cntxt)) | |
| 895 | (format t "* argument ~a : " arg-name) | |
| 896 | (progn | |
| 897 | (format t "* argument ~a." arg-name) | |
| 898 | (print-mod-name cntxt stream t t) | |
| 899 | (princ " : "))) | |
| 900 | (princ (string-downcase (string (parameter-imported-mode x)))) | |
| 901 | (princ " ") | |
| 902 | (force-output) | |
| 903 | (print-parameter-theory-name (parameter-theory-module x) | |
| 904 | stream | |
| 905 | nil | |
| 906 | :no-param))))) | |
| 907 | (princ "NONE."))) | |
| 908 | 908 | (print-next))) |
| 909 | 909 | |
| 910 | 910 | |
| 913 | 913 | (defun print-module-sort (mod srt &optional describe) |
| 914 | 914 | (with-in-module (mod) |
| 915 | 915 | (if describe |
| 916 | (describe-sort srt) | |
| 917 | (print-sort-name srt mod)))) | |
| 916 | (describe-sort srt) | |
| 917 | (print-sort-name srt mod)))) | |
| 918 | 918 | |
| 919 | 919 | ;;; PRINT-MODULE-VARIABLES |
| 920 | 920 | ;;;----------------------------------------------------------------------------- |
| 923 | 923 | (with-in-module (mod) |
| 924 | 924 | (when (module-variables mod) |
| 925 | 925 | (dolist (v (mapcar #'cdr (reverse (module-variables mod)))) |
| 926 | (if (term-is-variable? v) | |
| 927 | (princ "var ") | |
| 928 | (princ "pvar ")) | |
| 929 | (princ (string (variable-name v))) | |
| 930 | (princ " : ") | |
| 931 | (print-sort-name (variable-sort v) mod) | |
| 932 | (print-next))))) | |
| 926 | (if (term-is-variable? v) | |
| 927 | (princ "var ") | |
| 928 | (princ "pvar ")) | |
| 929 | (princ (string (variable-name v))) | |
| 930 | (princ " : ") | |
| 931 | (print-sort-name (variable-sort v) mod) | |
| 932 | (print-next))))) | |
| 933 | 933 | |
| 934 | 934 | ;;; EOF |
| 0 | 0 | ;;;-*- Mode:LISP; Package:CHAOS; Base:10; Syntax:Common-lisp -*- |
| 1 | 1 | ;;; |
| 2 | ;;; Copyright (c) 2000-2014, Toshimi Sawada. All rights reserved. | |
| 2 | ;;; Copyright (c) 2000-2015, Toshimi Sawada. All rights reserved. | |
| 3 | 3 | ;;; |
| 4 | 4 | ;;; Redistribution and use in source and binary forms, with or without |
| 5 | 5 | ;;; modification, are permitted provided that the following conditions |
| 28 | 28 | (in-package :chaos) |
| 29 | 29 | #|============================================================================== |
| 30 | 30 | System: CHAOS |
| 31 | Module: chaos/tools | |
| 31 | Module: chaos/tools | |
| 32 | 32 | File: help.lisp |
| 33 | 33 | ==============================================================================|# |
| 34 | 34 | #-:chaos-debug |
| 46 | 46 | (let* ((sdesc (gethash com-pat *Help-DB*)) |
| 47 | 47 | (syntax (first sdesc))) |
| 48 | 48 | (if sdesc |
| 49 | (concatenate 'string "~&[Syntax]: \"" syntax "\"~% " | |
| 49 | (concatenate 'string "~%[Syntax]: \"" syntax "\"~% " | |
| 50 | 50 | (if detail |
| 51 | 51 | (third sdesc) |
| 52 | 52 | (second sdesc))) |
| 0 | 0 | ;;;-*-Mode:LISP; Package: CHAOS; Base:10; Syntax:Common-lisp -*- |
| 1 | 1 | ;;; |
| 2 | ;;; Copyright (c) 2000-2014, Toshimi Sawada. All rights reserved. | |
| 2 | ;;; Copyright (c) 2000-2015, Toshimi Sawada. All rights reserved. | |
| 3 | 3 | ;;; |
| 4 | 4 | ;;; Redistribution and use in source and binary forms, with or without |
| 5 | 5 | ;;; modification, are permitted provided that the following conditions |
| 27 | 27 | ;;; |
| 28 | 28 | (in-package :chaos) |
| 29 | 29 | #|============================================================================= |
| 30 | System:CHAOS | |
| 31 | Module:tools | |
| 32 | File:inspect.lisp | |
| 30 | System:CHAOS | |
| 31 | Module:tools | |
| 32 | File:inspect.lisp | |
| 33 | 33 | =============================================================================|# |
| 34 | 34 | #-:chaos-debug |
| 35 | 35 | (declaim (optimize (speed 3) (safety 0) #-GCL (debug 0))) |
| 41 | 41 | ;;; |
| 42 | 42 | (defun show-module-symbol-table (mod &optional (stream *standard-output*)) |
| 43 | 43 | (let* ((st (module-symbol-table mod)) |
| 44 | (names (sort (copy-list (symbol-table-names st)) #'ob< ))) | |
| 44 | (names (sort (copy-list (symbol-table-names st)) #'ob< ))) | |
| 45 | 45 | (dolist (name names) |
| 46 | 46 | (describe-name mod name (symbol-table-get name mod) stream)))) |
| 47 | 47 | |
| 49 | 49 | |
| 50 | 50 | (defun describe-name (mod name tbl &optional (stream *standard-output*)) |
| 51 | 51 | (unless tbl |
| 52 | (format stream "~&No object with name ~A found." name) | |
| 52 | (format stream "~%No object with name ~A found." name) | |
| 53 | 53 | (return-from describe-name nil)) |
| 54 | 54 | (let ((*print-indent* 2) |
| 55 | (print-name (if (symbolp name) | |
| 56 | (string name) | |
| 57 | name))) | |
| 55 | (print-name (if (symbolp name) | |
| 56 | (string name) | |
| 57 | name))) | |
| 58 | 58 | (when (and (stringp print-name) |
| 59 | (not (eql .current-char-index. | |
| 60 | (char print-name 0)))) | |
| 59 | (not (eql .current-char-index. | |
| 60 | (char print-name 0)))) | |
| 61 | 61 | (setq .current-char-index. (char print-name 0)) |
| 62 | 62 | (format stream "~%** [~a] -----------------------------------------" |
| 63 | (string-upcase .current-char-index.))) | |
| 64 | (format stream "~&~A~10T" (if (symbolp name) | |
| 65 | (string name) | |
| 66 | name)) | |
| 63 | (string-upcase .current-char-index.))) | |
| 64 | (format stream "~%~A~10T" (if (symbolp name) | |
| 65 | (string name) | |
| 66 | name)) | |
| 67 | 67 | |
| 68 | 68 | (let ((parameters (stable-parameters tbl)) |
| 69 | (submodules (stable-submodules tbl)) | |
| 70 | (sorts (stable-sorts tbl)) | |
| 71 | (operators (stable-operators tbl)) | |
| 72 | (variables (stable-variables tbl)) | |
| 73 | (axioms (stable-axioms tbl)) | |
| 74 | (unknowns (stable-unknowns tbl))) | |
| 69 | (submodules (stable-submodules tbl)) | |
| 70 | (sorts (stable-sorts tbl)) | |
| 71 | (operators (stable-operators tbl)) | |
| 72 | (variables (stable-variables tbl)) | |
| 73 | (axioms (stable-axioms tbl)) | |
| 74 | (unknowns (stable-unknowns tbl))) | |
| 75 | 75 | (when parameters |
| 76 | (inspect-show-parameters mod name parameters stream)) | |
| 76 | (inspect-show-parameters mod name parameters stream)) | |
| 77 | 77 | (when submodules |
| 78 | (inspect-show-submodules mod name submodules stream)) | |
| 78 | (inspect-show-submodules mod name submodules stream)) | |
| 79 | 79 | (when sorts |
| 80 | (inspect-show-sorts mod name sorts stream)) | |
| 80 | (inspect-show-sorts mod name sorts stream)) | |
| 81 | 81 | (when operators |
| 82 | (inspect-show-operators mod name operators stream)) | |
| 82 | (inspect-show-operators mod name operators stream)) | |
| 83 | 83 | (when variables |
| 84 | (inspect-show-variables mod name variables stream)) | |
| 84 | (inspect-show-variables mod name variables stream)) | |
| 85 | 85 | (when axioms |
| 86 | (inspect-show-axioms mod name axioms stream)) | |
| 86 | (inspect-show-axioms mod name axioms stream)) | |
| 87 | 87 | (when unknowns |
| 88 | (inspect-show-unknowns mod name unknowns stream))))) | |
| 88 | (inspect-show-unknowns mod name unknowns stream))))) | |
| 89 | 89 | |
| 90 | 90 | ;;; |
| 91 | 91 | ;;; |
| 98 | 98 | (print-next) |
| 99 | 99 | (format stream "- parameter theory ~A(type ~S)" name (type-of name)) |
| 100 | 100 | (when context-name |
| 101 | (format stream ", declared in ~A" context-name))))) | |
| 101 | (format stream ", declared in ~A" context-name))))) | |
| 102 | 102 | |
| 103 | 103 | (defun inspect-show-submodules (mod name objs stream) |
| 104 | 104 | (dolist (obj objs) |
| 105 | 105 | (let ((context-name (get-context-name-extended obj)) |
| 106 | (alias (if (symbolp name) | |
| 107 | (rassoc (string name) (module-alias mod) :test #'equal) | |
| 108 | nil))) | |
| 106 | (alias (if (symbolp name) | |
| 107 | (rassoc (string name) (module-alias mod) :test #'equal) | |
| 108 | nil))) | |
| 109 | 109 | (print-next) |
| 110 | 110 | (cond ((assoc obj (module-submodules mod)) |
| 111 | (format stream "- direct sub-module") | |
| 112 | (when alias | |
| 113 | (format stream ", alias of module ") | |
| 114 | (print-modexp (module-name (car alias)) stream t))) | |
| 115 | ((module-is-parameter-theory obj) | |
| 116 | (format stream "- parameter theory")) | |
| 117 | (t (format stream "- indirect sub-module") | |
| 118 | (when alias | |
| 119 | (format stream ", alias of module ") | |
| 120 | (print-modexp (module-name (car alias)) stream t)))) | |
| 111 | (format stream "- direct sub-module") | |
| 112 | (when alias | |
| 113 | (format stream ", alias of module ") | |
| 114 | (print-modexp (module-name (car alias)) stream t))) | |
| 115 | ((module-is-parameter-theory obj) | |
| 116 | (format stream "- parameter theory")) | |
| 117 | (t (format stream "- indirect sub-module") | |
| 118 | (when alias | |
| 119 | (format stream ", alias of module ") | |
| 120 | (print-modexp (module-name (car alias)) stream t)))) | |
| 121 | 121 | (when context-name |
| 122 | (format stream ", declared in ~A" context-name)) | |
| 122 | (format stream ", declared in ~A" context-name)) | |
| 123 | 123 | (let ((alias (assoc name (module-alias mod)))) |
| 124 | (when alias | |
| 125 | (format stream ", renamed (original name = ~a)." | |
| 126 | (with-output-to-string (str) | |
| 127 | (print-mod-name obj str t)))))))) | |
| 124 | (when alias | |
| 125 | (format stream ", renamed (original name = ~a)." | |
| 126 | (with-output-to-string (str) | |
| 127 | (print-mod-name obj str t)))))))) | |
| 128 | 128 | |
| 129 | 129 | (defun get-context-name-for-qualify (obj) |
| 130 | 130 | (let ((cmod (object-context-mod obj))) |
| 131 | 131 | (unless cmod |
| 132 | 132 | (with-output-chaos-error ('no-context) |
| 133 | (format t "Internal error : no context found for object ~s" obj))) | |
| 133 | (format t "Internal error : no context found for object ~s" obj))) | |
| 134 | 134 | (let ((qname (get-module-print-name cmod))) |
| 135 | 135 | (unless (module-is-parameter-theory cmod) |
| 136 | (return-from get-context-name-for-qualify qname)) | |
| 136 | (return-from get-context-name-for-qualify qname)) | |
| 137 | 137 | (car qname)))) |
| 138 | 138 | |
| 139 | 139 | (defun inspect-show-sorts (mod name objs stream) |
| 140 | 140 | (dolist (obj objs) |
| 141 | 141 | (print-next) |
| 142 | 142 | (let ((context-name (get-context-name-extended obj)) |
| 143 | (ambig (cdr objs))) | |
| 143 | (ambig (cdr objs))) | |
| 144 | 144 | (if (sort-is-hidden obj) |
| 145 | (format stream "- hidden sort declared in ~a" context-name) | |
| 146 | (format stream "- sort declared in ~a" context-name)) | |
| 145 | (format stream "- hidden sort declared in ~a" context-name) | |
| 146 | (format stream "- sort declared in ~a" context-name)) | |
| 147 | 147 | (when ambig |
| 148 | (let ((qname (get-context-name-for-qualify obj))) | |
| 149 | ;; must be qualified | |
| 150 | (cond ((modexp-is-simple-name qname) | |
| 151 | (print-next) | |
| 152 | (format stream " the name must be qualified for disambiguation: ~A.~A" | |
| 153 | (string name) qname)) | |
| 154 | (t (let ((a-name (rassoc (object-context-mod obj) | |
| 155 | (module-alias mod)))) | |
| 156 | (cond (a-name | |
| 157 | (print-next) | |
| 158 | (format stream " the name must be qualified for disambiguation: ~A.~A" | |
| 159 | (string name) (car a-name))) | |
| 160 | (t | |
| 161 | (print-next) | |
| 162 | (format stream " the name must be qualified for disambiguation,") | |
| 163 | (print-next) | |
| 164 | (format stream " but the module name is not simple one:") | |
| 165 | (print-mod-name (object-context-mod obj) | |
| 166 | stream))))))))))) | |
| 148 | (let ((qname (get-context-name-for-qualify obj))) | |
| 149 | ;; must be qualified | |
| 150 | (cond ((modexp-is-simple-name qname) | |
| 151 | (print-next) | |
| 152 | (format stream " the name must be qualified for disambiguation: ~A.~A" | |
| 153 | (string name) qname)) | |
| 154 | (t (let ((a-name (rassoc (object-context-mod obj) | |
| 155 | (module-alias mod)))) | |
| 156 | (cond (a-name | |
| 157 | (print-next) | |
| 158 | (format stream " the name must be qualified for disambiguation: ~A.~A" | |
| 159 | (string name) (car a-name))) | |
| 160 | (t | |
| 161 | (print-next) | |
| 162 | (format stream " the name must be qualified for disambiguation,") | |
| 163 | (print-next) | |
| 164 | (format stream " but the module name is not simple one:") | |
| 165 | (print-mod-name (object-context-mod obj) | |
| 166 | stream))))))))))) | |
| 167 | 167 | |
| 168 | 168 | (defun inspect-show-operators (mod name objs stream) |
| 169 | 169 | (declare (ignore name)) |
| 172 | 172 | (format stream "- operator:") |
| 173 | 173 | (let ((*print-indent* (+ *print-indent* 2))) |
| 174 | 174 | (print-op-brief obj mod t t t)))) |
| 175 | ||
| 175 | ||
| 176 | 176 | (defun inspect-show-axioms (mod name objs stream) |
| 177 | 177 | (declare (ignore name mod)) |
| 178 | 178 | (dolist (obj objs) |
| 180 | 180 | (let ((context-name (get-context-name-extended obj))) |
| 181 | 181 | (format stream "- axiom declared in ~a" context-name) |
| 182 | 182 | (let ((*print-indent* (+ *print-indent* 2))) |
| 183 | (print-next) | |
| 184 | (print-axiom-brief obj stream))))) | |
| 183 | (print-next) | |
| 184 | (print-axiom-brief obj stream))))) | |
| 185 | 185 | |
| 186 | 186 | (defun inspect-show-variables (mod name objs stream) |
| 187 | 187 | (declare (ignore name)) |
| 188 | 188 | (dolist (obj objs) |
| 189 | 189 | (print-next) |
| 190 | 190 | (format stream "- variable of sort ~a" |
| 191 | (with-output-to-string (str) | |
| 192 | (print-sort-name (variable-sort obj) mod str))))) | |
| 191 | (with-output-to-string (str) | |
| 192 | (print-sort-name (variable-sort obj) mod str))))) | |
| 193 | 193 | |
| 194 | 194 | (defun inspect-show-unknowns (mod name objs stream) |
| 195 | 195 | (declare (ignore mod name)) |
| 214 | 214 | (defun inspect-canon-name (name) |
| 215 | 215 | (if (stringp name) |
| 216 | 216 | (let ((sname (parse-with-delimiter2 name #\_))) |
| 217 | (if (stringp sname) | |
| 218 | sname | |
| 219 | (remove "" sname :test #'equal))) | |
| 217 | (if (stringp sname) | |
| 218 | sname | |
| 219 | (remove "" sname :test #'equal))) | |
| 220 | 220 | (mapcan #'inspect-canon-name |
| 221 | (remove ")" (remove "(" name :test #'equal) :test #'equal)))) | |
| 221 | (remove ")" (remove "(" name :test #'equal) :test #'equal)))) | |
| 222 | 222 | |
| 223 | 223 | (defun !look-up (name module) |
| 224 | 224 | (declare (ignore ignore)) |
| 228 | 228 | (with-in-module (module) |
| 229 | 229 | (let ((nm (inspect-canon-name name))) |
| 230 | 230 | (describe-name module |
| 231 | (canonicalize-object-name nm) | |
| 232 | (symbol-table-get nm module) | |
| 233 | *standard-output*)))) | |
| 231 | (canonicalize-object-name nm) | |
| 232 | (symbol-table-get nm module) | |
| 233 | *standard-output*)))) | |
| 234 | 234 | |
| 235 | 235 | ;;; EOF |
| 0 | 0 | ;;;-*- Mode:LISP; Package:CHAOS; Base:10; Syntax:Common-lisp -*- |
| 1 | 1 | ;;; |
| 2 | ;;; Copyright (c) 2000-2014, Toshimi Sawada. All rights reserved. | |
| 2 | ;;; Copyright (c) 2000-2015, Toshimi Sawada. All rights reserved. | |
| 3 | 3 | ;;; |
| 4 | 4 | ;;; Redistribution and use in source and binary forms, with or without |
| 5 | 5 | ;;; modification, are permitted provided that the following conditions |
| 27 | 27 | ;;; |
| 28 | 28 | (in-package :chaos) |
| 29 | 29 | #|============================================================================== |
| 30 | System: CHAOS | |
| 31 | Module: tools | |
| 32 | File: module-tree.lisp | |
| 30 | System: CHAOS | |
| 31 | Module: tools | |
| 32 | File: module-tree.lisp | |
| 33 | 33 | ==============================================================================|# |
| 34 | 34 | #-:chaos-debug |
| 35 | 35 | (declaim (optimize (speed 3) (safety 0) #-GCL (debug 0))) |
| 40 | 40 | |
| 41 | 41 | (defun make-submodule-tree (mod) |
| 42 | 42 | (mapcar #'(lambda (x) |
| 43 | (cons x (make-submodule-tree (car x)))) | |
| 44 | (module-direct-submodules mod))) | |
| 43 | (cons x (make-submodule-tree (car x)))) | |
| 44 | (module-direct-submodules mod))) | |
| 45 | 45 | |
| 46 | 46 | (defun make-module-tree (mod) |
| 47 | 47 | (cons (list mod) (make-submodule-tree mod))) |
| 60 | 60 | |
| 61 | 61 | (defun !print-module-tree (mod stream show-as-graph) |
| 62 | 62 | (let* ((leaf? #'(lambda (tree) (null (dag-node-subnodes tree)))) |
| 63 | (leaf-name #'(lambda (tree) | |
| 64 | (with-output-to-string (str) | |
| 65 | (let ((datum (dag-node-datum tree))) | |
| 66 | (case (cdr datum) | |
| 67 | (:protecting (princ "pr(" str)) | |
| 68 | (:extending (princ "ex(" str)) | |
| 69 | (:using (princ "us(" str)) | |
| 70 | (:including (princ "inc(" str)) | |
| 71 | (:modmorph (princ "!(" str))) | |
| 72 | (print-mod-name-x (car datum) str t nil) | |
| 73 | (when (cdr datum) (princ ")" str))) | |
| 74 | str))) | |
| 75 | (leaf-info #'(lambda (tree) (declare (ignore tree)) t)) | |
| 76 | (int-node-name #'(lambda (tree) (funcall leaf-name tree))) | |
| 77 | (int-node-children #'(lambda (tree) | |
| 78 | (let ((subs nil)) | |
| 79 | (dolist (sub-node (dag-node-subnodes tree)) | |
| 80 | (let ((datum (dag-node-datum sub-node))) | |
| 81 | (when (and (module-p (car datum)) | |
| 82 | (not (module-is-parameter-theory | |
| 83 | (car datum))) | |
| 84 | (not (memq (car datum) | |
| 85 | *kernel-hard-wired-builtin-modules*)) | |
| 86 | (not (memq (cdr datum) | |
| 87 | '(:view :modmorph)))) | |
| 88 | (push sub-node subs)))) | |
| 89 | subs)))) ;; #'(lambda (tree) (dag-node-subnodes tree)) | |
| 63 | (leaf-name #'(lambda (tree) | |
| 64 | (with-output-to-string (str) | |
| 65 | (let ((datum (dag-node-datum tree))) | |
| 66 | (case (cdr datum) | |
| 67 | (:protecting (princ "pr(" str)) | |
| 68 | (:extending (princ "ex(" str)) | |
| 69 | (:using (princ "us(" str)) | |
| 70 | (:including (princ "inc(" str)) | |
| 71 | (:modmorph (princ "!(" str))) | |
| 72 | (print-mod-name-x (car datum) str t nil) | |
| 73 | (when (cdr datum) (princ ")" str))) | |
| 74 | str))) | |
| 75 | (leaf-info #'(lambda (tree) (declare (ignore tree)) t)) | |
| 76 | (int-node-name #'(lambda (tree) (funcall leaf-name tree))) | |
| 77 | (int-node-children #'(lambda (tree) | |
| 78 | (let ((subs nil)) | |
| 79 | (dolist (sub-node (dag-node-subnodes tree)) | |
| 80 | (let ((datum (dag-node-datum sub-node))) | |
| 81 | (when (and (module-p (car datum)) | |
| 82 | (not (module-is-parameter-theory | |
| 83 | (car datum))) | |
| 84 | (not (memq (car datum) | |
| 85 | *kernel-hard-wired-builtin-modules*)) | |
| 86 | (not (memq (cdr datum) | |
| 87 | '(:view :modmorph)))) | |
| 88 | (push sub-node subs)))) | |
| 89 | subs)))) ;; #'(lambda (tree) (dag-node-subnodes tree)) | |
| 90 | 90 | (force-output stream) |
| 91 | 91 | (print-next nil *print-indent* stream) |
| 92 | 92 | (print-trees (list (if show-as-graph |
| 93 | (augment-tree-as-graph (module-dag mod)) | |
| 94 | (augment-tree (module-dag mod)))) | |
| 95 | stream))) | |
| 93 | (augment-tree-as-graph (module-dag mod)) | |
| 94 | (augment-tree (module-dag mod)))) | |
| 95 | stream))) | |
| 96 | 96 | |
| 97 | 97 | ;;; MODULE EXPRESSION TREE |
| 98 | 98 | |
| 99 | 99 | (defun get-modexp-children (modexp) |
| 100 | 100 | (cond ((chaos-ast? modexp) |
| 101 | (case (ast-type modexp) | |
| 102 | ((%ren-sort %ren-op %ren-var %ren-param %+) | |
| 103 | (remove nil (third modexp))) | |
| 104 | (%rmap nil) | |
| 105 | (%! (remove nil `(,(%instantiation-module modexp) | |
| 106 | ,@(%instantiation-args modexp)))) | |
| 107 | ((%view %view-from) | |
| 108 | (remove-if #'(lambda (x) (or (eq x 'none) (null x))) (cdr modexp))) | |
| 109 | (otherwise (remove nil (cdr modexp))))) | |
| 110 | (t nil))) | |
| 101 | (case (ast-type modexp) | |
| 102 | ((%ren-sort %ren-op %ren-var %ren-param %+) | |
| 103 | (remove nil (third modexp))) | |
| 104 | (%rmap nil) | |
| 105 | (%! (remove nil `(,(%instantiation-module modexp) | |
| 106 | ,@(%instantiation-args modexp)))) | |
| 107 | ((%view %view-from) | |
| 108 | (remove-if #'(lambda (x) (or (eq x 'none) (null x))) (cdr modexp))) | |
| 109 | (otherwise (remove nil (cdr modexp))))) | |
| 110 | (t nil))) | |
| 111 | 111 | |
| 112 | 112 | (defun print-modexp-tree (modexp &optional (stream *standard-output*)) |
| 113 | 113 | (let* ((leaf? #'(lambda (tree) (or (%is-rmap tree) (not (chaos-ast? tree))))) |
| 114 | (leaf-name #'(lambda (tree) | |
| 115 | (cond ((chaos-ast? tree) | |
| 116 | (case (ast-type tree) | |
| 117 | (%! "_[_]") | |
| 118 | (%!arg "_<=_") | |
| 119 | (%* "_*_") | |
| 120 | (%+ "_+_") | |
| 121 | ((%view %view-from) "view_") | |
| 122 | (%rmap "{_}") | |
| 123 | (%ren-sort "sort_->_") | |
| 124 | (%ren-op "op_->_") | |
| 125 | (%ren-param "param_->_") | |
| 126 | (otherwise "??"))) | |
| 127 | ((and (consp tree) (eq (car tree) ':?name)) | |
| 128 | (cdr tree)) | |
| 129 | ((and (consp tree) (null (cdr tree))) | |
| 130 | (car tree)) | |
| 131 | (t tree)))) | |
| 132 | (leaf-info #'(lambda (tree) (declare (ignore tree)) t)) | |
| 133 | (int-node-name #'(lambda (tree) (funcall leaf-name tree))) | |
| 134 | (int-node-children #'get-modexp-children)) | |
| 114 | (leaf-name #'(lambda (tree) | |
| 115 | (cond ((chaos-ast? tree) | |
| 116 | (case (ast-type tree) | |
| 117 | (%! "_[_]") | |
| 118 | (%!arg "_<=_") | |
| 119 | (%* "_*_") | |
| 120 | (%+ "_+_") | |
| 121 | ((%view %view-from) "view_") | |
| 122 | (%rmap "{_}") | |
| 123 | (%ren-sort "sort_->_") | |
| 124 | (%ren-op "op_->_") | |
| 125 | (%ren-param "param_->_") | |
| 126 | (otherwise "??"))) | |
| 127 | ((and (consp tree) (eq (car tree) ':?name)) | |
| 128 | (cdr tree)) | |
| 129 | ((and (consp tree) (null (cdr tree))) | |
| 130 | (car tree)) | |
| 131 | (t tree)))) | |
| 132 | (leaf-info #'(lambda (tree) (declare (ignore tree)) t)) | |
| 133 | (int-node-name #'(lambda (tree) (funcall leaf-name tree))) | |
| 134 | (int-node-children #'get-modexp-children)) | |
| 135 | 135 | (force-output stream) |
| 136 | 136 | (print-next nil *print-indent* stream) |
| 137 | 137 | (print-trees (list (augment-tree modexp)) stream))) |
| 140 | 140 | ;;; |
| 141 | 141 | (defun print-subs-list (module) |
| 142 | 142 | (dag-dfs (module-dag module) |
| 143 | #'(lambda (node) | |
| 144 | (let* ((datum (dag-node-datum node)) | |
| 145 | (mode (cdr datum)) | |
| 146 | (mod (car datum))) | |
| 147 | (format t "~&* mode :~a" mode) | |
| 148 | (print-next) | |
| 149 | (princ " module : ") | |
| 150 | (print-chaos-object mod))))) | |
| 143 | #'(lambda (node) | |
| 144 | (let* ((datum (dag-node-datum node)) | |
| 145 | (mode (cdr datum)) | |
| 146 | (mod (car datum))) | |
| 147 | (format t "~%* mode :~a" mode) | |
| 148 | (print-next) | |
| 149 | (princ " module : ") | |
| 150 | (print-chaos-object mod))))) | |
| 151 | 151 | |
| 152 | 152 | (defun print-mod-name-x (arg &optional |
| 153 | (stream *standard-output*) | |
| 154 | (abbrev nil) | |
| 155 | (no-param nil)) | |
| 153 | (stream *standard-output*) | |
| 154 | (abbrev nil) | |
| 155 | (no-param nil)) | |
| 156 | 156 | (let ((*standard-output* stream)) |
| 157 | 157 | (if (module-p arg) |
| 158 | (let ((modname (get-module-print-name arg))) | |
| 159 | (if (is-dummy-module arg) | |
| 160 | (let ((info (getf (module-infos arg) 'rename-mod))) | |
| 161 | (print-mod-name-x (car info) stream abbrev no-param) | |
| 162 | (princ "*DUMMY")) | |
| 163 | (with-in-module (arg) | |
| 164 | (print-mod-name-internal-x modname abbrev t))) | |
| 165 | (let ((params (get-module-parameters arg))) | |
| 166 | (when (and params (not no-param)) | |
| 167 | (let ((flg nil)) | |
| 168 | (princ "[") | |
| 169 | ;; (princ "(") | |
| 170 | (dolist (param params) | |
| 171 | (let ((theory (parameter-theory-module param))) | |
| 172 | (if flg (princ ", ")) | |
| 173 | (if (or (null (parameter-context param)) | |
| 174 | (eq arg (parameter-context param))) | |
| 175 | (princ (parameter-arg-name param)) | |
| 176 | (if (not (eq (parameter-context param) arg)) | |
| 177 | (progn | |
| 178 | (format t "~a." (parameter-arg-name param)) | |
| 179 | (print-mod-name-x (parameter-context param) | |
| 180 | stream | |
| 181 | abbrev | |
| 182 | t)) | |
| 183 | (format t "~a" (parameter-arg-name param)))) | |
| 184 | ;; patch-begin | |
| 185 | (princ "::") | |
| 186 | (print-parameter-theory-name theory stream :abbrev :no-param) | |
| 187 | (setq flg t))) | |
| 188 | (princ "]") | |
| 189 | ;; (princ ")") | |
| 190 | )))) | |
| 191 | (print-chaos-object arg)))) | |
| 158 | (let ((modname (get-module-print-name arg))) | |
| 159 | (if (is-dummy-module arg) | |
| 160 | (let ((info (getf (module-infos arg) 'rename-mod))) | |
| 161 | (print-mod-name-x (car info) stream abbrev no-param) | |
| 162 | (princ "*DUMMY")) | |
| 163 | (with-in-module (arg) | |
| 164 | (print-mod-name-internal-x modname abbrev t))) | |
| 165 | (let ((params (get-module-parameters arg))) | |
| 166 | (when (and params (not no-param)) | |
| 167 | (let ((flg nil)) | |
| 168 | (princ "[") | |
| 169 | ;; (princ "(") | |
| 170 | (dolist (param params) | |
| 171 | (let ((theory (parameter-theory-module param))) | |
| 172 | (if flg (princ ", ")) | |
| 173 | (if (or (null (parameter-context param)) | |
| 174 | (eq arg (parameter-context param))) | |
| 175 | (princ (parameter-arg-name param)) | |
| 176 | (if (not (eq (parameter-context param) arg)) | |
| 177 | (progn | |
| 178 | (format t "~a." (parameter-arg-name param)) | |
| 179 | (print-mod-name-x (parameter-context param) | |
| 180 | stream | |
| 181 | abbrev | |
| 182 | t)) | |
| 183 | (format t "~a" (parameter-arg-name param)))) | |
| 184 | ;; patch-begin | |
| 185 | (princ "::") | |
| 186 | (print-parameter-theory-name theory stream :abbrev :no-param) | |
| 187 | (setq flg t))) | |
| 188 | (princ "]") | |
| 189 | ;; (princ ")") | |
| 190 | )))) | |
| 191 | (print-chaos-object arg)))) | |
| 192 | 192 | |
| 193 | 193 | (defun print-mod-name-internal-x (val abbrev &optional (no-param nil)) |
| 194 | 194 | (declare (values t)) |
| 195 | 195 | (if (stringp val) |
| 196 | 196 | (princ val) |
| 197 | 197 | (if (and (consp val) (not (chaos-ast? val))) |
| 198 | (if (equal "::" (cadr val)) | |
| 199 | ;; parameter theory | |
| 200 | (if abbrev | |
| 201 | (progn | |
| 202 | (format t "~a" (car val)) | |
| 203 | (princ ".") | |
| 204 | (print-mod-name-x (car (last val)) *standard-output* abbrev no-param)) | |
| 205 | (let ((cntxt (fourth val))) | |
| 206 | (if (and cntxt | |
| 207 | (not (eq *current-module* cntxt))) | |
| 208 | (progn (format t "~a." (car val)) | |
| 209 | (print-mod-name-x cntxt *standard-output* t t) | |
| 210 | (princ "::")) | |
| 211 | (format t "~a::" (car val))) | |
| 212 | (print-mod-name-x (caddr val) *standard-output* abbrev t))) | |
| 213 | (print-chaos-object val)) | |
| 198 | (if (equal "::" (cadr val)) | |
| 199 | ;; parameter theory | |
| 200 | (if abbrev | |
| 201 | (progn | |
| 202 | (format t "~a" (car val)) | |
| 203 | (princ ".") | |
| 204 | (print-mod-name-x (car (last val)) *standard-output* abbrev no-param)) | |
| 205 | (let ((cntxt (fourth val))) | |
| 206 | (if (and cntxt | |
| 207 | (not (eq *current-module* cntxt))) | |
| 208 | (progn (format t "~a." (car val)) | |
| 209 | (print-mod-name-x cntxt *standard-output* t t) | |
| 210 | (princ "::")) | |
| 211 | (format t "~a::" (car val))) | |
| 212 | (print-mod-name-x (caddr val) *standard-output* abbrev t))) | |
| 213 | (print-chaos-object val)) | |
| 214 | 214 | (print-modexp val *standard-output* abbrev no-param)))) |
| 215 | 215 | |
| 216 | 216 | (defvar .mod-dup-hash. (make-hash-table :test #'eq)) |
| 239 | 239 | |
| 240 | 240 | (defun d-module-tree* (dag-node stream p-label &optional my-num) |
| 241 | 241 | (let* ((mod+imp (dag-node-datum dag-node)) |
| 242 | (mod (car mod+imp)) | |
| 243 | (imp (cdr mod+imp)) | |
| 244 | (*print-line-limit* 100) | |
| 245 | (*print-xmode* :fancy) | |
| 246 | (num (if (and p-label my-num) | |
| 247 | (format nil "~a-~d" p-label my-num) | |
| 248 | (if my-num | |
| 249 | (format nil "~a" my-num) | |
| 250 | nil))) | |
| 251 | (dup? (gethash mod .mod-dup-hash.))) | |
| 242 | (mod (car mod+imp)) | |
| 243 | (imp (cdr mod+imp)) | |
| 244 | (*print-line-limit* 100) | |
| 245 | (*print-xmode* :fancy) | |
| 246 | (num (if (and p-label my-num) | |
| 247 | (format nil "~a-~d" p-label my-num) | |
| 248 | (if my-num | |
| 249 | (format nil "~a" my-num) | |
| 250 | nil))) | |
| 251 | (dup? (gethash mod .mod-dup-hash.))) | |
| 252 | 252 | (when num |
| 253 | 253 | (format stream "~a: " num) |
| 254 | 254 | (when imp |
| 255 | (pr-imp-mode imp stream))) | |
| 255 | (pr-imp-mode imp stream))) | |
| 256 | 256 | (unless dup? (setf (gethash mod .mod-dup-hash.) num)) |
| 257 | 257 | (let ((*print-indent* (+ 0 *print-indent*))) |
| 258 | 258 | (when num (princ "(" stream)) |
| 259 | 259 | (print-mod-name mod *standard-output* t t) |
| 260 | 260 | (when num (princ ")" stream)) |
| 261 | 261 | (if dup? (princ "*" stream) |
| 262 | (with-in-module (mod) | |
| 263 | (let ((subnodes (dag-node-subnodes dag-node))) | |
| 264 | (when subnodes | |
| 265 | (let ((y-num 1)) | |
| 266 | (dolist (sub subnodes) | |
| 267 | (let ((subm (car (dag-node-datum sub))) | |
| 268 | (sub-imp (cdr (dag-node-datum sub)))) | |
| 269 | (when (or *chaos-verbose* | |
| 270 | (and (not (module-hidden subm)) | |
| 271 | (not (module-is-parameter-theory subm)) | |
| 272 | (not (eq sub-imp :modmorph)))) | |
| 273 | (print-next-prefix #\Space) | |
| 274 | (d-module-tree* sub stream num y-num) | |
| 275 | (incf y-num)))))))))))) | |
| 262 | (with-in-module (mod) | |
| 263 | (let ((subnodes (dag-node-subnodes dag-node))) | |
| 264 | (when subnodes | |
| 265 | (let ((y-num 1)) | |
| 266 | (dolist (sub subnodes) | |
| 267 | (let ((subm (car (dag-node-datum sub))) | |
| 268 | (sub-imp (cdr (dag-node-datum sub)))) | |
| 269 | (when (or *chaos-verbose* | |
| 270 | (and (not (module-hidden subm)) | |
| 271 | (not (module-is-parameter-theory subm)) | |
| 272 | (not (eq sub-imp :modmorph)))) | |
| 273 | (print-next-prefix #\Space) | |
| 274 | (d-module-tree* sub stream num y-num) | |
| 275 | (incf y-num)))))))))))) | |
| 276 | 276 | ;;; EOF |
| 0 | 0 | ;;;-*-Mode:LISP; Package: CHAOS; Base:10; Syntax:Common-lisp -*- |
| 1 | 1 | ;;; |
| 2 | ;;; Copyright (c) 2000-2014, Toshimi Sawada. All rights reserved. | |
| 2 | ;;; Copyright (c) 2000-2015, Toshimi Sawada. All rights reserved. | |
| 3 | 3 | ;;; |
| 4 | 4 | ;;; Redistribution and use in source and binary forms, with or without |
| 5 | 5 | ;;; modification, are permitted provided that the following conditions |
| 27 | 27 | ;;; |
| 28 | 28 | (in-package :chaos) |
| 29 | 29 | #|============================================================================= |
| 30 | System:CHAOS | |
| 31 | Module:tools | |
| 32 | File:op-check.lisp | |
| 30 | System:CHAOS | |
| 31 | Module:tools | |
| 32 | File:op-check.lisp | |
| 33 | 33 | =============================================================================|# |
| 34 | 34 | #-:chaos-debug |
| 35 | 35 | (declaim (optimize (speed 3) (safety 0) #-GCL (debug 0))) |
| 48 | 48 | ;;; 1. constants(operations free from axioms) are always strict. |
| 49 | 49 | ;;; |
| 50 | 50 | (defun check-method-strictness (meth &optional |
| 51 | (module (or *current-module* | |
| 52 | *last-module* | |
| 53 | )) | |
| 54 | report?) | |
| 55 | ||
| 56 | (unless module | |
| 57 | (with-output-chaos-error ('no-cntext) | |
| 58 | (princ "checking lazyness: no context module is specified!") | |
| 59 | )) | |
| 60 | ;; | |
| 51 | (module (get-context-module)) | |
| 52 | report?) | |
| 61 | 53 | (with-in-module (module) |
| 62 | 54 | (cond ((and (null (method-rules-with-different-top meth)) |
| 63 | (rule-ring-is-empty (method-rules-with-same-top meth))) | |
| 64 | ;; the method has no rewrite rules | |
| 65 | (if report? | |
| 66 | (show-method-strictness-report meth | |
| 67 | (butlast (the-default-strategy | |
| 68 | (length (method-arity meth)))) | |
| 69 | nil) | |
| 70 | (values (butlast (the-default-strategy (length (method-arity meth)))) | |
| 71 | nil))) | |
| 72 | ;; the method has some rewrite rules associated with it. | |
| 73 | ((or | |
| 74 | ;; has some equational theory | |
| 75 | (not (theory-is-empty-for-matching (method-theory meth))) | |
| 76 | ;; the method is not free constructor. | |
| 77 | (null (method-rules-with-different-top meth)) | |
| 78 | ;; has rules with different top and constant | |
| 79 | ;; --> non-free constructor | |
| 80 | (null (method-arity meth))) | |
| 81 | ;; then the strategy is bottom up: | |
| 82 | (if report? | |
| 83 | (show-method-strictness-report | |
| 84 | meth | |
| 85 | (butlast (the-default-strategy | |
| 86 | (length (method-arity meth)))) | |
| 87 | nil) | |
| 88 | (values (butlast (the-default-strategy (length (method-arity meth)))) | |
| 89 | nil))) | |
| 90 | ;; | |
| 91 | (t | |
| 92 | ;; the real work begins here. | |
| 93 | (let ((l-ar (length (method-arity meth))) | |
| 94 | (strategy nil) | |
| 95 | (end-strategy nil)) | |
| 96 | (do ((occ 0 (1+ occ))) | |
| 97 | ((<= l-ar occ)) | |
| 98 | (block is-variable | |
| 99 | (let ((rr (method-rules-with-same-top meth))) | |
| 100 | (do ((rule (initialize-rule-ring rr) (rule-ring-next rr))) | |
| 101 | ((end-of-rule-ring rr)) | |
| 102 | (unless (term-is-variable? | |
| 103 | (term-arg-n (rule-lhs rule) occ)) | |
| 104 | ;; we eagarly evaluate non-variable argument. | |
| 105 | (push (1+ occ) strategy) | |
| 106 | ;; check next argument | |
| 107 | (return-from is-variable)))) | |
| 108 | ;; we come here iff | |
| 109 | ;; the arguments in lhs of all rules-with-same-top are | |
| 110 | ;; variables or no rules-with-same-top. | |
| 111 | (dolist (rule (method-rules-with-different-top meth)) | |
| 112 | (When | |
| 113 | (let ((argn (term-arg-n (rule-lhs rule) occ)) | |
| 114 | (m (term-head (rule-lhs rule)))) | |
| 115 | (or (not (term-is-variable? argn)) | |
| 116 | ;; argn is not a variable. | |
| 117 | (rule-is-builtin rule) | |
| 118 | (not (and | |
| 119 | ;; method is maximal? | |
| 120 | ;; overloaded is necessarily a superset | |
| 121 | ;; of lower. Note, overloaded always include | |
| 122 | ;; self + default method, but lower not. | |
| 123 | ;; thus #lower = #overloaded - 2 means the | |
| 124 | ;; method is maximal. | |
| 125 | (= (length (method-lower-methods meth)) | |
| 126 | (- (length (method-overloaded-methods meth)) 2)) | |
| 127 | (sort<= (nth occ (method-arity m)) | |
| 128 | (term-sort argn)) | |
| 129 | )))) | |
| 130 | ;; method of lhs is not maximal, | |
| 131 | ;; eagarly evaluates the non-variable argument. | |
| 132 | (push (1+ occ) strategy) | |
| 133 | ;; check the next arg. | |
| 134 | (return-from is-variable))) | |
| 135 | ;; come here if the occ-th argument is a variable,or | |
| 136 | ;; method is maximal. can delay the evaluation. | |
| 137 | (push (1+ occ) end-strategy) | |
| 138 | )) | |
| 139 | ;; | |
| 140 | (if report? | |
| 141 | (show-method-strictness-report meth | |
| 142 | (reverse strategy) | |
| 143 | (reverse end-strategy)) | |
| 144 | (values (reverse strategy) (reverse end-strategy))))) | |
| 145 | ))) | |
| 146 | ||
| 147 | (defun check-operator-strictness (op &optional (module (or *last-module* | |
| 148 | *current-module*)) | |
| 149 | report?) | |
| 55 | (rule-ring-is-empty (method-rules-with-same-top meth))) | |
| 56 | ;; the method has no rewrite rules | |
| 57 | (if report? | |
| 58 | (show-method-strictness-report meth | |
| 59 | (butlast (the-default-strategy | |
| 60 | (length (method-arity meth)))) | |
| 61 | nil) | |
| 62 | (values (butlast (the-default-strategy (length (method-arity meth)))) | |
| 63 | nil))) | |
| 64 | ;; the method has some rewrite rules associated with it. | |
| 65 | ((or | |
| 66 | ;; has some equational theory | |
| 67 | (not (theory-is-empty-for-matching (method-theory meth))) | |
| 68 | ;; the method is not free constructor. | |
| 69 | (null (method-rules-with-different-top meth)) | |
| 70 | ;; has rules with different top and constant | |
| 71 | ;; --> non-free constructor | |
| 72 | (null (method-arity meth))) | |
| 73 | ;; then the strategy is bottom up: | |
| 74 | (if report? | |
| 75 | (show-method-strictness-report | |
| 76 | meth | |
| 77 | (butlast (the-default-strategy | |
| 78 | (length (method-arity meth)))) | |
| 79 | nil) | |
| 80 | (values (butlast (the-default-strategy (length (method-arity meth)))) | |
| 81 | nil))) | |
| 82 | ;; | |
| 83 | (t | |
| 84 | ;; the real work begins here. | |
| 85 | (let ((l-ar (length (method-arity meth))) | |
| 86 | (strategy nil) | |
| 87 | (end-strategy nil)) | |
| 88 | (do ((occ 0 (1+ occ))) | |
| 89 | ((<= l-ar occ)) | |
| 90 | (block is-variable | |
| 91 | (let ((rr (method-rules-with-same-top meth))) | |
| 92 | (do ((rule (initialize-rule-ring rr) (rule-ring-next rr))) | |
| 93 | ((end-of-rule-ring rr)) | |
| 94 | (unless (term-is-variable? | |
| 95 | (term-arg-n (rule-lhs rule) occ)) | |
| 96 | ;; we eagarly evaluate non-variable argument. | |
| 97 | (push (1+ occ) strategy) | |
| 98 | ;; check next argument | |
| 99 | (return-from is-variable)))) | |
| 100 | ;; we come here iff | |
| 101 | ;; the arguments in lhs of all rules-with-same-top are | |
| 102 | ;; variables or no rules-with-same-top. | |
| 103 | (dolist (rule (method-rules-with-different-top meth)) | |
| 104 | (When | |
| 105 | (let ((argn (term-arg-n (rule-lhs rule) occ)) | |
| 106 | (m (term-head (rule-lhs rule)))) | |
| 107 | (or (not (term-is-variable? argn)) | |
| 108 | ;; argn is not a variable. | |
| 109 | (rule-is-builtin rule) | |
| 110 | (not (and | |
| 111 | ;; method is maximal? | |
| 112 | ;; overloaded is necessarily a superset | |
| 113 | ;; of lower. Note, overloaded always include | |
| 114 | ;; self + default method, but lower not. | |
| 115 | ;; thus #lower = #overloaded - 2 means the | |
| 116 | ;; method is maximal. | |
| 117 | (= (length (method-lower-methods meth)) | |
| 118 | (- (length (method-overloaded-methods meth)) 2)) | |
| 119 | (sort<= (nth occ (method-arity m)) | |
| 120 | (term-sort argn)) | |
| 121 | )))) | |
| 122 | ;; method of lhs is not maximal, | |
| 123 | ;; eagarly evaluates the non-variable argument. | |
| 124 | (push (1+ occ) strategy) | |
| 125 | ;; check the next arg. | |
| 126 | (return-from is-variable))) | |
| 127 | ;; come here if the occ-th argument is a variable,or | |
| 128 | ;; method is maximal. can delay the evaluation. | |
| 129 | (push (1+ occ) end-strategy) | |
| 130 | )) | |
| 131 | ;; | |
| 132 | (if report? | |
| 133 | (show-method-strictness-report meth | |
| 134 | (reverse strategy) | |
| 135 | (reverse end-strategy)) | |
| 136 | (values (reverse strategy) (reverse end-strategy))))) | |
| 137 | ))) | |
| 138 | ||
| 139 | (defun check-operator-strictness (op &optional (module (get-context-module)) | |
| 140 | report?) | |
| 150 | 141 | (unless module |
| 151 | 142 | (with-output-chaos-error ('no-context) |
| 152 | (princ "no context (current) module is given!") | |
| 153 | )) | |
| 143 | (princ "no context (current) module is given!"))) | |
| 154 | 144 | ;; |
| 155 | 145 | (let* ((opinfo (if (opinfo-p op) |
| 156 | (prog1 op (setq op (opinfo-operator op))) | |
| 157 | (get-operator-info op (module-all-operators module)))) | |
| 158 | (methods (opinfo-methods opinfo)) | |
| 159 | (res nil)) | |
| 146 | (prog1 op (setq op (opinfo-operator op))) | |
| 147 | (get-operator-info op (module-all-operators module)))) | |
| 148 | (methods (opinfo-methods opinfo)) | |
| 149 | (res nil)) | |
| 160 | 150 | (when report? |
| 161 | 151 | (print-next) |
| 162 | 152 | (let ((*print-line-limit* 60)) |
| 163 | (format t "~%------------------------------------------------------------") | |
| 164 | (print-next) | |
| 165 | (print-centering | |
| 166 | (format nil "* laziness of operator: ~a *" (operator-symbol op))))) | |
| 153 | (format t "~%------------------------------------------------------------") | |
| 154 | (print-next) | |
| 155 | (print-centering | |
| 156 | (format nil "* laziness of operator: ~a *" (operator-symbol op))))) | |
| 167 | 157 | ;; |
| 168 | 158 | (dolist (meth methods) |
| 169 | 159 | (unless (method-is-error-method meth) |
| 170 | (multiple-value-bind (str-list1 str-list2) | |
| 171 | (check-method-strictness meth module) | |
| 172 | (when report? | |
| 173 | (with-in-module (module) | |
| 174 | (print-next) | |
| 175 | (format t "------------------------------------------------------------") | |
| 176 | (show-method-strictness-report meth | |
| 177 | str-list1 | |
| 178 | str-list2))) | |
| 179 | (push (list meth str-list1 str-list2) res)))) | |
| 160 | (multiple-value-bind (str-list1 str-list2) | |
| 161 | (check-method-strictness meth module) | |
| 162 | (when report? | |
| 163 | (with-in-module (module) | |
| 164 | (print-next) | |
| 165 | (format t "------------------------------------------------------------") | |
| 166 | (show-method-strictness-report meth | |
| 167 | str-list1 | |
| 168 | str-list2))) | |
| 169 | (push (list meth str-list1 str-list2) res)))) | |
| 180 | 170 | (nreverse res))) |
| 181 | 171 | |
| 182 | (defun check-operator-strictness-whole (&optional (module (or *last-module* | |
| 183 | *current-module*)) | |
| 184 | report?) | |
| 172 | (defun check-operator-strictness-whole (&optional (module (get-context-module)) | |
| 173 | report?) | |
| 185 | 174 | (unless module |
| 186 | 175 | (with-output-chaos-error ('no-context) |
| 187 | (princ "no context (current) module is specified!") | |
| 188 | )) | |
| 176 | (princ "no context (current) module is specified!"))) | |
| 189 | 177 | ;; |
| 190 | 178 | (let ((result nil)) |
| 191 | 179 | (dolist (opinfo (ops-to-be-shown module)) |
| 192 | 180 | (let ((op (opinfo-operator opinfo)) |
| 193 | (res nil)) | |
| 194 | (setq res (check-operator-strictness op module report?)) | |
| 195 | (push (cons op res) result))) | |
| 181 | (res nil)) | |
| 182 | (setq res (check-operator-strictness op module report?)) | |
| 183 | (push (cons op res) result))) | |
| 196 | 184 | (nreverse result))) |
| 197 | 185 | |
| 198 | 186 | (defun show-method-strictness-report (method sl1 sl2) |
| 199 | 187 | (print-next) |
| 200 | 188 | (print-chaos-object method) |
| 201 | 189 | (let ((*print-indent* (+ 2 *print-indent*)) |
| 202 | (strategy (or (method-rewrite-strategy method) | |
| 203 | (method-supplied-strategy method) | |
| 204 | (operator-strategy (method-operator method))))) | |
| 190 | (strategy (or (method-rewrite-strategy method) | |
| 191 | (method-supplied-strategy method) | |
| 192 | (operator-strategy (method-operator method))))) | |
| 205 | 193 | (cond ((and (null sl1) (null sl2)) |
| 206 | (print-next) | |
| 207 | (princ "* NON-STRICT (lazy).")) | |
| 208 | (t (when sl1 | |
| 209 | (print-next) | |
| 210 | (format t "* strict on the arguments : ~{~^ ~a~}" sl1)) | |
| 211 | (when sl2 | |
| 212 | (print-next) | |
| 213 | (format t "* may delay the evaluation on the arguments : ~{~^ ~a~}" sl2)))) | |
| 194 | (print-next) | |
| 195 | (princ "* NON-STRICT (lazy).")) | |
| 196 | (t (when sl1 | |
| 197 | (print-next) | |
| 198 | (format t "* strict on the arguments : ~{~^ ~a~}" sl1)) | |
| 199 | (when sl2 | |
| 200 | (print-next) | |
| 201 | (format t "* may delay the evaluation on the arguments : ~{~^ ~a~}" sl2)))) | |
| 214 | 202 | ;; |
| 215 | 203 | (print-next) |
| 216 | 204 | (if strategy |
| 217 | (format t "- rewrite strategy:~{~^ ~a~}" strategy) | |
| 218 | (princ "- rewrite strategy: none")) | |
| 205 | (format t "- rewrite strategy:~{~^ ~a~}" strategy) | |
| 206 | (princ "- rewrite strategy: none")) | |
| 219 | 207 | (let ((axioms (method-all-rules method))) |
| 220 | 208 | (when axioms |
| 221 | (print-next) | |
| 222 | (princ "- axioms:") | |
| 223 | (let ((*print-indent* (+ 2 *print-indent*))) | |
| 224 | (dolist (rl axioms) | |
| 225 | (print-next) | |
| 226 | (print-axiom-brief rl))))))) | |
| 209 | (print-next) | |
| 210 | (princ "- axioms:") | |
| 211 | (let ((*print-indent* (+ 2 *print-indent*))) | |
| 212 | (dolist (rl axioms) | |
| 213 | (print-next) | |
| 214 | (print-axiom-brief rl))))))) | |
| 227 | 215 | |
| 228 | 216 | |
| 229 | 217 | |
| 234 | 222 | |
| 235 | 223 | (defun method-contained-in (meth term) |
| 236 | 224 | (cond ((term-is-constant? term) nil) |
| 237 | (t (let ((head (term-head term))) | |
| 238 | (when (method-is-of-same-operator meth head) | |
| 239 | (return-from method-contained-in t)) | |
| 240 | (dotimes (x (length (term-subterms term))) | |
| 241 | (when (method-contained-in meth (term-arg-n term x)) | |
| 242 | (return-from method-contained-in t))) | |
| 243 | nil)))) | |
| 225 | (t (let ((head (term-head term))) | |
| 226 | (when (method-is-of-same-operator meth head) | |
| 227 | (return-from method-contained-in t)) | |
| 228 | (dotimes (x (length (term-subterms term))) | |
| 229 | (when (method-contained-in meth (term-arg-n term x)) | |
| 230 | (return-from method-contained-in t))) | |
| 231 | nil)))) | |
| 244 | 232 | |
| 245 | 233 | (defun check-method-coherency (meth &optional |
| 246 | (module (or *current-module* *last-module*)) | |
| 247 | (warn t)) | |
| 234 | (module (get-context-module)) | |
| 235 | (warn t)) | |
| 248 | 236 | (unless module |
| 249 | 237 | (with-output-chaos-error ('no-cntext) |
| 250 | 238 | (princ "checking coherecy: no context module is specified!"))) |
| 251 | 239 | ;; |
| 252 | 240 | (when (or (method-is-of-same-operator meth *beh-equal*) |
| 253 | (method-is-of-same-operator meth *beh-eq-pred*)) | |
| 241 | (method-is-of-same-operator meth *beh-eq-pred*)) | |
| 254 | 242 | (when warn |
| 255 | 243 | (with-output-chaos-warning () |
| 256 | (princ "specified operator is special built-in predicate."))) | |
| 244 | (princ "specified operator is special built-in predicate."))) | |
| 257 | 245 | (return-from check-method-coherency nil)) |
| 258 | 246 | ;; |
| 259 | 247 | (let ((methods (module-beh-methods module)) |
| 260 | (attrs (module-beh-attributes module)) | |
| 261 | (hs (dolist (x (method-arity meth)) | |
| 262 | (when (sort-is-hidden x) | |
| 263 | (return x))))) | |
| 248 | (attrs (module-beh-attributes module)) | |
| 249 | (hs (dolist (x (method-arity meth)) | |
| 250 | (when (sort-is-hidden x) | |
| 251 | (return x))))) | |
| 264 | 252 | (declare (type list methods attrs)) |
| 265 | 253 | ;; |
| 266 | 254 | (unless (sort-p hs) |
| 267 | 255 | (when warn |
| 268 | (with-output-chaos-warning () | |
| 269 | (princ "operator ") | |
| 270 | (print-chaos-object meth) | |
| 271 | (princ " has no hidden sort argument."))) | |
| 256 | (with-output-chaos-warning () | |
| 257 | (princ "operator ") | |
| 258 | (print-chaos-object meth) | |
| 259 | (princ " has no hidden sort argument."))) | |
| 272 | 260 | (return-from check-method-coherency nil)) |
| 273 | 261 | (when (sort= *huniversal-sort* hs) |
| 274 | 262 | (when warn |
| 275 | (with-output-chaos-warning () | |
| 276 | (princ "specified operator is special built-in."))) | |
| 263 | (with-output-chaos-warning () | |
| 264 | (princ "specified operator is special built-in."))) | |
| 277 | 265 | (return-from check-method-coherency nil)) |
| 278 | 266 | (when (method-is-behavioural meth) |
| 279 | 267 | (when warn |
| 280 | (with-output-chaos-warning () | |
| 281 | (princ "operator ") | |
| 282 | (print-chaos-object meth) | |
| 283 | (princ " is declared as behavioural."))) | |
| 268 | (with-output-chaos-warning () | |
| 269 | (princ "operator ") | |
| 270 | (print-chaos-object meth) | |
| 271 | (princ " is declared as behavioural."))) | |
| 284 | 272 | (return-from check-method-coherency nil)) |
| 285 | 273 | (unless (sort-is-hidden (method-coarity meth)) |
| 286 | 274 | (format t "~%**> operator: ") |
| 291 | 279 | (with-in-module (module) |
| 292 | 280 | ;; |
| 293 | 281 | (let ((observers nil)) |
| 294 | (dolist (op (append methods attrs)) | |
| 295 | (when (find-if #'(lambda (x) (sort<= hs x)) | |
| 296 | (method-arity op)) | |
| 297 | (push op observers))) | |
| 298 | ;; | |
| 299 | (format t "~%**> starting coherence check of ") | |
| 300 | (print-chaos-object meth) | |
| 301 | ;; | |
| 302 | (unless observers | |
| 303 | (format t "~% no context constructing operations,") | |
| 304 | (format t "~% failed to prove coherency.") | |
| 305 | (return-from check-method-coherency nil)) | |
| 306 | ;; | |
| 307 | (let* ((con-count 0) | |
| 308 | ;; op(x1,...xn) | |
| 309 | (op-pat (make-term-with-sort-check | |
| 310 | meth | |
| 311 | (mapcar #'(lambda (x) | |
| 312 | (make-variable-term x | |
| 313 | (gensym "X"))) | |
| 314 | (method-arity meth))))) | |
| 315 | (dolist (ob observers) | |
| 316 | (let* ((hs-var (make-variable-term hs (gensym "HS"))) | |
| 317 | ;; ob(cv1,...,zi,..,cvn) | |
| 318 | (context-pat (make-term-with-sort-check | |
| 319 | ob | |
| 320 | (mapcar #'(lambda (x) | |
| 321 | (if (sort-is-hidden x) | |
| 322 | ;; op-pat | |
| 323 | hs-var | |
| 324 | (make-variable-term | |
| 325 | x | |
| 326 | (gensym "CV")))) | |
| 327 | (method-arity ob))))) | |
| 328 | (format t "~%-- context pattern(~d): " (incf con-count)) | |
| 329 | (print-chaos-object context-pat) | |
| 330 | ;; | |
| 331 | (let ((ax nil) | |
| 332 | (match? nil) | |
| 333 | (subst nil) | |
| 334 | (checked? nil) | |
| 335 | (found? nil)) | |
| 336 | ;; | |
| 337 | (dolist (x (method-rules ob)) | |
| 338 | (setq found? nil) | |
| 339 | (multiple-value-setq (match? subst) | |
| 340 | (perform-context-match (axiom-lhs x) | |
| 341 | context-pat | |
| 342 | )) | |
| 343 | (when match? | |
| 344 | (setq ax x) | |
| 345 | (if (method-contained-in meth (axiom-lhs ax)) | |
| 346 | (progn | |
| 347 | (setq subst nil) | |
| 348 | (setq found? t) | |
| 349 | ;; | |
| 350 | (format t "~% * found an axiom : ") | |
| 351 | (print-chaos-object ax)) | |
| 352 | ;; | |
| 353 | (let ((image (variable-image subst hs-var)) | |
| 354 | (new-lhs nil) | |
| 355 | (new-rhs nil) | |
| 356 | (new-cond (axiom-condition ax)) | |
| 357 | ) | |
| 358 | (when (and image (term-is-psuedo-constant? image)) | |
| 359 | (setq found? t) | |
| 360 | (setq subst | |
| 361 | (substitution-add (new-substitution) | |
| 362 | image | |
| 363 | op-pat)) | |
| 364 | ;; | |
| 365 | (format t "~% * found an axiom : ") | |
| 366 | (print-chaos-object ax) | |
| 367 | (when subst | |
| 368 | (format t "~% with substitution: ") | |
| 369 | (print-substitution subst)) | |
| 370 | ;; | |
| 371 | (setq new-lhs | |
| 372 | (substitution-image2 subst | |
| 373 | (axiom-lhs ax))) | |
| 374 | (setq new-rhs | |
| 375 | (substitution-image2 subst | |
| 376 | (axiom-rhs ax))) | |
| 377 | (unless (is-true? (axiom-condition ax)) | |
| 378 | (setq new-cond | |
| 379 | (substitution-image2 | |
| 380 | subst | |
| 381 | (axiom-condition ax)))) | |
| 382 | ;; | |
| 383 | (setq ax | |
| 384 | (make-rule :lhs new-lhs | |
| 385 | :rhs new-rhs | |
| 386 | :condition new-cond | |
| 387 | :behavioural (axiom-behavioural ax) | |
| 388 | :id-condition (axiom-id-condition ax) | |
| 389 | :type (axiom-type ax) | |
| 390 | :kind (axiom-kind ax) | |
| 391 | :labels (axiom-labels ax) | |
| 392 | :meta-and-or (axiom-meta-and-or ax))) | |
| 393 | (when *chaos-verbose* | |
| 394 | (format t "~% -- check with axiom instance:") | |
| 395 | (format t "~% ") | |
| 396 | (print-chaos-object ax)) | |
| 397 | ))) | |
| 398 | ;; | |
| 399 | ;; | |
| 400 | (when found? | |
| 401 | (setq checked? t) | |
| 402 | ;; | |
| 403 | (unless (is-true? (axiom-condition ax)) | |
| 404 | (format t "~% axiom is conditional,") | |
| 405 | (format t "~% system can not check coherency, sorry!") | |
| 406 | (return-from check-method-coherency nil)) | |
| 407 | ;; | |
| 408 | ;; RHS | |
| 409 | ;; | |
| 410 | (format t "~% -- start checking rhs pattern : ") | |
| 411 | (let ((ng? (check-def-rhs meth (axiom-rhs ax) subst 1))) | |
| 412 | (when ng? | |
| 413 | (return-from check-method-coherency nil)) | |
| 414 | (format t "~% * success.")) | |
| 415 | ))) | |
| 416 | ;; | |
| 417 | (unless checked? | |
| 418 | (format t "~% * no axioms of context pattern,") | |
| 419 | (format t "~% failed to prove.") | |
| 420 | (return-from check-method-coherency nil)) | |
| 421 | ) | |
| 422 | )) | |
| 423 | ;; all done | |
| 424 | (format t "~%** operator is behaviourally coherent.") | |
| 425 | t | |
| 426 | ))))) | |
| 427 | ||
| 282 | (dolist (op (append methods attrs)) | |
| 283 | (when (find-if #'(lambda (x) (sort<= hs x)) | |
| 284 | (method-arity op)) | |
| 285 | (push op observers))) | |
| 286 | ;; | |
| 287 | (format t "~%**> starting coherence check of ") | |
| 288 | (print-chaos-object meth) | |
| 289 | ;; | |
| 290 | (unless observers | |
| 291 | (format t "~% no context constructing operations,") | |
| 292 | (format t "~% failed to prove coherency.") | |
| 293 | (return-from check-method-coherency nil)) | |
| 294 | ;; | |
| 295 | (let* ((con-count 0) | |
| 296 | ;; op(x1,...xn) | |
| 297 | (op-pat (make-term-with-sort-check | |
| 298 | meth | |
| 299 | (mapcar #'(lambda (x) | |
| 300 | (make-variable-term x | |
| 301 | (gensym "X"))) | |
| 302 | (method-arity meth))))) | |
| 303 | (dolist (ob observers) | |
| 304 | (let* ((hs-var (make-variable-term hs (gensym "HS"))) | |
| 305 | ;; ob(cv1,...,zi,..,cvn) | |
| 306 | (context-pat (make-term-with-sort-check | |
| 307 | ob | |
| 308 | (mapcar #'(lambda (x) | |
| 309 | (if (sort-is-hidden x) | |
| 310 | ;; op-pat | |
| 311 | hs-var | |
| 312 | (make-variable-term | |
| 313 | x | |
| 314 | (gensym "CV")))) | |
| 315 | (method-arity ob))))) | |
| 316 | (format t "~%-- context pattern(~d): " (incf con-count)) | |
| 317 | (print-chaos-object context-pat) | |
| 318 | ;; | |
| 319 | (let ((ax nil) | |
| 320 | (match? nil) | |
| 321 | (subst nil) | |
| 322 | (checked? nil) | |
| 323 | (found? nil)) | |
| 324 | ;; | |
| 325 | (dolist (x (method-rules ob)) | |
| 326 | (setq found? nil) | |
| 327 | (multiple-value-setq (match? subst) | |
| 328 | (perform-context-match (axiom-lhs x) | |
| 329 | context-pat | |
| 330 | )) | |
| 331 | (when match? | |
| 332 | (setq ax x) | |
| 333 | (if (method-contained-in meth (axiom-lhs ax)) | |
| 334 | (progn | |
| 335 | (setq subst nil) | |
| 336 | (setq found? t) | |
| 337 | ;; | |
| 338 | (format t "~% * found an axiom : ") | |
| 339 | (print-chaos-object ax)) | |
| 340 | ;; | |
| 341 | (let ((image (variable-image subst hs-var)) | |
| 342 | (new-lhs nil) | |
| 343 | (new-rhs nil) | |
| 344 | (new-cond (axiom-condition ax)) | |
| 345 | ) | |
| 346 | (when (and image (term-is-psuedo-constant? image)) | |
| 347 | (setq found? t) | |
| 348 | (setq subst | |
| 349 | (substitution-add (new-substitution) | |
| 350 | image | |
| 351 | op-pat)) | |
| 352 | ;; | |
| 353 | (format t "~% * found an axiom : ") | |
| 354 | (print-chaos-object ax) | |
| 355 | (when subst | |
| 356 | (format t "~% with substitution: ") | |
| 357 | (print-substitution subst)) | |
| 358 | ;; | |
| 359 | (setq new-lhs | |
| 360 | (substitution-image2 subst | |
| 361 | (axiom-lhs ax))) | |
| 362 | (setq new-rhs | |
| 363 | (substitution-image2 subst | |
| 364 | (axiom-rhs ax))) | |
| 365 | (unless (is-true? (axiom-condition ax)) | |
| 366 | (setq new-cond | |
| 367 | (substitution-image2 | |
| 368 | subst | |
| 369 | (axiom-condition ax)))) | |
| 370 | ;; | |
| 371 | (setq ax | |
| 372 | (make-rule :lhs new-lhs | |
| 373 | :rhs new-rhs | |
| 374 | :condition new-cond | |
| 375 | :behavioural (axiom-behavioural ax) | |
| 376 | :id-condition (axiom-id-condition ax) | |
| 377 | :type (axiom-type ax) | |
| 378 | :kind (axiom-kind ax) | |
| 379 | :labels (axiom-labels ax) | |
| 380 | :meta-and-or (axiom-meta-and-or ax))) | |
| 381 | (when *chaos-verbose* | |
| 382 | (format t "~% -- check with axiom instance:") | |
| 383 | (format t "~% ") | |
| 384 | (print-chaos-object ax)) | |
| 385 | ))) | |
| 386 | ;; | |
| 387 | ;; | |
| 388 | (when found? | |
| 389 | (setq checked? t) | |
| 390 | ;; | |
| 391 | (unless (is-true? (axiom-condition ax)) | |
| 392 | (format t "~% axiom is conditional,") | |
| 393 | (format t "~% system can not check coherency, sorry!") | |
| 394 | (return-from check-method-coherency nil)) | |
| 395 | ;; | |
| 396 | ;; RHS | |
| 397 | ;; | |
| 398 | (format t "~% -- start checking rhs pattern : ") | |
| 399 | (let ((ng? (check-def-rhs meth (axiom-rhs ax) subst 1))) | |
| 400 | (when ng? | |
| 401 | (return-from check-method-coherency nil)) | |
| 402 | (format t "~% * success.")) | |
| 403 | ))) | |
| 404 | ;; | |
| 405 | (unless checked? | |
| 406 | (format t "~% * no axioms of context pattern,") | |
| 407 | (format t "~% failed to prove.") | |
| 408 | (return-from check-method-coherency nil)) | |
| 409 | ) | |
| 410 | )) | |
| 411 | ;; all done | |
| 412 | (format t "~%** operator is behaviourally coherent.") | |
| 413 | t | |
| 414 | ))))) | |
| 415 | ||
| 428 | 416 | (defun perform-context-match (target pattern) |
| 429 | 417 | (flet ((matcher (pat term) |
| 430 | (if (term-is-variable? pat) | |
| 431 | (if (sort<= (term-sort term) (variable-sort pat) | |
| 432 | (module-sort-order *current-module*)) | |
| 433 | (values nil (list (cons pat term)) nil nil) | |
| 434 | (values nil nil t nil)) | |
| 435 | (if (term-is-lisp-form? pat) | |
| 436 | (values nil nil t nil) | |
| 437 | (first-match pat term))))) | |
| 418 | (if (term-is-variable? pat) | |
| 419 | (if (sort<= (term-sort term) (variable-sort pat) | |
| 420 | (module-sort-order *current-module*)) | |
| 421 | (values nil (list (cons pat term)) nil nil) | |
| 422 | (values nil nil t nil)) | |
| 423 | (if (term-is-lisp-form? pat) | |
| 424 | (values nil nil t nil) | |
| 425 | (first-match pat term))))) | |
| 438 | 426 | ;; |
| 439 | 427 | (let ((real-target (supply-psuedo-variables target))) |
| 440 | 428 | ;; ---- first match |
| 441 | 429 | (multiple-value-bind (global-state subst no-match e-equal) |
| 442 | (matcher pattern real-target) | |
| 443 | (declare (ignore global-state)) | |
| 444 | (when no-match | |
| 445 | (return-from perform-context-match nil)) | |
| 446 | (when e-equal | |
| 447 | (when *chaos-verbose* | |
| 448 | (format t "~&-- terms are equational equal.")) | |
| 449 | (return-from perform-context-match (values t nil))) | |
| 450 | ;; | |
| 451 | #|| | |
| 452 | (when *chaos-verbose* | |
| 453 | (format t "~%* match success with substitution : ") | |
| 454 | (let ((*print-indent* (+ *print-indent* 4))) | |
| 455 | (print-substitution subst))) | |
| 456 | ||# | |
| 457 | (values t subst))))) | |
| 430 | (matcher pattern real-target) | |
| 431 | (declare (ignore global-state)) | |
| 432 | (when no-match | |
| 433 | (return-from perform-context-match nil)) | |
| 434 | (when e-equal | |
| 435 | (when *chaos-verbose* | |
| 436 | (format t "~%-- terms are equational equal.")) | |
| 437 | (return-from perform-context-match (values t nil))) | |
| 438 | ;; | |
| 439 | #|| | |
| 440 | (when *chaos-verbose* | |
| 441 | (format t "~%* match success with substitution : ") | |
| 442 | (let ((*print-indent* (+ *print-indent* 4))) | |
| 443 | (print-substitution subst))) | |
| 444 | ||# | |
| 445 | (values t subst))))) | |
| 458 | 446 | |
| 459 | 447 | (defvar .op-found. 0) |
| 460 | 448 | |
| 461 | 449 | (defun check-def-rhs (meth rhs subst context-depth) |
| 462 | 450 | (setq .op-found. 0) |
| 463 | 451 | (let* ((rhs-inst (substitution-image2 subst rhs)) |
| 464 | (res (check-def-rhs* meth rhs-inst context-depth nil))) | |
| 452 | (res (check-def-rhs* meth rhs-inst context-depth nil))) | |
| 465 | 453 | (when (< 1 .op-found.) |
| 466 | 454 | (format t "~%* operator ") |
| 467 | 455 | (print-chaos-object meth) |
| 469 | 457 | res)) |
| 470 | 458 | |
| 471 | 459 | (defun check-def-rhs* (meth rhs context-depth occurrence) |
| 472 | (cond ((term-is-constant? rhs) ; includes vars, psude vars, lisp, | |
| 473 | ; built-in constants also. | |
| 474 | nil) | |
| 475 | (t (let ((head (term-head rhs))) | |
| 476 | ;; (format t "~%RHS =") | |
| 477 | ;; (term-print rhs) | |
| 478 | ;; --------------------------------------- | |
| 479 | (when (eq *bool-if* head) | |
| 480 | (return-from check-def-rhs* nil)) | |
| 481 | ;; ^^^^^^^^------------------------------- | |
| 482 | #|| | |
| 483 | (when (some #'(lambda (x) (sort-is-hidden x)) | |
| 484 | (method-arity head)) | |
| 485 | (when (and (not (method-is-behavioural head)) | |
| 486 | (not (eq *bool-if* head)) | |
| 487 | (not (method-is-of-same-operator meth | |
| 488 | head))) | |
| 489 | (format t "~% * contains non behavioural operator with hidden sort argument.") | |
| 490 | (terpri) | |
| 491 | (print-chaos-object head) | |
| 492 | (format t "~%* failed to prove.") | |
| 493 | (return-from check-def-rhs* :ng1))) | |
| 494 | ||# | |
| 495 | (when (method-is-of-same-operator meth head) | |
| 496 | (incf .op-found.) | |
| 497 | (unless (>= context-depth (length occurrence)) | |
| 498 | ||
| 499 | (format t "~% * for operator: ") | |
| 500 | (print-chaos-object meth) | |
| 501 | (print-next) | |
| 502 | (princ " rhs = ") | |
| 503 | (term-print rhs) | |
| 504 | ||
| 505 | (format t "~% * could not find monotonic, well-founded ordering.") | |
| 506 | (format t "~% operator occurs at ~a" | |
| 507 | (mapcar #'(lambda (x) (1+ x)) | |
| 508 | (reverse occurrence))) | |
| 509 | (return-from check-def-rhs* :ng2))) | |
| 510 | (dotimes (x (length (term-subterms rhs))) | |
| 511 | (let ((ng (check-def-rhs* meth | |
| 512 | (term-arg-n rhs x) | |
| 513 | context-depth | |
| 514 | (cons x occurrence)))) | |
| 515 | (when ng | |
| 516 | (return-from check-def-rhs* ng)))) | |
| 517 | ;; | |
| 518 | nil ; OK | |
| 519 | )))) | |
| 460 | (cond ((term-is-constant? rhs) ; includes vars, psude vars, lisp, | |
| 461 | ; built-in constants also. | |
| 462 | nil) | |
| 463 | (t (let ((head (term-head rhs))) | |
| 464 | ;; (format t "~%RHS =") | |
| 465 | ;; (term-print rhs) | |
| 466 | ;; --------------------------------------- | |
| 467 | (when (eq *bool-if* head) | |
| 468 | (return-from check-def-rhs* nil)) | |
| 469 | ;; ^^^^^^^^------------------------------- | |
| 470 | #|| | |
| 471 | (when (some #'(lambda (x) (sort-is-hidden x)) | |
| 472 | (method-arity head)) | |
| 473 | (when (and (not (method-is-behavioural head)) | |
| 474 | (not (eq *bool-if* head)) | |
| 475 | (not (method-is-of-same-operator meth | |
| 476 | head))) | |
| 477 | (format t "~% * contains non behavioural operator with hidden sort argument.") | |
| 478 | (terpri) | |
| 479 | (print-chaos-object head) | |
| 480 | (format t "~%* failed to prove.") | |
| 481 | (return-from check-def-rhs* :ng1))) | |
| 482 | ||# | |
| 483 | (when (method-is-of-same-operator meth head) | |
| 484 | (incf .op-found.) | |
| 485 | (unless (>= context-depth (length occurrence)) | |
| 486 | ||
| 487 | (format t "~% * for operator: ") | |
| 488 | (print-chaos-object meth) | |
| 489 | (print-next) | |
| 490 | (princ " rhs = ") | |
| 491 | (term-print rhs) | |
| 492 | ||
| 493 | (format t "~% * could not find monotonic, well-founded ordering.") | |
| 494 | (format t "~% operator occurs at ~a" | |
| 495 | (mapcar #'(lambda (x) (1+ x)) | |
| 496 | (reverse occurrence))) | |
| 497 | (return-from check-def-rhs* :ng2))) | |
| 498 | (dotimes (x (length (term-subterms rhs))) | |
| 499 | (let ((ng (check-def-rhs* meth | |
| 500 | (term-arg-n rhs x) | |
| 501 | context-depth | |
| 502 | (cons x occurrence)))) | |
| 503 | (when ng | |
| 504 | (return-from check-def-rhs* ng)))) | |
| 505 | ;; | |
| 506 | nil ; OK | |
| 507 | )))) | |
| 520 | 508 | |
| 521 | 509 | (defun check-operator-coherency (op |
| 522 | &optional | |
| 523 | (module (or *current-module* *last-module*)) | |
| 524 | (warn t) | |
| 525 | ) | |
| 526 | ||
| 510 | &optional | |
| 511 | (module (get-context-module)) | |
| 512 | (warn t)) | |
| 513 | ||
| 527 | 514 | (unless module |
| 528 | 515 | (with-output-chaos-error ('no-context) |
| 529 | (princ "no context (current) module is given!") | |
| 530 | )) | |
| 516 | (princ "no context (current) module is given!"))) | |
| 531 | 517 | ;; |
| 532 | 518 | (let* ((opinfo (if (opinfo-p op) |
| 533 | (prog1 op (setq op (opinfo-operator op))) | |
| 534 | (get-operator-info op (module-all-operators module)))) | |
| 535 | (methods (opinfo-methods opinfo))) | |
| 519 | (prog1 op (setq op (opinfo-operator op))) | |
| 520 | (get-operator-info op (module-all-operators module)))) | |
| 521 | (methods (opinfo-methods opinfo))) | |
| 536 | 522 | (dolist (meth methods) |
| 537 | 523 | (when (or (method-is-user-defined-error-method meth) |
| 538 | (not (method-is-error-method meth))) | |
| 539 | (check-method-coherency meth module warn))) | |
| 524 | (not (method-is-error-method meth))) | |
| 525 | (check-method-coherency meth module warn))) | |
| 540 | 526 | )) |
| 541 | 527 | |
| 542 | 528 | (defun check-operator-coherency-whole (mod) |
| 543 | 529 | (with-in-module (mod) |
| 544 | 530 | (let ((ops (module-all-operators mod))) |
| 545 | 531 | (dolist (opinfo ops) |
| 546 | (let ((methods (opinfo-methods opinfo))) | |
| 547 | (dolist (meth methods) | |
| 548 | (when (or (method-is-user-defined-error-method meth) | |
| 549 | (not (method-is-error-method meth))) | |
| 550 | (check-method-coherency meth mod nil)))))))) | |
| 532 | (let ((methods (opinfo-methods opinfo))) | |
| 533 | (dolist (meth methods) | |
| 534 | (when (or (method-is-user-defined-error-method meth) | |
| 535 | (not (method-is-error-method meth))) | |
| 536 | (check-method-coherency meth mod nil)))))))) | |
| 551 | 537 | |
| 552 | 538 | ;;; CONGRUENCE CHECK |
| 553 | 539 | ;;; may modify operator's attribute. |
| 554 | 540 | ;;; |
| 555 | 541 | (defun check-operator-congruency (mod) |
| 556 | 542 | (let ((ops nil) |
| 557 | (cong nil) | |
| 558 | (nocong nil) | |
| 559 | (cobasis nil) | |
| 560 | (observers nil)) | |
| 543 | (cong nil) | |
| 544 | (nocong nil) | |
| 545 | (cobasis nil) | |
| 546 | (observers nil)) | |
| 561 | 547 | (when (eq 'void *beh-equal*) (return-from check-operator-congruency nil)) |
| 562 | 548 | (when *beh-proof-in-progress* (return-from check-operator-congruency nil)) |
| 563 | 549 | ;; |
| 564 | 550 | (with-in-module (mod) |
| 565 | (dolist (op (module-beh-methods mod)) | |
| 566 | (if (method-arity op) | |
| 567 | (if (method-rules op) | |
| 568 | (push op observers) | |
| 569 | (push op ops)) | |
| 570 | (push op cong))) | |
| 571 | (dolist (op (module-beh-attributes mod)) | |
| 572 | (if (method-rules op) | |
| 573 | (push op observers) | |
| 574 | (push op ops))) | |
| 575 | (dolist (op (module-non-beh-methods mod)) | |
| 576 | (if (method-arity op) | |
| 577 | (if (method-rules op) | |
| 578 | (push op observers) | |
| 579 | (push op ops)) | |
| 580 | (push op cong))) | |
| 581 | (dolist (op (module-non-beh-attributes mod)) | |
| 582 | (unless (method-is-of-same-operator op *beh-equal*) | |
| 583 | (if (method-rules op) | |
| 584 | (push op observers) | |
| 585 | (push op ops))))) | |
| 551 | (dolist (op (module-beh-methods mod)) | |
| 552 | (if (method-arity op) | |
| 553 | (if (method-rules op) | |
| 554 | (push op observers) | |
| 555 | (push op ops)) | |
| 556 | (push op cong))) | |
| 557 | (dolist (op (module-beh-attributes mod)) | |
| 558 | (if (method-rules op) | |
| 559 | (push op observers) | |
| 560 | (push op ops))) | |
| 561 | (dolist (op (module-non-beh-methods mod)) | |
| 562 | (if (method-arity op) | |
| 563 | (if (method-rules op) | |
| 564 | (push op observers) | |
| 565 | (push op ops)) | |
| 566 | (push op cong))) | |
| 567 | (dolist (op (module-non-beh-attributes mod)) | |
| 568 | (unless (method-is-of-same-operator op *beh-equal*) | |
| 569 | (if (method-rules op) | |
| 570 | (push op observers) | |
| 571 | (push op ops))))) | |
| 586 | 572 | ;; |
| 587 | 573 | (dolist (op ops) |
| 588 | (if (check-method-congruency op observers mod) | |
| 589 | (push op cong) | |
| 590 | (push op nocong))) | |
| 574 | (if (check-method-congruency op observers mod) | |
| 575 | (push op cong) | |
| 576 | (push op nocong))) | |
| 591 | 577 | ;; |
| 592 | 578 | (setq cobasis (nconc observers nocong)) |
| 593 | 579 | ;; |
| 594 | 580 | (with-in-module (mod) |
| 595 | (dolist (op cong) | |
| 596 | (cond ((method-is-behavioural op) | |
| 597 | (when *chaos-verbose* | |
| 598 | (with-output-msg () | |
| 599 | (princ "operator ") | |
| 600 | (print-chaos-object op) | |
| 601 | (print-next) | |
| 602 | (princ "is need not be declared as bop.") | |
| 603 | ))) | |
| 604 | (t (when (method-arity op) | |
| 605 | ;; (setf (method-is-coherent op) t) | |
| 606 | (unless (method-is-coherent op) | |
| 607 | (with-output-simple-msg () | |
| 608 | (princ "** system found the operator") | |
| 609 | (print-next) | |
| 610 | (print-chaos-object op) | |
| 611 | (print-next) | |
| 612 | (princ "can be declared as coherent."))))) | |
| 613 | )) | |
| 614 | (setf (module-cobasis mod) cobasis) | |
| 615 | ) | |
| 581 | (dolist (op cong) | |
| 582 | (cond ((method-is-behavioural op) | |
| 583 | (when *chaos-verbose* | |
| 584 | (with-output-msg () | |
| 585 | (princ "operator ") | |
| 586 | (print-chaos-object op) | |
| 587 | (print-next) | |
| 588 | (princ "is need not be declared as bop.") | |
| 589 | ))) | |
| 590 | (t (when (method-arity op) | |
| 591 | ;; (setf (method-is-coherent op) t) | |
| 592 | (unless (method-is-coherent op) | |
| 593 | (with-output-simple-msg () | |
| 594 | (princ "** system found the operator") | |
| 595 | (print-next) | |
| 596 | (print-chaos-object op) | |
| 597 | (print-next) | |
| 598 | (princ "can be declared as coherent."))))) | |
| 599 | )) | |
| 600 | (setf (module-cobasis mod) cobasis) | |
| 601 | ) | |
| 616 | 602 | )) |
| 617 | ||
| 603 | ||
| 618 | 604 | (defun check-method-congruency (meth iobservers |
| 619 | &optional (module (or *current-module* | |
| 620 | *last-module*))) | |
| 605 | &optional (module (get-context-module))) | |
| 621 | 606 | (unless module |
| 622 | 607 | (with-output-panic-message () |
| 623 | 608 | (princ "congruence check: no context module!"))) |
| 626 | 611 | (return-from check-method-congruency nil)) |
| 627 | 612 | (when (sort= *huniversal-sort* hs) |
| 628 | 613 | (with-output-chaos-warning () |
| 629 | (princ "specified operator is special built-in.")) | |
| 614 | (princ "specified operator is special built-in.")) | |
| 630 | 615 | (return-from check-method-congruency nil)) |
| 631 | 616 | ;; |
| 632 | 617 | (with-in-module (module) |
| 633 | 618 | (let ((observers nil)) |
| 634 | (dolist (op iobservers) | |
| 635 | (when (find-if #'(lambda (x) (sort<= hs x)) | |
| 636 | (method-arity op)) | |
| 637 | (push op observers))) | |
| 638 | (unless observers | |
| 639 | (return-from check-method-congruency nil)) | |
| 640 | (dolist (ob observers) | |
| 641 | (let ((found nil)) | |
| 642 | (dolist (rule (method-rules ob)) | |
| 643 | (let ((lhs (axiom-lhs rule)) | |
| 644 | (subst-var nil) | |
| 645 | (rhs (axiom-rhs rule))) | |
| 646 | (multiple-value-bind (occ-l num-if-l) | |
| 647 | (find-occ lhs | |
| 648 | #'(lambda (x) | |
| 649 | (and (term-is-applform? x) | |
| 650 | (method-is-of-same-operator | |
| 651 | (term-head x) | |
| 652 | meth))) | |
| 653 | nil | |
| 654 | 0) | |
| 655 | (multiple-value-bind (occ-r num-if-r) | |
| 656 | (find-occ rhs | |
| 657 | #'(lambda (x) | |
| 658 | (and (term-is-applform? x) | |
| 659 | (method-is-of-same-operator | |
| 660 | (term-head x) | |
| 661 | meth))) | |
| 662 | nil | |
| 663 | 0) | |
| 664 | (unless (listp occ-l) | |
| 665 | (multiple-value-setq (occ-l num-if-l) | |
| 666 | (find-occ lhs | |
| 667 | #'(lambda (x) | |
| 668 | (and (term-is-variable? x) | |
| 669 | (sort<= (method-coarity meth) | |
| 670 | (term-sort x)) | |
| 671 | (setq subst-var x))) | |
| 672 | nil | |
| 673 | 0))) | |
| 674 | (when (and occ-l (not (listp occ-r)) subst-var) | |
| 675 | (multiple-value-setq (occ-r num-if-r) | |
| 676 | (find-occ rhs | |
| 677 | #'(lambda (x) | |
| 678 | (and (term-is-variable? x) | |
| 679 | (variable= x subst-var))) | |
| 680 | nil | |
| 681 | 0))) | |
| 682 | ||
| 683 | (when (and (listp occ-l) | |
| 684 | (or (not (listp occ-r)) | |
| 685 | ;; (<= (length occ-r) (length occ-l)) | |
| 686 | (<= (- (length occ-r) num-if-r) (length occ-l)) | |
| 687 | )) | |
| 688 | (setq found t) | |
| 689 | (return t)))))) ; done for all rules of an observer | |
| 690 | (unless found | |
| 691 | (return-from check-method-congruency nil)))) | |
| 692 | ;; done for all | |
| 693 | t)))) | |
| 619 | (dolist (op iobservers) | |
| 620 | (when (find-if #'(lambda (x) (sort<= hs x)) | |
| 621 | (method-arity op)) | |
| 622 | (push op observers))) | |
| 623 | (unless observers | |
| 624 | (return-from check-method-congruency nil)) | |
| 625 | (dolist (ob observers) | |
| 626 | (let ((found nil)) | |
| 627 | (dolist (rule (method-rules ob)) | |
| 628 | (let ((lhs (axiom-lhs rule)) | |
| 629 | (subst-var nil) | |
| 630 | (rhs (axiom-rhs rule))) | |
| 631 | (multiple-value-bind (occ-l num-if-l) | |
| 632 | (find-occ lhs | |
| 633 | #'(lambda (x) | |
| 634 | (and (term-is-applform? x) | |
| 635 | (method-is-of-same-operator | |
| 636 | (term-head x) | |
| 637 | meth))) | |
| 638 | nil | |
| 639 | 0) | |
| 640 | (multiple-value-bind (occ-r num-if-r) | |
| 641 | (find-occ rhs | |
| 642 | #'(lambda (x) | |
| 643 | (and (term-is-applform? x) | |
| 644 | (method-is-of-same-operator | |
| 645 | (term-head x) | |
| 646 | meth))) | |
| 647 | nil | |
| 648 | 0) | |
| 649 | (unless (listp occ-l) | |
| 650 | (multiple-value-setq (occ-l num-if-l) | |
| 651 | (find-occ lhs | |
| 652 | #'(lambda (x) | |
| 653 | (and (term-is-variable? x) | |
| 654 | (sort<= (method-coarity meth) | |
| 655 | (term-sort x)) | |
| 656 | (setq subst-var x))) | |
| 657 | nil | |
| 658 | 0))) | |
| 659 | (when (and occ-l (not (listp occ-r)) subst-var) | |
| 660 | (multiple-value-setq (occ-r num-if-r) | |
| 661 | (find-occ rhs | |
| 662 | #'(lambda (x) | |
| 663 | (and (term-is-variable? x) | |
| 664 | (variable= x subst-var))) | |
| 665 | nil | |
| 666 | 0))) | |
| 667 | ||
| 668 | (when (and (listp occ-l) | |
| 669 | (or (not (listp occ-r)) | |
| 670 | ;; (<= (length occ-r) (length occ-l)) | |
| 671 | (<= (- (length occ-r) num-if-r) (length occ-l)) | |
| 672 | )) | |
| 673 | (setq found t) | |
| 674 | (return t)))))) ; done for all rules of an observer | |
| 675 | (unless found | |
| 676 | (return-from check-method-congruency nil)))) | |
| 677 | ;; done for all | |
| 678 | t)))) | |
| 694 | 679 | ;;; |
| 695 | 680 | ;;; |
| 696 | 681 | ;;; |
| 697 | 682 | (defun substitution-image2 (sigma term) |
| 698 | 683 | (declare (type list sigma) |
| 699 | (type term)) | |
| 684 | (type term)) | |
| 700 | 685 | (let ((*consider-object* t)) |
| 701 | 686 | (cond ((or (term-is-variable? term) |
| 702 | (term-is-psuedo-constant? term)) | |
| 703 | (let ((im (variable-image-slow sigma term))) | |
| 704 | (if im | |
| 705 | (values im (sort= (variable-sort term) | |
| 706 | (term-sort im))) | |
| 707 | (values term t)))) | |
| 708 | ((term-is-builtin-constant? term) term) | |
| 709 | ((term-is-lisp-form? term) | |
| 710 | (multiple-value-bind (new success) | |
| 711 | (funcall (lisp-form-function term) sigma) | |
| 712 | (if success | |
| 713 | new | |
| 714 | term))) | |
| 715 | ((term-is-applform? term) | |
| 716 | (let ((l-result nil) | |
| 717 | (modif-sort nil)) | |
| 718 | (dolist (s-t (term-subterms term)) | |
| 719 | (multiple-value-bind (image-s-t same-sort) | |
| 720 | (substitution-image2 sigma s-t) | |
| 721 | (unless same-sort (setq modif-sort t)) | |
| 722 | (push image-s-t l-result))) | |
| 723 | (setq l-result (nreverse l-result)) | |
| 724 | (let ((method (term-head term))) | |
| 725 | (if (and (cdr l-result) | |
| 726 | (null (cddr l-result)) | |
| 727 | (method-is-identity method)) | |
| 728 | ;; head operator is binary & has identity theory | |
| 729 | (if (term-is-zero-for-method (car l-result) method) | |
| 730 | ;; ID * X --> X | |
| 731 | ;; simplify for left identity. | |
| 732 | (values (cadr l-result) | |
| 733 | (sort= (term-sort term) | |
| 734 | (term-sort (cadr l-result)))) | |
| 735 | ;; X * ID --> X | |
| 736 | (if (term-is-zero-for-method (cadr l-result) method) | |
| 737 | (values (car l-result) | |
| 738 | (sort= (term-sort term) | |
| 739 | (term-sort (car l-result)))) | |
| 740 | ;; X * Y | |
| 741 | (if modif-sort | |
| 742 | (let ((term-image (make-term-with-sort-check | |
| 743 | method l-result))) | |
| 744 | (values term-image | |
| 745 | (sort= (term-sort term) | |
| 746 | (term-sort term-image)))) | |
| 747 | (values (make-applform (term-sort term) | |
| 748 | method l-result) | |
| 749 | t) ; sort not changed | |
| 750 | ))) ; done for zero cases | |
| 751 | ;; This is the same as the previous bit of code | |
| 752 | (if modif-sort | |
| 753 | (let ((term-image (make-term-with-sort-check method | |
| 754 | l-result))) | |
| 755 | (values term-image | |
| 756 | (sort= (term-sort term) (term-sort term-image)))) | |
| 757 | (values (make-applform (method-coarity method) | |
| 758 | method l-result) | |
| 759 | t)))))) | |
| 760 | (t (break "not implemented yet")) | |
| 761 | ))) | |
| 687 | (term-is-psuedo-constant? term)) | |
| 688 | (let ((im (variable-image-slow sigma term))) | |
| 689 | (if im | |
| 690 | (values im (sort= (variable-sort term) | |
| 691 | (term-sort im))) | |
| 692 | (values term t)))) | |
| 693 | ((term-is-builtin-constant? term) term) | |
| 694 | ((term-is-lisp-form? term) | |
| 695 | (multiple-value-bind (new success) | |
| 696 | (funcall (lisp-form-function term) sigma) | |
| 697 | (if success | |
| 698 | new | |
| 699 | term))) | |
| 700 | ((term-is-applform? term) | |
| 701 | (let ((l-result nil) | |
| 702 | (modif-sort nil)) | |
| 703 | (dolist (s-t (term-subterms term)) | |
| 704 | (multiple-value-bind (image-s-t same-sort) | |
| 705 | (substitution-image2 sigma s-t) | |
| 706 | (unless same-sort (setq modif-sort t)) | |
| 707 | (push image-s-t l-result))) | |
| 708 | (setq l-result (nreverse l-result)) | |
| 709 | (let ((method (term-head term))) | |
| 710 | (if (and (cdr l-result) | |
| 711 | (null (cddr l-result)) | |
| 712 | (method-is-identity method)) | |
| 713 | ;; head operator is binary & has identity theory | |
| 714 | (if (term-is-zero-for-method (car l-result) method) | |
| 715 | ;; ID * X --> X | |
| 716 | ;; simplify for left identity. | |
| 717 | (values (cadr l-result) | |
| 718 | (sort= (term-sort term) | |
| 719 | (term-sort (cadr l-result)))) | |
| 720 | ;; X * ID --> X | |
| 721 | (if (term-is-zero-for-method (cadr l-result) method) | |
| 722 | (values (car l-result) | |
| 723 | (sort= (term-sort term) | |
| 724 | (term-sort (car l-result)))) | |
| 725 | ;; X * Y | |
| 726 | (if modif-sort | |
| 727 | (let ((term-image (make-term-with-sort-check | |
| 728 | method l-result))) | |
| 729 | (values term-image | |
| 730 | (sort= (term-sort term) | |
| 731 | (term-sort term-image)))) | |
| 732 | (values (make-applform (term-sort term) | |
| 733 | method l-result) | |
| 734 | t) ; sort not changed | |
| 735 | ))) ; done for zero cases | |
| 736 | ;; This is the same as the previous bit of code | |
| 737 | (if modif-sort | |
| 738 | (let ((term-image (make-term-with-sort-check method | |
| 739 | l-result))) | |
| 740 | (values term-image | |
| 741 | (sort= (term-sort term) (term-sort term-image)))) | |
| 742 | (values (make-applform (method-coarity method) | |
| 743 | method l-result) | |
| 744 | t)))))) | |
| 745 | (t (break "not implemented yet")) | |
| 746 | ))) | |
| 762 | 747 | ;;; EOF |
| 0 | 0 | ;;;-*- Mode:LISP; Package:CHAOS; Base:10; Syntax:Common-lisp -*- |
| 1 | 1 | ;;; |
| 2 | ;;; Copyright (c) 2000-2014, Toshimi Sawada. All rights reserved. | |
| 2 | ;;; Copyright (c) 2000-2015, Toshimi Sawada. All rights reserved. | |
| 3 | 3 | ;;; |
| 4 | 4 | ;;; Redistribution and use in source and binary forms, with or without |
| 5 | 5 | ;;; modification, are permitted provided that the following conditions |
| 27 | 27 | ;;; |
| 28 | 28 | (in-package :chaos) |
| 29 | 29 | #|============================================================================== |
| 30 | System: Chaos | |
| 31 | Module: tools | |
| 32 | File: recheck.lisp | |
| 30 | System: Chaos | |
| 31 | Module: tools | |
| 32 | File: recheck.lisp | |
| 33 | 33 | ==============================================================================|# |
| 34 | 34 | #-:chaos-debug |
| 35 | 35 | (declaim (optimize (speed 3) (safety 0) #-GCL (debug 0))) |
| 47 | 47 | ;;; methods respectively. |
| 48 | 48 | ;;; |
| 49 | 49 | (defstruct (sop (:type list)(:copier nil) |
| 50 | (:constructor create-sop (operator))) | |
| 51 | (operator nil) ; operator. | |
| 52 | (empties nil) ; set of methods whose arity contains | |
| 53 | ; some empty sort. | |
| 54 | (non-empties nil) ; non-empty methods. | |
| 50 | (:constructor create-sop (operator))) | |
| 51 | (operator nil) ; operator. | |
| 52 | (empties nil) ; set of methods whose arity contains | |
| 53 | ; some empty sort. | |
| 54 | (non-empties nil) ; non-empty methods. | |
| 55 | 55 | ) |
| 56 | 56 | |
| 57 | (defun print-sop (sop &optional (module (or *current-module* | |
| 58 | *last-module*))) | |
| 57 | (defun print-sop (sop &optional (module (get-context-module))) | |
| 59 | 58 | (with-in-module (module) |
| 60 | 59 | (format t "~%** SOP : operator ") |
| 61 | 60 | (print-chaos-object (sop-operator sop)) |
| 62 | 61 | (format t "~%-- empty methods") |
| 63 | 62 | (if (sop-empties sop) |
| 64 | (let ((*print-indent* (+ 2 *print-indent*))) | |
| 65 | (dolist (meth (sop-empties sop)) | |
| 66 | (print-next) | |
| 67 | (print-chaos-object meth))) | |
| 68 | (princ " : None")) | |
| 63 | (let ((*print-indent* (+ 2 *print-indent*))) | |
| 64 | (dolist (meth (sop-empties sop)) | |
| 65 | (print-next) | |
| 66 | (print-chaos-object meth))) | |
| 67 | (princ " : None")) | |
| 69 | 68 | (format t "~%-- non empty methods") |
| 70 | 69 | (if (sop-non-empties sop) |
| 71 | (let ((*print-indent* (+ 2 *print-indent*))) | |
| 72 | (dolist (meth (sop-non-empties sop)) | |
| 73 | (print-next) | |
| 74 | (print-chaos-object meth))) | |
| 75 | (princ " : None")))) | |
| 70 | (let ((*print-indent* (+ 2 *print-indent*))) | |
| 71 | (dolist (meth (sop-non-empties sop)) | |
| 72 | (print-next) | |
| 73 | (print-chaos-object meth))) | |
| 74 | (princ " : None")))) | |
| 76 | 75 | |
| 77 | 76 | ;;; *********** |
| 78 | 77 | ;;; SORT MARK __________________________________________________________________ |
| 90 | 89 | (defun unmark-sorts (sl) |
| 91 | 90 | (dolist (s sl) (setf (sort-is-inhabited s) nil))) |
| 92 | 91 | |
| 93 | (defmacro get-unmarked-sorts ($_?sl) ; not used? | |
| 92 | (defmacro get-unmarked-sorts ($_?sl) ; not used? | |
| 94 | 93 | ` (let (($$res_ nil)) |
| 95 | 94 | (dolist (*_s ,$_?sl) |
| 96 | (unless (sort-is-inhabited *_s) | |
| 97 | (push *_s $$res_))) | |
| 95 | (unless (sort-is-inhabited *_s) | |
| 96 | (push *_s $$res_))) | |
| 98 | 97 | $$res_)) |
| 99 | 98 | |
| 100 | 99 | ;;; ----------------------- |
| 103 | 102 | ;;; |
| 104 | 103 | (defun check-signature-empties (module) |
| 105 | 104 | (let ((esorts nil) |
| 106 | (nesorts nil) | |
| 107 | (neops nil)) | |
| 105 | (nesorts nil) | |
| 106 | (neops nil)) | |
| 108 | 107 | (clear-tmp-sort-cache) |
| 109 | 108 | (with-in-module (module) |
| 110 | 109 | (let ((sorts (module-all-sorts module)) |
| 111 | (sops nil)) | |
| 112 | ;; initially, all sorts are marked empty. | |
| 113 | (unmark-sorts sorts) | |
| 114 | ;; mark builtin sorts as non-empty | |
| 115 | (dolist (x sorts) | |
| 116 | (when (or (eq (sort-module x) *chaos-module*) | |
| 117 | (sort-is-builtin x) | |
| 118 | (and-sort-p x)) | |
| 119 | (mark-sort x) | |
| 120 | (pushnew x nesorts :test #'eq))) | |
| 121 | ;; and all operators are assumed to be empty. | |
| 122 | ;; note we ignore error operators | |
| 123 | (dolist (opinfo (module-all-operators module)) | |
| 124 | (let* ((methods (opinfo-methods opinfo)) | |
| 125 | (op-name (operator-name (opinfo-operator opinfo))) | |
| 126 | (sop (find-if #'(lambda (x) | |
| 127 | (equal op-name | |
| 128 | (operator-name (sop-operator x)))) | |
| 129 | sops))) | |
| 130 | (unless sop | |
| 131 | (setq sop (create-sop (opinfo-operator opinfo))) | |
| 132 | (push sop sops)) | |
| 133 | ;; | |
| 134 | (dolist (method methods) | |
| 135 | (unless (method-is-error-method method) | |
| 136 | (push method (sop-empties sop)) | |
| 137 | )))) | |
| 138 | ||
| 139 | ;; iterate while there are no changes in empty sorts, | |
| 140 | ;; or empty methods. | |
| 141 | (let ((changed? t)) | |
| 142 | (while changed? | |
| 143 | (setq changed? nil) | |
| 144 | ;; | |
| 145 | (dolist (sop sops) | |
| 146 | (let ((eop nil)) | |
| 147 | (dolist (method (sop-empties sop)) | |
| 148 | (if (every #'(lambda (x) (is-sort-marked? x)) | |
| 149 | (method-arity method)) | |
| 150 | (progn | |
| 151 | (setq changed? t) | |
| 152 | (push method (sop-non-empties sop)) | |
| 153 | (push method neops) | |
| 154 | (dolist (s (super-or-equal-sorts (method-coarity method))) | |
| 155 | (mark-sort s) | |
| 156 | (pushnew s nesorts :test #'eq))) | |
| 157 | (progn | |
| 158 | (push method eop)))) | |
| 159 | (setf (sop-empties sop) eop))))) | |
| 160 | ||
| 161 | ;; check is done. | |
| 162 | ;; | |
| 163 | (setq esorts | |
| 164 | (set-difference sorts | |
| 165 | nesorts :test #'eq)) | |
| 166 | (values esorts nesorts sops neops))))) | |
| 110 | (sops nil)) | |
| 111 | ;; initially, all sorts are marked empty. | |
| 112 | (unmark-sorts sorts) | |
| 113 | ;; mark builtin sorts as non-empty | |
| 114 | (dolist (x sorts) | |
| 115 | (when (or (eq (sort-module x) *chaos-module*) | |
| 116 | (sort-is-builtin x) | |
| 117 | (and-sort-p x)) | |
| 118 | (mark-sort x) | |
| 119 | (pushnew x nesorts :test #'eq))) | |
| 120 | ;; and all operators are assumed to be empty. | |
| 121 | ;; note we ignore error operators | |
| 122 | (dolist (opinfo (module-all-operators module)) | |
| 123 | (let* ((methods (opinfo-methods opinfo)) | |
| 124 | (op-name (operator-name (opinfo-operator opinfo))) | |
| 125 | (sop (find-if #'(lambda (x) | |
| 126 | (equal op-name | |
| 127 | (operator-name (sop-operator x)))) | |
| 128 | sops))) | |
| 129 | (unless sop | |
| 130 | (setq sop (create-sop (opinfo-operator opinfo))) | |
| 131 | (push sop sops)) | |
| 132 | ;; | |
| 133 | (dolist (method methods) | |
| 134 | (unless (method-is-error-method method) | |
| 135 | (push method (sop-empties sop)) | |
| 136 | )))) | |
| 137 | ||
| 138 | ;; iterate while there are no changes in empty sorts, | |
| 139 | ;; or empty methods. | |
| 140 | (let ((changed? t)) | |
| 141 | (while changed? | |
| 142 | (setq changed? nil) | |
| 143 | ;; | |
| 144 | (dolist (sop sops) | |
| 145 | (let ((eop nil)) | |
| 146 | (dolist (method (sop-empties sop)) | |
| 147 | (if (every #'(lambda (x) (is-sort-marked? x)) | |
| 148 | (method-arity method)) | |
| 149 | (progn | |
| 150 | (setq changed? t) | |
| 151 | (push method (sop-non-empties sop)) | |
| 152 | (push method neops) | |
| 153 | (dolist (s (super-or-equal-sorts (method-coarity method))) | |
| 154 | (mark-sort s) | |
| 155 | (pushnew s nesorts :test #'eq))) | |
| 156 | (progn | |
| 157 | (push method eop)))) | |
| 158 | (setf (sop-empties sop) eop))))) | |
| 159 | ||
| 160 | ;; check is done. | |
| 161 | ;; | |
| 162 | (setq esorts | |
| 163 | (set-difference sorts | |
| 164 | nesorts :test #'eq)) | |
| 165 | (values esorts nesorts sops neops))))) | |
| 167 | 166 | |
| 168 | 167 | ;;; |
| 169 | 168 | ;;; |
| 184 | 183 | (return-from regularize-make-glb (values (car sorts) nil))) |
| 185 | 184 | ;; |
| 186 | 185 | (let ((xset (mapcar #'(lambda (x) |
| 187 | (reg-direct-sub-or-equal-sorts x so)) | |
| 188 | sorts))) | |
| 186 | (reg-direct-sub-or-equal-sorts x so)) | |
| 187 | sorts))) | |
| 189 | 188 | (let ((glb nil) |
| 190 | (meets (car xset))) | |
| 191 | (dolist (xs (cdr xset)) | |
| 192 | (setq meets (intersection meets xs))) | |
| 193 | (if meets | |
| 194 | (setq meets (maximal-sorts meets so)) | |
| 195 | (setq meets (minimal-sorts sorts so))) | |
| 196 | ;; | |
| 197 | (unless (cdr meets) | |
| 198 | (when (and-sort-p (car meets)) | |
| 199 | (return-from regularize-make-glb (values (car meets) nil)))) | |
| 200 | ;; | |
| 201 | (when *regularize-debug* | |
| 202 | (format t "~&** making glb from sorts :") | |
| 203 | (print-chaos-object sorts)) | |
| 204 | ||
| 205 | (setq glb (make-glb-sort sorts module)) | |
| 206 | ;; | |
| 207 | ;; further optimization can be done here, but... | |
| 208 | ;; | |
| 209 | (let ((pre (find-if #'(lambda (x) | |
| 210 | (when *regularize-optimize* | |
| 211 | (reg-sort-included x glb so) | |
| 212 | (equal (sort-id glb) | |
| 213 | (sort-id x))) | |
| 214 | ) | |
| 215 | *regularize-glb-sorts-so-far*))) | |
| 216 | (when pre | |
| 217 | (return-from regularize-make-glb (values pre nil))) | |
| 218 | (push glb *regularize-glb-sorts-so-far*) | |
| 219 | (values glb t)))))) | |
| 189 | (meets (car xset))) | |
| 190 | (dolist (xs (cdr xset)) | |
| 191 | (setq meets (intersection meets xs))) | |
| 192 | (if meets | |
| 193 | (setq meets (maximal-sorts meets so)) | |
| 194 | (setq meets (minimal-sorts sorts so))) | |
| 195 | ;; | |
| 196 | (unless (cdr meets) | |
| 197 | (when (and-sort-p (car meets)) | |
| 198 | (return-from regularize-make-glb (values (car meets) nil)))) | |
| 199 | ;; | |
| 200 | (when *regularize-debug* | |
| 201 | (format t "~%** making glb from sorts :") | |
| 202 | (print-chaos-object sorts)) | |
| 203 | ||
| 204 | (setq glb (make-glb-sort sorts module)) | |
| 205 | ;; | |
| 206 | ;; further optimization can be done here, but... | |
| 207 | ;; | |
| 208 | (let ((pre (find-if #'(lambda (x) | |
| 209 | (when *regularize-optimize* | |
| 210 | (reg-sort-included x glb so) | |
| 211 | (equal (sort-id glb) | |
| 212 | (sort-id x))) | |
| 213 | ) | |
| 214 | *regularize-glb-sorts-so-far*))) | |
| 215 | (when pre | |
| 216 | (return-from regularize-make-glb (values pre nil))) | |
| 217 | (push glb *regularize-glb-sorts-so-far*) | |
| 218 | (values glb t)))))) | |
| 220 | 219 | |
| 221 | 220 | (defun reg-direct-subsorts (sort sort-order) |
| 222 | 221 | (cond ((and-sort-p sort) |
| 223 | (let ((subs nil)) | |
| 224 | (dolist (x (and-sort-components sort)) | |
| 225 | (dolist (s (reg-direct-subsorts x sort-order)) | |
| 226 | (pushnew s subs :test #'eq))) | |
| 227 | subs)) | |
| 228 | (t (direct-subsorts sort sort-order)))) | |
| 222 | (let ((subs nil)) | |
| 223 | (dolist (x (and-sort-components sort)) | |
| 224 | (dolist (s (reg-direct-subsorts x sort-order)) | |
| 225 | (pushnew s subs :test #'eq))) | |
| 226 | subs)) | |
| 227 | (t (direct-subsorts sort sort-order)))) | |
| 229 | 228 | |
| 230 | 229 | (defun reg-sub-or-equal-sorts (sort sort-order) |
| 231 | 230 | (cons sort (reg-direct-subsorts sort sort-order))) |
| 233 | 232 | (defun reg-direct-sub-or-equal-sorts (sort sort-order) |
| 234 | 233 | (if (and-sort-p sort) |
| 235 | 234 | (let ((subs nil)) |
| 236 | (dolist (x (and-sort-components sort)) | |
| 237 | (dolist (s (reg-direct-sub-or-equal-sorts x sort-order)) | |
| 238 | (pushnew s subs :test #'eq))) | |
| 239 | (pushnew sort subs :test #'eq)) | |
| 235 | (dolist (x (and-sort-components sort)) | |
| 236 | (dolist (s (reg-direct-sub-or-equal-sorts x sort-order)) | |
| 237 | (pushnew s subs :test #'eq))) | |
| 238 | (pushnew sort subs :test #'eq)) | |
| 240 | 239 | (cons sort (direct-subsorts sort sort-order)))) |
| 241 | 240 | |
| 242 | 241 | (defun reg-sort<= (s1 s2 so) |
| 243 | 242 | (cond ((and-sort-p s1) |
| 244 | (some #'(lambda (x) | |
| 245 | (reg-sort<= x s2 so)) | |
| 246 | (and-sort-components s1))) | |
| 247 | ((and-sort-p s2) | |
| 248 | (every #'(lambda (x) | |
| 249 | (reg-sort<= s1 x so)) | |
| 250 | (and-sort-components s2))) | |
| 251 | (t (if (sort<= s1 s2 so) | |
| 252 | t | |
| 253 | nil))) | |
| 243 | (some #'(lambda (x) | |
| 244 | (reg-sort<= x s2 so)) | |
| 245 | (and-sort-components s1))) | |
| 246 | ((and-sort-p s2) | |
| 247 | (every #'(lambda (x) | |
| 248 | (reg-sort<= s1 x so)) | |
| 249 | (and-sort-components s2))) | |
| 250 | (t (if (sort<= s1 s2 so) | |
| 251 | t | |
| 252 | nil))) | |
| 254 | 253 | ) |
| 255 | 254 | |
| 256 | 255 | ;;; assume that both s1 and s2 are and-sorts. |
| 264 | 263 | (print-next)(princ "s2 = ")(print-chaos-object s2) |
| 265 | 264 | (chaos-error 'panic))) |
| 266 | 265 | (let ((compo1 (and-sort-components s1)) |
| 267 | (compo2 (and-sort-components s2))) | |
| 266 | (compo2 (and-sort-components s2))) | |
| 268 | 267 | (every #'(lambda (x) |
| 269 | (memq x compo2)) | |
| 270 | compo1))) | |
| 268 | (memq x compo2)) | |
| 269 | compo1))) | |
| 271 | 270 | |
| 272 | 271 | (defun reg-sort-list<= (sl1 sl2 so) |
| 273 | 272 | (declare (type list sl1 sl2) |
| 274 | (type sort-order so)) | |
| 273 | (type sort-order so)) | |
| 275 | 274 | (and (= (the fixnum (length sl1)) (the fixnum (length sl2))) |
| 276 | 275 | (every #'(lambda (x y) (reg-sort<= x y so)) sl1 sl2))) |
| 277 | 276 | |
| 278 | 277 | (defun reg-sort< (s1 s2 so) |
| 279 | 278 | (cond ((and-sort-p s1) |
| 280 | (some #'(lambda (x) | |
| 281 | (reg-sort< x s2 so)) | |
| 282 | (and-sort-components s1))) | |
| 283 | ((and-sort-p s2) | |
| 284 | (every #'(lambda (x) | |
| 285 | (reg-sort< s1 x so)) | |
| 286 | (and-sort-components s2))) | |
| 287 | (t (if (sort< s1 s2 so) | |
| 288 | t | |
| 289 | nil))) | |
| 279 | (some #'(lambda (x) | |
| 280 | (reg-sort< x s2 so)) | |
| 281 | (and-sort-components s1))) | |
| 282 | ((and-sort-p s2) | |
| 283 | (every #'(lambda (x) | |
| 284 | (reg-sort< s1 x so)) | |
| 285 | (and-sort-components s2))) | |
| 286 | (t (if (sort< s1 s2 so) | |
| 287 | t | |
| 288 | nil))) | |
| 290 | 289 | ) |
| 291 | 290 | |
| 292 | 291 | (defun reg-sort-list= (sl1 sl2) |
| 297 | 296 | ;;; |
| 298 | 297 | (defun examine-regularity (module) |
| 299 | 298 | (multiple-value-bind (empty-sorts |
| 300 | non-empty-sorts | |
| 301 | sops | |
| 302 | non-empties) | |
| 299 | non-empty-sorts | |
| 300 | sops | |
| 301 | non-empties) | |
| 303 | 302 | (check-signature-empties module) |
| 304 | 303 | (declare (ignore non-empty-sorts)) |
| 305 | 304 | ;; |
| 306 | 305 | (setq *regularize-glb-sorts-so-far* (module-sorts-for-regularity module) |
| 307 | *regularize-sorts-to-be-added* nil | |
| 308 | *regularize-methods-so-far* nil | |
| 309 | *regularize-methods-to-be-added* nil) | |
| 306 | *regularize-sorts-to-be-added* nil | |
| 307 | *regularize-methods-so-far* nil | |
| 308 | *regularize-methods-to-be-added* nil) | |
| 310 | 309 | ;; |
| 311 | 310 | (with-in-module (module) |
| 312 | 311 | (let ((new-sorts nil) |
| 313 | (new-methods nil) | |
| 314 | (redundant-methods nil) | |
| 315 | (empty-methods nil)) | |
| 316 | ;; step-1 | |
| 317 | ;; make new and-sorts which are necessary for regularity. | |
| 318 | ;; for each connected component of sorts, we possibly need | |
| 319 | ;; a new and-sort. | |
| 320 | ;; and for each combination of sort ilands, we also need possibly | |
| 321 | ;; a new and-sort. | |
| 322 | ;; we make each from non-empty methods. | |
| 323 | (when *chaos-verbose* | |
| 324 | (format t "~&(checking sorts for regularity:")) | |
| 325 | (dolist (opinfo (module-all-operators module)) | |
| 326 | (block make-coarity | |
| 327 | ;; step 1.1 : first we make glb sort for connected components. | |
| 328 | (let ((entry (find-if #'(lambda (x) | |
| 329 | (equal (car x) | |
| 330 | (operator-name | |
| 331 | (opinfo-operator opinfo)))) | |
| 332 | new-sorts))) | |
| 333 | (unless entry | |
| 334 | (setq entry (cons (operator-name (opinfo-operator opinfo)) | |
| 335 | nil)) | |
| 336 | (push entry new-sorts)) | |
| 337 | ;; optimization here? eliminate builtin ops... | |
| 338 | (let ((methods (remove-if #'(lambda (x) | |
| 339 | (method-is-error-method x)) | |
| 340 | (opinfo-methods opinfo)))) | |
| 341 | (let ((new-coarity nil) | |
| 342 | (coarities nil)) | |
| 343 | (dolist (meth methods) | |
| 344 | (when (memq meth non-empties) | |
| 345 | (pushnew (method-coarity meth) coarities :test #'eq))) | |
| 346 | (unless coarities | |
| 347 | (return-from make-coarity nil)) | |
| 348 | ||
| 349 | ;; compute new coarity | |
| 350 | (multiple-value-bind (ncor new?) | |
| 351 | (regularize-make-glb coarities module) | |
| 352 | (declare (ignore new?)) | |
| 353 | (setq new-coarity ncor)) | |
| 354 | ;; | |
| 355 | (pushnew new-coarity (cdr entry) :test #'eq) | |
| 356 | (when (and-sort-p new-coarity) | |
| 357 | (pushnew new-coarity *regularize-sorts-to-be-added* | |
| 358 | :test #'eq)) | |
| 359 | ))) | |
| 360 | )) | |
| 361 | (when *chaos-verbose* (princ ")")(terpri)(force-output)) | |
| 362 | ;; step 1.2 | |
| 363 | ;; we make glb for each combinations of sort ilands. | |
| 364 | ;; note: new-sorts is the form of List[(operator-name sorts)]. | |
| 365 | #|| TOO MUCH, this is not needed. | |
| 366 | (dolist (cg new-sorts) | |
| 367 | (let ((new nil)) | |
| 368 | (do ((ss (cdr cg) (cdr ss))) | |
| 369 | ((endp ss)) | |
| 370 | (dolist (s (cdr ss)) | |
| 371 | (multiple-value-bind (glb new?) | |
| 372 | (regularize-make-glb (list (car ss) s) module) | |
| 373 | (when new? | |
| 374 | ;; note, because the disjointness, new? is the | |
| 375 | ;; tigger to add. | |
| 376 | (push glb *regularize-sorts-to-be-added*) | |
| 377 | (mark-sort glb)) | |
| 378 | (pushnew glb new :test #'eq)))) | |
| 379 | (setf (cdr cg) (nconc (cdr cg) new)) | |
| 380 | )) | |
| 381 | ||# | |
| 382 | ;; | |
| 383 | (when *regularize-debug* | |
| 384 | (format t "~%** step1 result :") | |
| 385 | (let ((*print-indent* (+ 2 *print-indent*))) | |
| 386 | (print-next) | |
| 387 | (princ "- sorts for each operator symbol :") | |
| 388 | (dolist (s new-sorts) | |
| 389 | (print-next) | |
| 390 | (print-chaos-object (car s)) | |
| 391 | (princ " : ") | |
| 392 | (print-chaos-object (cdr s))) | |
| 393 | (print-next) | |
| 394 | (princ "- sorts to be added!") | |
| 395 | (print-next) | |
| 396 | (print-chaos-object *regularize-sorts-to-be-added*))) | |
| 397 | ||
| 398 | ;;----------------------------------------------------- | |
| 399 | ;; step-2 | |
| 400 | ;; now *regularize-sorts-to-be-added* is the sufficient | |
| 401 | ;; set of and-sorts for regularity. | |
| 402 | ;; based on these, we construct new methods if need. | |
| 403 | ;; here, we consider each group of overloaded operators | |
| 404 | ;; (including ad hoc overloading), sops returned from | |
| 405 | ;; check-signature-empties organized so. | |
| 406 | ;; | |
| 407 | ||
| 408 | (when (or *chaos-verbose* *regularize-debug*) | |
| 409 | (princ "(start checking operators : ")) | |
| 410 | (dolist (sop sops) | |
| 411 | ;; step 2-1. first we construct ranks which may be | |
| 412 | ;; necessary for regularity. | |
| 413 | ;; the result will be hold in new-ranks. | |
| 414 | (let ((methods (sop-non-empties sop)) | |
| 415 | (name (operator-name (sop-operator sop))) | |
| 416 | (cent nil) | |
| 417 | (redun-methods nil) | |
| 418 | (new-ranks nil)) | |
| 419 | ;; | |
| 420 | (when (or *chaos-verbose* *regularize-debug*) | |
| 421 | (format t "~{~a~^ ~a~} " (car name))) | |
| 422 | ;; | |
| 423 | (setq cent (find-if #'(lambda (x) | |
| 424 | (equal name (car x))) | |
| 425 | new-sorts)) | |
| 426 | (unless cent (return nil)) ; no possibility | |
| 427 | ;; | |
| 428 | ;; loop until no more pssible new rank ... | |
| 429 | ;; | |
| 430 | (let ((changed? t)) | |
| 431 | (while changed? | |
| 432 | (when (or *chaos-verbose* *regularize-debug*) | |
| 433 | (princ ".") | |
| 434 | (force-output)) | |
| 435 | (setq changed? nil) | |
| 436 | (block make-new-rank | |
| 437 | ;; for each combination. | |
| 438 | (do ((mm methods (cdr mm))) | |
| 439 | ((endp mm)) | |
| 440 | (dolist (m (cdr mm)) ; makes combination | |
| 441 | (block make-rank | |
| 442 | (let ((new-ar (make-list | |
| 443 | (the fixnum | |
| 444 | (length (the list | |
| 445 | (reg-method-arity m)))))) | |
| 446 | (new-cr nil) | |
| 447 | (a1 (reg-method-arity (car mm))) | |
| 448 | (a2 (reg-method-arity m)) | |
| 449 | (c1 (reg-method-coarity (car mm))) | |
| 450 | (c2 (reg-method-coarity m))) | |
| 451 | (declare (type list a1 a2) | |
| 452 | (type sort* c1 c2)) | |
| 453 | ;; | |
| 454 | (when *regularize-debug* | |
| 455 | (let ((*print-indent* (+ 2 *print-indent*))) | |
| 456 | (print-next) | |
| 457 | (princ "- check comination of ") | |
| 458 | (print-chaos-object (car mm)) | |
| 459 | (print-next) | |
| 460 | (princ " .vs. ") | |
| 461 | (print-chaos-object m))) | |
| 462 | ;; | |
| 463 | (dotimes (x (length a1)) | |
| 464 | (declare (type fixnum x)) | |
| 465 | (multiple-value-bind (glb new?) | |
| 466 | (regularize-make-glb (list (nth x a1) | |
| 467 | (nth x a2)) | |
| 468 | module) | |
| 469 | (cond (new? (return-from make-rank nil)) | |
| 470 | ((and-sort-p glb) | |
| 471 | (unless (memq glb | |
| 472 | *regularize-sorts-to-be-added*) | |
| 473 | (return-from make-rank nil)))) | |
| 474 | (setf (nth x new-ar) glb))) | |
| 475 | ;; search for proper coarity. | |
| 476 | (multiple-value-bind (glb new?) | |
| 477 | (regularize-make-glb (list c1 c2) | |
| 478 | module) | |
| 479 | (when new? | |
| 480 | (if (and-sort-p glb) | |
| 481 | (not (every #'(lambda (x) | |
| 482 | (is-sort-marked? x)) | |
| 483 | (and-sort-components glb))) | |
| 484 | (return-from make-rank nil))) | |
| 485 | (setq new-cr glb)) | |
| 486 | ;; | |
| 487 | (unless new-cr | |
| 488 | (return-from make-rank nil)) | |
| 489 | ;; new-ar and new-cr contais possible new rank | |
| 490 | ;; for this combination. | |
| 491 | ;; we register it to new | |
| 492 | (when *regularize-debug* | |
| 493 | (let ((*print-indent* (+ *print-indent* 2))) | |
| 494 | (print-next) | |
| 495 | (princ "trying to add new rank ") | |
| 496 | (print-chaos-object (list new-ar new-cr)))) | |
| 497 | ;; | |
| 498 | ;; redundancy check | |
| 499 | ;; | |
| 500 | (multiple-value-bind (to-add? method-list redundant) | |
| 501 | (check-method-redundancy new-ar new-cr methods module) | |
| 502 | (setq redun-methods (nconc redun-methods redundant)) | |
| 503 | (when to-add? | |
| 504 | (setq changed? t) | |
| 505 | (when *regularize-debug* | |
| 506 | (princ " ... new one! added.")) | |
| 507 | (pushnew (list new-ar new-cr) new-ranks :test #'equal) | |
| 508 | (mark-sort new-cr) | |
| 509 | (pushnew new-cr *regularize-sorts-to-be-added* | |
| 510 | :test #'eq) | |
| 511 | ;; we try from new intial stage... | |
| 512 | (setq methods method-list) | |
| 513 | (return-from make-new-rank nil))) | |
| 514 | )) ; block make-rank | |
| 515 | )) ; end all possible combination of an op. | |
| 516 | ) ; block make-new-rank | |
| 517 | ) ; end of while | |
| 518 | ) | |
| 519 | ;; we end for each combination of this overloaded operators. | |
| 520 | ;; new contains new raks. | |
| 521 | (let ((*print-indent* (+ *print-indent* 2))) | |
| 522 | (when new-ranks | |
| 523 | (push (cons (sop-operator sop) | |
| 524 | new-ranks) | |
| 525 | new-methods)) | |
| 526 | (setf redundant-methods | |
| 527 | (nconc redundant-methods redun-methods)) | |
| 528 | ;; | |
| 529 | (when *regularize-debug* | |
| 530 | (print-next) | |
| 531 | (princ "- new ranks :") | |
| 532 | (if new-ranks | |
| 533 | (dolist (e new-ranks) | |
| 534 | (print-next) | |
| 535 | (print-chaos-object e)) | |
| 536 | (princ "None")))) | |
| 537 | ;; | |
| 538 | )) ; end of all operator groups. | |
| 539 | ;; | |
| 540 | ;; returns the whole result | |
| 541 | ;; | |
| 542 | (when (or *chaos-verbose* *regularize-debug*) | |
| 543 | (princ ")") | |
| 544 | (terpri) | |
| 545 | (force-output)) | |
| 546 | (dolist (sop sops) | |
| 547 | (setq empty-methods | |
| 548 | (nconc empty-methods (sop-empties sop)))) | |
| 549 | (setq empty-methods | |
| 550 | (delete-duplicates empty-methods :test #'equal)) | |
| 551 | (setq redundant-methods | |
| 552 | (delete-duplicates redundant-methods :test #'equal)) | |
| 553 | (let ((ns nil)) | |
| 554 | #|| | |
| 555 | (dolist (x new-sorts) | |
| 556 | (dolist (s (cdr x)) | |
| 557 | (when (and (and-sort-p s) | |
| 558 | (is-sort-marked? s) | |
| 559 | (not (memq s (module-sorts module)))) | |
| 560 | (pushnew s ns :test #'eq)))) | |
| 561 | ||# | |
| 562 | (dolist (s *regularize-sorts-to-be-added*) | |
| 563 | (when (and (and-sort-p s) | |
| 564 | (is-sort-marked? s) | |
| 565 | (not (memq s (module-sorts module)))) | |
| 566 | (pushnew s ns :test #'eq))) | |
| 567 | ;; | |
| 568 | (values empty-sorts | |
| 569 | ns | |
| 570 | new-methods | |
| 571 | redundant-methods | |
| 572 | empty-methods)) | |
| 573 | )))) | |
| 312 | (new-methods nil) | |
| 313 | (redundant-methods nil) | |
| 314 | (empty-methods nil)) | |
| 315 | ;; step-1 | |
| 316 | ;; make new and-sorts which are necessary for regularity. | |
| 317 | ;; for each connected component of sorts, we possibly need | |
| 318 | ;; a new and-sort. | |
| 319 | ;; and for each combination of sort ilands, we also need possibly | |
| 320 | ;; a new and-sort. | |
| 321 | ;; we make each from non-empty methods. | |
| 322 | (dolist (opinfo (module-all-operators module)) | |
| 323 | (block make-coarity | |
| 324 | ;; step 1.1 : first we make glb sort for connected components. | |
| 325 | (let ((entry (find-if #'(lambda (x) | |
| 326 | (equal (car x) | |
| 327 | (operator-name | |
| 328 | (opinfo-operator opinfo)))) | |
| 329 | new-sorts))) | |
| 330 | (unless entry | |
| 331 | (setq entry (cons (operator-name (opinfo-operator opinfo)) | |
| 332 | nil)) | |
| 333 | (push entry new-sorts)) | |
| 334 | ;; optimization here? eliminate builtin ops... | |
| 335 | (let ((methods (remove-if #'(lambda (x) | |
| 336 | (method-is-error-method x)) | |
| 337 | (opinfo-methods opinfo)))) | |
| 338 | (let ((new-coarity nil) | |
| 339 | (coarities nil)) | |
| 340 | (dolist (meth methods) | |
| 341 | (when (memq meth non-empties) | |
| 342 | (pushnew (method-coarity meth) coarities :test #'eq))) | |
| 343 | (unless coarities | |
| 344 | (return-from make-coarity nil)) | |
| 345 | ||
| 346 | ;; compute new coarity | |
| 347 | (multiple-value-bind (ncor new?) | |
| 348 | (regularize-make-glb coarities module) | |
| 349 | (declare (ignore new?)) | |
| 350 | (setq new-coarity ncor)) | |
| 351 | ;; | |
| 352 | (pushnew new-coarity (cdr entry) :test #'eq) | |
| 353 | (when (and-sort-p new-coarity) | |
| 354 | (pushnew new-coarity *regularize-sorts-to-be-added* | |
| 355 | :test #'eq)) | |
| 356 | ))) | |
| 357 | )) | |
| 358 | ;; step 1.2 | |
| 359 | ;; we make glb for each combinations of sort ilands. | |
| 360 | ;; note: new-sorts is the form of List[(operator-name sorts)]. | |
| 361 | #|| TOO MUCH, this is not needed. | |
| 362 | (dolist (cg new-sorts) | |
| 363 | (let ((new nil)) | |
| 364 | (do ((ss (cdr cg) (cdr ss))) | |
| 365 | ((endp ss)) | |
| 366 | (dolist (s (cdr ss)) | |
| 367 | (multiple-value-bind (glb new?) | |
| 368 | (regularize-make-glb (list (car ss) s) module) | |
| 369 | (when new? | |
| 370 | ;; note, because the disjointness, new? is the | |
| 371 | ;; tigger to add. | |
| 372 | (push glb *regularize-sorts-to-be-added*) | |
| 373 | (mark-sort glb)) | |
| 374 | (pushnew glb new :test #'eq)))) | |
| 375 | (setf (cdr cg) (nconc (cdr cg) new)) | |
| 376 | )) | |
| 377 | ||# | |
| 378 | ;; | |
| 379 | (when *regularize-debug* | |
| 380 | (format t "~%** step1 result :") | |
| 381 | (let ((*print-indent* (+ 2 *print-indent*))) | |
| 382 | (print-next) | |
| 383 | (princ "- sorts for each operator symbol :") | |
| 384 | (dolist (s new-sorts) | |
| 385 | (print-next) | |
| 386 | (print-chaos-object (car s)) | |
| 387 | (princ " : ") | |
| 388 | (print-chaos-object (cdr s))) | |
| 389 | (print-next) | |
| 390 | (princ "- sorts to be added!") | |
| 391 | (print-next) | |
| 392 | (print-chaos-object *regularize-sorts-to-be-added*))) | |
| 393 | ||
| 394 | ;;----------------------------------------------------- | |
| 395 | ;; step-2 | |
| 396 | ;; now *regularize-sorts-to-be-added* is the sufficient | |
| 397 | ;; set of and-sorts for regularity. | |
| 398 | ;; based on these, we construct new methods if need. | |
| 399 | ;; here, we consider each group of overloaded operators | |
| 400 | ;; (including ad hoc overloading), sops returned from | |
| 401 | ;; check-signature-empties organized so. | |
| 402 | ;; | |
| 403 | ||
| 404 | (when *regularize-debug* | |
| 405 | (princ "(start checking operators : ")) | |
| 406 | (dolist (sop sops) | |
| 407 | ;; step 2-1. first we construct ranks which may be | |
| 408 | ;; necessary for regularity. | |
| 409 | ;; the result will be hold in new-ranks. | |
| 410 | (let ((methods (sop-non-empties sop)) | |
| 411 | (name (operator-name (sop-operator sop))) | |
| 412 | (cent nil) | |
| 413 | (redun-methods nil) | |
| 414 | (new-ranks nil)) | |
| 415 | ;; | |
| 416 | (when *regularize-debug* | |
| 417 | (format t "~{~a~^ ~a~} " (car name))) | |
| 418 | ;; | |
| 419 | (setq cent (find-if #'(lambda (x) | |
| 420 | (equal name (car x))) | |
| 421 | new-sorts)) | |
| 422 | (unless cent (return nil)) ; no possibility | |
| 423 | ;; | |
| 424 | ;; loop until no more pssible new rank ... | |
| 425 | ;; | |
| 426 | (let ((changed? t)) | |
| 427 | (while changed? | |
| 428 | (when (or *chaos-verbose* *regularize-debug*) | |
| 429 | (princ ".") | |
| 430 | (force-output)) | |
| 431 | (setq changed? nil) | |
| 432 | (block make-new-rank | |
| 433 | ;; for each combination. | |
| 434 | (do ((mm methods (cdr mm))) | |
| 435 | ((endp mm)) | |
| 436 | (dolist (m (cdr mm)) ; makes combination | |
| 437 | (block make-rank | |
| 438 | (let ((new-ar (make-list | |
| 439 | (the fixnum | |
| 440 | (length (the list | |
| 441 | (reg-method-arity m)))))) | |
| 442 | (new-cr nil) | |
| 443 | (a1 (reg-method-arity (car mm))) | |
| 444 | (a2 (reg-method-arity m)) | |
| 445 | (c1 (reg-method-coarity (car mm))) | |
| 446 | (c2 (reg-method-coarity m))) | |
| 447 | (declare (type list a1 a2) | |
| 448 | (type sort* c1 c2)) | |
| 449 | ;; | |
| 450 | (when *regularize-debug* | |
| 451 | (let ((*print-indent* (+ 2 *print-indent*))) | |
| 452 | (print-next) | |
| 453 | (princ "- check comination of ") | |
| 454 | (print-chaos-object (car mm)) | |
| 455 | (print-next) | |
| 456 | (princ " .vs. ") | |
| 457 | (print-chaos-object m))) | |
| 458 | ;; | |
| 459 | (dotimes (x (length a1)) | |
| 460 | (declare (type fixnum x)) | |
| 461 | (multiple-value-bind (glb new?) | |
| 462 | (regularize-make-glb (list (nth x a1) | |
| 463 | (nth x a2)) | |
| 464 | module) | |
| 465 | (cond (new? (return-from make-rank nil)) | |
| 466 | ((and-sort-p glb) | |
| 467 | (unless (memq glb | |
| 468 | *regularize-sorts-to-be-added*) | |
| 469 | (return-from make-rank nil)))) | |
| 470 | (setf (nth x new-ar) glb))) | |
| 471 | ;; search for proper coarity. | |
| 472 | (multiple-value-bind (glb new?) | |
| 473 | (regularize-make-glb (list c1 c2) | |
| 474 | module) | |
| 475 | (when new? | |
| 476 | (if (and-sort-p glb) | |
| 477 | (not (every #'(lambda (x) | |
| 478 | (is-sort-marked? x)) | |
| 479 | (and-sort-components glb))) | |
| 480 | (return-from make-rank nil))) | |
| 481 | (setq new-cr glb)) | |
| 482 | ;; | |
| 483 | (unless new-cr | |
| 484 | (return-from make-rank nil)) | |
| 485 | ;; new-ar and new-cr contais possible new rank | |
| 486 | ;; for this combination. | |
| 487 | ;; we register it to new | |
| 488 | (when *regularize-debug* | |
| 489 | (let ((*print-indent* (+ *print-indent* 2))) | |
| 490 | (print-next) | |
| 491 | (princ "trying to add new rank ") | |
| 492 | (print-chaos-object (list new-ar new-cr)))) | |
| 493 | ;; | |
| 494 | ;; redundancy check | |
| 495 | ;; | |
| 496 | (multiple-value-bind (to-add? method-list redundant) | |
| 497 | (check-method-redundancy new-ar new-cr methods module) | |
| 498 | (setq redun-methods (nconc redun-methods redundant)) | |
| 499 | (when to-add? | |
| 500 | (setq changed? t) | |
| 501 | (when *regularize-debug* | |
| 502 | (princ " ... new one! added.")) | |
| 503 | (pushnew (list new-ar new-cr) new-ranks :test #'equal) | |
| 504 | (mark-sort new-cr) | |
| 505 | (pushnew new-cr *regularize-sorts-to-be-added* | |
| 506 | :test #'eq) | |
| 507 | ;; we try from new intial stage... | |
| 508 | (setq methods method-list) | |
| 509 | (return-from make-new-rank nil))) | |
| 510 | )) ; block make-rank | |
| 511 | )) ; end all possible combination of an op. | |
| 512 | ) ; block make-new-rank | |
| 513 | ) ; end of while | |
| 514 | ) | |
| 515 | ;; we end for each combination of this overloaded operators. | |
| 516 | ;; new contains new raks. | |
| 517 | (let ((*print-indent* (+ *print-indent* 2))) | |
| 518 | (when new-ranks | |
| 519 | (push (cons (sop-operator sop) | |
| 520 | new-ranks) | |
| 521 | new-methods)) | |
| 522 | (setf redundant-methods | |
| 523 | (nconc redundant-methods redun-methods)) | |
| 524 | ;; | |
| 525 | (when *regularize-debug* | |
| 526 | (print-next) | |
| 527 | (princ "- new ranks :") | |
| 528 | (if new-ranks | |
| 529 | (dolist (e new-ranks) | |
| 530 | (print-next) | |
| 531 | (print-chaos-object e)) | |
| 532 | (princ "None")))) | |
| 533 | ;; | |
| 534 | )) ; end of all operator groups. | |
| 535 | ;; | |
| 536 | ;; returns the whole result | |
| 537 | ;; | |
| 538 | (when (or *chaos-verbose* *regularize-debug*) | |
| 539 | (princ ")") | |
| 540 | (terpri) | |
| 541 | (force-output)) | |
| 542 | (dolist (sop sops) | |
| 543 | (setq empty-methods | |
| 544 | (nconc empty-methods (sop-empties sop)))) | |
| 545 | (setq empty-methods | |
| 546 | (delete-duplicates empty-methods :test #'equal)) | |
| 547 | (setq redundant-methods | |
| 548 | (delete-duplicates redundant-methods :test #'equal)) | |
| 549 | (let ((ns nil)) | |
| 550 | #|| | |
| 551 | (dolist (x new-sorts) | |
| 552 | (dolist (s (cdr x)) | |
| 553 | (when (and (and-sort-p s) | |
| 554 | (is-sort-marked? s) | |
| 555 | (not (memq s (module-sorts module)))) | |
| 556 | (pushnew s ns :test #'eq)))) | |
| 557 | ||# | |
| 558 | (dolist (s *regularize-sorts-to-be-added*) | |
| 559 | (when (and (and-sort-p s) | |
| 560 | (is-sort-marked? s) | |
| 561 | (not (memq s (module-sorts module)))) | |
| 562 | (pushnew s ns :test #'eq))) | |
| 563 | ;; | |
| 564 | (values empty-sorts | |
| 565 | ns | |
| 566 | new-methods | |
| 567 | redundant-methods | |
| 568 | empty-methods)) | |
| 569 | )))) | |
| 574 | 570 | |
| 575 | 571 | (defun reg-report-method (m module) |
| 576 | 572 | (cond ((operator-method-p m) |
| 577 | (print-chaos-object m)) | |
| 578 | (t (let ((name (operator-symbol (car m))) | |
| 579 | (ranks (cdr m)) | |
| 580 | (f nil)) | |
| 581 | (dolist (rank ranks) | |
| 582 | (when f (print-next)) | |
| 583 | (setq f t) | |
| 584 | (format t "~{~a~} : " name) | |
| 585 | (dolist (s (car rank)) | |
| 586 | (print-sort-name s module) | |
| 587 | (princ " ")) | |
| 588 | (princ "-> ") | |
| 589 | (print-sort-name (cadr rank) module) | |
| 590 | ))))) | |
| 573 | (print-chaos-object m)) | |
| 574 | (t (let ((name (operator-symbol (car m))) | |
| 575 | (ranks (cdr m)) | |
| 576 | (f nil)) | |
| 577 | (dolist (rank ranks) | |
| 578 | (when f (print-next)) | |
| 579 | (setq f t) | |
| 580 | (format t "~{~a~} : " name) | |
| 581 | (dolist (s (car rank)) | |
| 582 | (print-sort-name s module) | |
| 583 | (princ " ")) | |
| 584 | (princ "-> ") | |
| 585 | (print-sort-name (cadr rank) module) | |
| 586 | ))))) | |
| 591 | 587 | |
| 592 | 588 | (defun reg-method-arity (m) |
| 593 | 589 | (if (operator-method-p m) |
| 600 | 596 | (cadr m))) |
| 601 | 597 | |
| 602 | 598 | (defun check-method-redundancy (arity coarity method-list |
| 603 | &optional (module (or *current-module* | |
| 604 | *last-module*))) | |
| 599 | &optional (module (get-context-module))) | |
| 605 | 600 | (let ((so (module-sort-order module)) |
| 606 | (redundant-methods nil) | |
| 607 | (not-tobe-added? nil)) | |
| 601 | (redundant-methods nil) | |
| 602 | (not-tobe-added? nil)) | |
| 608 | 603 | (let ((new-set nil)) |
| 609 | 604 | (dolist (meth method-list) |
| 610 | (cond ((reg-sort-list= arity (reg-method-arity meth)) | |
| 611 | (when *regularize-debug* | |
| 612 | (let ((*print-indent* (+ *print-indent* 2))) | |
| 613 | (format t "~%- check redundancy with :") | |
| 614 | (print-chaos-object meth))) | |
| 615 | ;; | |
| 616 | (when (sort= (reg-method-coarity meth) coarity) | |
| 617 | (when *regularize-debug* | |
| 618 | (format t "~%- there already the same one.")) | |
| 619 | (return-from check-method-redundancy | |
| 620 | (values nil method-list nil))) | |
| 621 | ;; | |
| 622 | (if (cond ((and-sort-p coarity) | |
| 623 | (reg-sort<= coarity (reg-method-coarity meth) so)) | |
| 624 | (t (reg-sort< coarity (reg-method-coarity meth) so))) | |
| 625 | (progn | |
| 626 | (when *regularize-debug* | |
| 627 | (format t "~%- redundant..")) | |
| 628 | (push meth redundant-methods)) | |
| 629 | (progn | |
| 630 | (when *regularize-debug* | |
| 631 | (format t "~%- not redundant..")) | |
| 632 | (push meth new-set)))) | |
| 633 | (t (push meth new-set)))) | |
| 605 | (cond ((reg-sort-list= arity (reg-method-arity meth)) | |
| 606 | (when *regularize-debug* | |
| 607 | (let ((*print-indent* (+ *print-indent* 2))) | |
| 608 | (format t "~%- check redundancy with :") | |
| 609 | (print-chaos-object meth))) | |
| 610 | ;; | |
| 611 | (when (sort= (reg-method-coarity meth) coarity) | |
| 612 | (when *regularize-debug* | |
| 613 | (format t "~%- there already the same one.")) | |
| 614 | (return-from check-method-redundancy | |
| 615 | (values nil method-list nil))) | |
| 616 | ;; | |
| 617 | (if (cond ((and-sort-p coarity) | |
| 618 | (reg-sort<= coarity (reg-method-coarity meth) so)) | |
| 619 | (t (reg-sort< coarity (reg-method-coarity meth) so))) | |
| 620 | (progn | |
| 621 | (when *regularize-debug* | |
| 622 | (format t "~%- redundant..")) | |
| 623 | (push meth redundant-methods)) | |
| 624 | (progn | |
| 625 | (when *regularize-debug* | |
| 626 | (format t "~%- not redundant..")) | |
| 627 | (push meth new-set)))) | |
| 628 | (t (push meth new-set)))) | |
| 634 | 629 | ;; |
| 635 | 630 | (setq method-list new-set) |
| 636 | 631 | (unless (setq not-tobe-added? |
| 637 | (dolist (d new-set nil) | |
| 638 | (when (and (reg-sort-list= (reg-method-arity d) arity) | |
| 639 | (reg-sort< (reg-method-coarity d) coarity so)) | |
| 640 | (return t)))) | |
| 641 | (push (list arity coarity) method-list)) | |
| 632 | (dolist (d new-set nil) | |
| 633 | (when (and (reg-sort-list= (reg-method-arity d) arity) | |
| 634 | (reg-sort< (reg-method-coarity d) coarity so)) | |
| 635 | (return t)))) | |
| 636 | (push (list arity coarity) method-list)) | |
| 642 | 637 | ;; |
| 643 | 638 | (values (not not-tobe-added?) method-list redundant-methods) |
| 644 | 639 | ;; |
| 649 | 644 | ;;; |
| 650 | 645 | (defun check-regularity (module &optional (silent nil)) |
| 651 | 646 | (multiple-value-bind (empty-sorts |
| 652 | new-sorts | |
| 653 | new-methods | |
| 654 | redundant-methods | |
| 655 | empty-methods) | |
| 647 | new-sorts | |
| 648 | new-methods | |
| 649 | redundant-methods | |
| 650 | empty-methods) | |
| 656 | 651 | (examine-regularity module) |
| 657 | 652 | ;; |
| 658 | 653 | (unless (or empty-sorts new-sorts new-methods redundant-methods empty-methods) |
| 659 | 654 | (unless silent |
| 660 | (with-output-msg () | |
| 661 | (princ "signature of module ") | |
| 662 | (print-chaos-object module) | |
| 663 | (princ " is regular."))) | |
| 655 | (with-output-msg () | |
| 656 | (princ "signature of module ") | |
| 657 | (print-chaos-object module) | |
| 658 | (princ " is regular."))) | |
| 664 | 659 | (return-from check-regularity nil)) |
| 665 | 660 | ;; |
| 666 | 661 | (with-in-module (module) |
| 667 | 662 | (unless silent |
| 668 | (let ((*print-indent* (+ 2 *print-indent*))) | |
| 669 | (declare (special *print-indent*)) | |
| 670 | (when empty-sorts | |
| 671 | (with-output-simple-msg () | |
| 672 | (format t ">> The following sorts are empty:") | |
| 673 | (dolist (s empty-sorts) | |
| 674 | (print-next) | |
| 675 | (print-sort-name s module)))) | |
| 676 | (when new-sorts | |
| 677 | (with-output-simple-msg () | |
| 678 | (format t ">> The following sorts may be required for regularity:") | |
| 679 | (dolist (s new-sorts) | |
| 680 | (let ((subs (reg-direct-subsorts s (module-sort-order module)))) | |
| 681 | (print-next) | |
| 682 | (princ "[ ") | |
| 683 | (when subs | |
| 684 | (dolist (s subs) | |
| 685 | (print-sort-name s module) | |
| 686 | (princ " ")) | |
| 687 | (princ "< ")) | |
| 688 | (print-sort-name s) | |
| 689 | (princ " <") | |
| 690 | (dolist (x (and-sort-components s)) | |
| 691 | (princ " ") | |
| 692 | (print-sort-name x module)) | |
| 693 | (princ " ]"))))) | |
| 694 | (when new-methods | |
| 695 | (with-output-simple-msg () | |
| 696 | (format t ">> The following operators may be required for regularity:") | |
| 697 | (dolist (m new-methods) | |
| 698 | (print-next) | |
| 699 | (reg-report-method m module)))) | |
| 700 | (when redundant-methods | |
| 701 | (with-output-simple-msg () | |
| 702 | (format t ">> The following operators are detected as redundant,") | |
| 703 | (format t "~% due to the above new operators.") | |
| 704 | (dolist (m redundant-methods) | |
| 705 | (print-next) | |
| 706 | (reg-report-method m module)))) | |
| 707 | (when empty-methods | |
| 708 | (with-output-simple-msg () | |
| 709 | (format t ">> The following operators have empty arity:") | |
| 710 | (dolist (m empty-methods) | |
| 711 | (print-next) | |
| 712 | (reg-report-method m module))))))) | |
| 663 | (let ((*print-indent* (+ 2 *print-indent*))) | |
| 664 | (declare (special *print-indent*)) | |
| 665 | (when empty-sorts | |
| 666 | (with-output-simple-msg () | |
| 667 | (format t ">> The following sorts are empty:") | |
| 668 | (dolist (s empty-sorts) | |
| 669 | (print-next) | |
| 670 | (print-sort-name s module)))) | |
| 671 | (when new-sorts | |
| 672 | (with-output-simple-msg () | |
| 673 | (format t ">> The following sorts may be required for regularity:") | |
| 674 | (dolist (s new-sorts) | |
| 675 | (let ((subs (reg-direct-subsorts s (module-sort-order module)))) | |
| 676 | (print-next) | |
| 677 | (princ "[ ") | |
| 678 | (when subs | |
| 679 | (dolist (s subs) | |
| 680 | (print-sort-name s module) | |
| 681 | (princ " ")) | |
| 682 | (princ "< ")) | |
| 683 | (print-sort-name s) | |
| 684 | (princ " <") | |
| 685 | (dolist (x (and-sort-components s)) | |
| 686 | (princ " ") | |
| 687 | (print-sort-name x module)) | |
| 688 | (princ " ]"))))) | |
| 689 | (when new-methods | |
| 690 | (with-output-simple-msg () | |
| 691 | (format t ">> The following operators may be required for regularity:") | |
| 692 | (dolist (m new-methods) | |
| 693 | (print-next) | |
| 694 | (reg-report-method m module)))) | |
| 695 | (when redundant-methods | |
| 696 | (with-output-simple-msg () | |
| 697 | (format t ">> The following operators are detected as redundant,") | |
| 698 | (format t "~% due to the above new operators.") | |
| 699 | (dolist (m redundant-methods) | |
| 700 | (print-next) | |
| 701 | (reg-report-method m module)))) | |
| 702 | (when empty-methods | |
| 703 | (with-output-simple-msg () | |
| 704 | (format t ">> The following operators have empty arity:") | |
| 705 | (dolist (m empty-methods) | |
| 706 | (print-next) | |
| 707 | (reg-report-method m module))))))) | |
| 713 | 708 | ;; was not regular |
| 714 | 709 | t)) |
| 715 | 710 | |
| 0 | 0 | ;;;-*- Mode:LISP; Package:CHAOS; Base:10; Syntax:Common-lisp -*- |
| 1 | 1 | ;;; |
| 2 | ;;; Copyright (c) 2000-2014, Toshimi Sawada. All rights reserved. | |
| 2 | ;;; Copyright (c) 2000-2015, Toshimi Sawada. All rights reserved. | |
| 3 | 3 | ;;; |
| 4 | 4 | ;;; Redistribution and use in source and binary forms, with or without |
| 5 | 5 | ;;; modification, are permitted provided that the following conditions |
| 27 | 27 | ;;; |
| 28 | 28 | (in-package :chaos) |
| 29 | 29 | #|============================================================================== |
| 30 | System: Chaos | |
| 31 | Module: tools | |
| 32 | File: regularize.lisp | |
| 30 | System: Chaos | |
| 31 | Module: tools | |
| 32 | File: regularize.lisp | |
| 33 | 33 | ==============================================================================|# |
| 34 | 34 | #-:chaos-debug |
| 35 | 35 | (declaim (optimize (speed 3) (safety 0) #-GCL (debug 0))) |
| 53 | 53 | (let ((*print-indent* (+ *print-indent* 2))) |
| 54 | 54 | ;; init. |
| 55 | 55 | (setf (module-sorts-for-regularity module) nil |
| 56 | (module-methods-for-regularity module) nil | |
| 57 | (module-void-methods module) nil) | |
| 56 | (module-methods-for-regularity module) nil | |
| 57 | (module-void-methods module) nil) | |
| 58 | 58 | ;; |
| 59 | 59 | (multiple-value-bind (empty-sorts |
| 60 | new-sorts | |
| 61 | new-methods | |
| 62 | redundant-methods | |
| 63 | empty-methods) | |
| 64 | (examine-regularity module) | |
| 65 | ;; declare new sorts in module | |
| 66 | (dolist (new-sort new-sorts) | |
| 67 | (unless (memq new-sort (module-sorts-for-regularity module)) | |
| 68 | (push new-sort (module-sorts-for-regularity module)) | |
| 69 | (add-sort-to-module new-sort module) | |
| 70 | (declare-subsort-in-module | |
| 71 | ` ((,new-sort :< ,@(and-sort-components new-sort))) | |
| 72 | module) | |
| 73 | (unless *chaos-quiet* | |
| 74 | (let ((*standard-output* *error-output*)) | |
| 75 | (print-next) | |
| 76 | (princ "-- declaring sort [") | |
| 77 | (print-sort-name new-sort module) | |
| 78 | (princ " <") | |
| 79 | (dolist (s (and-sort-components new-sort)) | |
| 80 | (princ " ") | |
| 81 | (print-sort-name s module)) | |
| 82 | (princ "], for regularity."))) | |
| 83 | )) | |
| 84 | ;; declare new operators. | |
| 85 | (dolist (m new-methods) | |
| 86 | (let ((name (operator-symbol (car m))) | |
| 87 | (ranks (cdr m))) | |
| 88 | (dolist (rank ranks) | |
| 89 | (multiple-value-bind (op meth) | |
| 90 | (declare-operator-in-module name | |
| 91 | (car rank) | |
| 92 | (cadr rank) | |
| 93 | module) | |
| 94 | (declare (ignore op)) | |
| 95 | (unless *chaos-quiet* | |
| 96 | (let ((*standard-output* *error-output*)) | |
| 97 | (print-next) | |
| 98 | (princ "-- declaring operator ") | |
| 99 | (print-chaos-object meth) | |
| 100 | (princ " for regularity."))) | |
| 101 | (pushnew meth (module-methods-for-regularity module)) | |
| 102 | )))) | |
| 60 | new-sorts | |
| 61 | new-methods | |
| 62 | redundant-methods | |
| 63 | empty-methods) | |
| 64 | (examine-regularity module) | |
| 65 | ;; declare new sorts in module | |
| 66 | (dolist (new-sort new-sorts) | |
| 67 | (unless (memq new-sort (module-sorts-for-regularity module)) | |
| 68 | (push new-sort (module-sorts-for-regularity module)) | |
| 69 | (add-sort-to-module new-sort module) | |
| 70 | (declare-subsort-in-module | |
| 71 | ` ((,new-sort :< ,@(and-sort-components new-sort))) | |
| 72 | module) | |
| 73 | (unless *chaos-quiet* | |
| 74 | (let ((*standard-output* *error-output*)) | |
| 75 | (print-next) | |
| 76 | (princ "-- declaring sort [") | |
| 77 | (print-sort-name new-sort module) | |
| 78 | (princ " <") | |
| 79 | (dolist (s (and-sort-components new-sort)) | |
| 80 | (princ " ") | |
| 81 | (print-sort-name s module)) | |
| 82 | (princ "], for regularity."))) | |
| 83 | )) | |
| 84 | ;; declare new operators. | |
| 85 | (dolist (m new-methods) | |
| 86 | (let ((name (operator-symbol (car m))) | |
| 87 | (ranks (cdr m))) | |
| 88 | (dolist (rank ranks) | |
| 89 | (multiple-value-bind (op meth) | |
| 90 | (declare-operator-in-module name | |
| 91 | (car rank) | |
| 92 | (cadr rank) | |
| 93 | module) | |
| 94 | (declare (ignore op)) | |
| 95 | (unless *chaos-quiet* | |
| 96 | (let ((*standard-output* *error-output*)) | |
| 97 | (print-next) | |
| 98 | (princ "-- declaring operator ") | |
| 99 | (print-chaos-object meth) | |
| 100 | (princ " for regularity."))) | |
| 101 | (pushnew meth (module-methods-for-regularity module)) | |
| 102 | )))) | |
| 103 | 103 | |
| 104 | ;; set void-methods -- not used now? | |
| 105 | (dolist (m empty-methods) | |
| 106 | (pushnew m (module-void-methods module) :test #'eq)) | |
| 104 | ;; set void-methods -- not used now? | |
| 105 | (dolist (m empty-methods) | |
| 106 | (pushnew m (module-void-methods module) :test #'eq)) | |
| 107 | 107 | |
| 108 | ;; reports misc infos. | |
| 109 | (unless *chaos-quiet* | |
| 110 | (when empty-sorts | |
| 111 | (let ((*standard-output* *error-output*)) | |
| 112 | (print-next) | |
| 113 | (format t ">> The following sorts are empty:") | |
| 114 | (dolist (s empty-sorts) | |
| 115 | (print-next) | |
| 116 | (print-sort-name s module)))) | |
| 117 | (when redundant-methods | |
| 118 | (let ((*standard-output* *error-output*)) | |
| 119 | (print-next) | |
| 120 | (format t ">> The following operators are detected as redundant,") | |
| 121 | (print-next) | |
| 122 | (format t " due to the above new operators.") | |
| 123 | (dolist (m redundant-methods) | |
| 124 | (print-next) | |
| 125 | (reg-report-method m module)))) | |
| 126 | (when empty-methods | |
| 127 | (let ((*standard-output* *error-output*)) | |
| 128 | (print-next) | |
| 129 | (format t ">> The following operators have empty arity:") | |
| 130 | (dolist (m empty-methods) | |
| 131 | (print-next) | |
| 132 | (reg-report-method m module)))) | |
| 133 | ) | |
| 134 | ;; | |
| 135 | t)))) | |
| 108 | ;; reports misc infos. | |
| 109 | (unless *chaos-quiet* | |
| 110 | (when empty-sorts | |
| 111 | (let ((*standard-output* *error-output*)) | |
| 112 | (print-next) | |
| 113 | (format t ">> The following sorts are empty:") | |
| 114 | (dolist (s empty-sorts) | |
| 115 | (print-next) | |
| 116 | (print-sort-name s module)))) | |
| 117 | (when redundant-methods | |
| 118 | (let ((*standard-output* *error-output*)) | |
| 119 | (print-next) | |
| 120 | (format t ">> The following operators are detected as redundant,") | |
| 121 | (print-next) | |
| 122 | (format t " due to the above new operators.") | |
| 123 | (dolist (m redundant-methods) | |
| 124 | (print-next) | |
| 125 | (reg-report-method m module)))) | |
| 126 | (when empty-methods | |
| 127 | (let ((*standard-output* *error-output*)) | |
| 128 | (print-next) | |
| 129 | (format t ">> The following operators have empty arity:") | |
| 130 | (dolist (m empty-methods) | |
| 131 | (print-next) | |
| 132 | (reg-report-method m module)))) | |
| 133 | ) | |
| 134 | ;; | |
| 135 | t)))) | |
| 136 | 136 | |
| 137 | 137 | ;;; |
| 138 | 138 | ;;; REGULARIZE-SIGNATURE |
| 139 | 139 | ;;; |
| 140 | 140 | (defun regularize-signature (module) |
| 141 | 141 | (let ((chaos-quiet *chaos-quiet*) |
| 142 | ;; (*chaos-verbose* t) | |
| 143 | (*regularize-signature* t) | |
| 144 | (*auto-reconstruct* t)) | |
| 142 | ;; (*chaos-verbose* t) | |
| 143 | (*regularize-signature* t) | |
| 144 | (*auto-reconstruct* t)) | |
| 145 | 145 | (declare (special *regularize-signature* |
| 146 | *auto-reconstruct* | |
| 147 | ;; *chaos-verbose* | |
| 148 | *chaos-quiet*)) | |
| 146 | *auto-reconstruct* | |
| 147 | ;; *chaos-verbose* | |
| 148 | *chaos-quiet*)) | |
| 149 | 149 | (setq *chaos-quiet* nil) |
| 150 | 150 | (regularize-signature-internal module) |
| 151 | 151 | (mark-need-parsing-preparation module) |
| 0 | 0 | ;;;-*- Mode:LISP; Package:CHAOS; Base:10; Syntax:Common-lisp -*- |
| 1 | 1 | ;;; |
| 2 | ;;; Copyright (c) 2000-2014, Toshimi Sawada. All rights reserved. | |
| 2 | ;;; Copyright (c) 2000-2015, Toshimi Sawada. All rights reserved. | |
| 3 | 3 | ;;; |
| 4 | 4 | ;;; Redistribution and use in source and binary forms, with or without |
| 5 | 5 | ;;; modification, are permitted provided that the following conditions |
| 27 | 27 | ;;; |
| 28 | 28 | (in-package :chaos) |
| 29 | 29 | #|============================================================================== |
| 30 | System: Chaos | |
| 31 | Module: tools | |
| 32 | File: sensible.lisp | |
| 30 | System: Chaos | |
| 31 | Module: tools | |
| 32 | File: sensible.lisp | |
| 33 | 33 | ==============================================================================|# |
| 34 | 34 | #-:chaos-debug |
| 35 | 35 | (declaim (optimize (speed 3) (safety 0) #-GCL (debug 0))) |
| 44 | 44 | (let ((result nil)) |
| 45 | 45 | (with-in-module (module) |
| 46 | 46 | (let ((opinfos (module-all-operators module))) |
| 47 | (dolist (opinfo opinfos) | |
| 48 | (let ((r1 (check-op-sensibleness opinfo))) | |
| 49 | (when r1 (push r1 result))))) | |
| 47 | (dolist (opinfo opinfos) | |
| 48 | (let ((r1 (check-op-sensibleness opinfo))) | |
| 49 | (when r1 (push r1 result))))) | |
| 50 | 50 | (if result |
| 51 | (let ((*print-indent* 2)) | |
| 52 | (with-output-simple-msg () | |
| 53 | (format t "<< The signature of the module is not sensible.")) | |
| 54 | (print-next) | |
| 55 | (format t " The following overloaded operators make the signature non-sensible:") | |
| 56 | (dolist (op result) | |
| 57 | (dolist (p1 op) | |
| 58 | (let ((*print-indent* (+ 2 *print-indent*))) | |
| 59 | (print-next) | |
| 60 | (print-method p1 module *standard-output*))))) | |
| 61 | (when report | |
| 62 | (with-output-simple-msg () | |
| 63 | (format t "<< The signature of the module is sensible."))) | |
| 64 | )))) | |
| 51 | (let ((*print-indent* 2)) | |
| 52 | (with-output-simple-msg () | |
| 53 | (format t "<< The signature of the module is not sensible.")) | |
| 54 | (print-next) | |
| 55 | (format t " The following overloaded operators make the signature non-sensible:") | |
| 56 | (dolist (op result) | |
| 57 | (dolist (p1 op) | |
| 58 | (let ((*print-indent* (+ 2 *print-indent*))) | |
| 59 | (print-next) | |
| 60 | (print-method p1 module *standard-output*))))) | |
| 61 | (when report | |
| 62 | (with-output-simple-msg () | |
| 63 | (format t "<< The signature of the module is sensible."))) | |
| 64 | )))) | |
| 65 | 65 | |
| 66 | 66 | (defun check-op-sensibleness (opinfo) |
| 67 | 67 | (let ((methods (opinfo-methods opinfo)) |
| 68 | (vio-pair nil)) | |
| 68 | (vio-pair nil)) | |
| 69 | 69 | (do* ((ms methods (cdr ms)) |
| 70 | (method (car methods) (car methods))) | |
| 71 | ((endp (cdr ms))) | |
| 70 | (method (car methods) (car methods))) | |
| 71 | ((endp (cdr ms))) | |
| 72 | 72 | (dolist (m2 (cdr ms)) |
| 73 | (unless (is-sensible method m2) | |
| 74 | (pushnew method vio-pair) | |
| 75 | (pushnew m2 vio-pair)))) | |
| 73 | (unless (is-sensible method m2) | |
| 74 | (pushnew method vio-pair) | |
| 75 | (pushnew m2 vio-pair)))) | |
| 76 | 76 | vio-pair)) |
| 77 | 77 | |
| 78 | 78 | (defun is-sensible (m1 m2) |
| 79 | 79 | (let* ((ar-list1 (method-arity m1)) |
| 80 | (ar-list2 (method-arity m2)) | |
| 81 | (alen (length ar-list1)) | |
| 82 | (cor1 (method-coarity m1)) | |
| 83 | (cor2 (method-coarity m2))) | |
| 80 | (ar-list2 (method-arity m2)) | |
| 81 | (alen (length ar-list1)) | |
| 82 | (cor1 (method-coarity m1)) | |
| 83 | (cor2 (method-coarity m2))) | |
| 84 | 84 | (unless (is-in-same-connected-component cor1 cor2 *current-sort-order*) |
| 85 | 85 | (return-from is-sensible nil)) |
| 86 | 86 | (dotimes (x alen) |
| 87 | 87 | (unless (is-in-same-connected-component (nth x ar-list1) |
| 88 | (nth x ar-list2) | |
| 89 | *current-sort-order*) | |
| 90 | (return-from is-sensible nil))) | |
| 88 | (nth x ar-list2) | |
| 89 | *current-sort-order*) | |
| 90 | (return-from is-sensible nil))) | |
| 91 | 91 | t)) |
| 92 | 92 | |
| 93 | 93 | ;;; EOF |
| 0 | 0 | ;;;-*- Mode:LISP; Package:CHAOS; Base:10; Syntax:Common-lisp -*- |
| 1 | 1 | ;;; |
| 2 | ;;; Copyright (c) 2000-2014, Toshimi Sawada. All rights reserved. | |
| 2 | ;;; Copyright (c) 2000-2015, Toshimi Sawada. All rights reserved. | |
| 3 | 3 | ;;; |
| 4 | 4 | ;;; Redistribution and use in source and binary forms, with or without |
| 5 | 5 | ;;; modification, are permitted provided that the following conditions |
| 189 | 189 | "set path of user defined \"BOOL\" module." |
| 190 | 190 | chaos-set-bool-path) |
| 191 | 191 | ;; debug flags : invisible from user, internal use only |
| 192 | ("no" ("idcomp") parity *no-id-completion* "" nil nil t) | |
| 192 | 193 | ("sys" ("universal-sort") parity *allow-universal-sort* "" nil nil t) |
| 193 | 194 | ("debug" ("rewrite") parity *rewrite-debug* "" nil nil t) |
| 195 | ("debug" ("memo") parity *memo-debug* "" nil nil t) | |
| 194 | 196 | ("debug" ("hash") parity *on-term-hash-debug* "" nil nil t) |
| 195 | 197 | ("debug" ("axiom") parity *on-axiom-debug* "" nil nil t) |
| 196 | 198 | ("debug" ("beh") parity *beh-debug* "" nil nil t) |
| 213 | 215 | ("debug" ("apply") parity *apply-debug* "" nil nil t) |
| 214 | 216 | ("debug" ("meta") parity *debug-meta* "" nil nil t) |
| 215 | 217 | ("debug" ("citp") parity *debug-citp* "" nil nil t) |
| 218 | ("debug" ("print") parity *debug-print* "" nil nil t) | |
| 216 | 219 | )) |
| 217 | 220 | |
| 218 | 221 | (defun set-chaos-switch (which value) |
| 255 | 258 | t |
| 256 | 259 | (if (or (equal "off" x) (equal "no" x)) |
| 257 | 260 | nil |
| 258 | (progn | |
| 259 | (princ "Specify on(yes) or off(no).") (terpri) | |
| 260 | (throw 'parity-error nil))))) | |
| 261 | (progn | |
| 262 | (princ "Specify on(yes) or off(no).") (terpri) | |
| 263 | (throw 'parity-error nil))))) | |
| 261 | 264 | |
| 262 | 265 | |
| 263 | 266 | (defun show-modes (flg) |
| 270 | 273 | (let ((sw flg)) |
| 271 | 274 | (if (or (equal sw '(".")) (null sw)) |
| 272 | 275 | (show-modes t) |
| 273 | (let ((which (car flg)) | |
| 276 | (let ((which (car flg)) | |
| 274 | 277 | (sub (cdr flg)) |
| 275 | 278 | (found nil) |
| 276 | 279 | (cand nil)) |
| 277 | (dolist (sw *chaos-switches*) | |
| 280 | (dolist (sw *chaos-switches*) | |
| 278 | 281 | (block next |
| 279 | 282 | (let ((key (chaos-switch-key sw))) |
| 280 | 283 | (when (eq key :comment) (return-from next nil)) |
| 286 | 289 | (setq found sw) |
| 287 | 290 | (setq cand nil) |
| 288 | 291 | (return))))))) |
| 289 | (unless (or found cand) | |
| 292 | (unless (or found cand) | |
| 290 | 293 | (with-output-chaos-warning () |
| 291 | 294 | (format t "unknown switch ~a" flg) |
| 292 | 295 | (return-from show-modes nil))) |
| 293 | (if found | |
| 296 | (if found | |
| 294 | 297 | (show-mode found) |
| 295 | 298 | (show-mode cand))))))) |
| 296 | 299 | |
| 301 | 304 | (type (chaos-switch-type switch))) |
| 302 | 305 | (cond ((eq name :comment) |
| 303 | 306 | (format t "~%~a" (second switch))) |
| 307 | ((equal name "libpath") | |
| 308 | (format t "~%libpath~24T= ~{~a~^:~}" value)) | |
| 304 | 309 | (t (when (atom name) (setq name (list name))) |
| 305 | 310 | (if (eq type 'parity) |
| 306 | (format t "~&~{~a~^|~a~} ~{~^ ~a~} ~24T~:[off~;on~]" name option value) | |
| 307 | (progn (format t "~&~{~a~^|~a~} ~{~^ ~a~} ~24T= " name option) | |
| 311 | (format t "~%~{~a~^|~a~} ~{~^ ~a~} ~24T~:[off~;on~]" name option value) | |
| 312 | (progn (format t "~%~{~a~^|~a~} ~{~^ ~a~} ~24T= " name option) | |
| 308 | 313 | (if value |
| 309 | 314 | (print-chaos-object value) |
| 310 | 315 | (princ "not specified")))))))) |
| 318 | 323 | (t (when (atom key) (setq key (list key))) |
| 319 | 324 | (case (chaos-switch-type sw) |
| 320 | 325 | (parity |
| 321 | (format t "~& set ~{~a~^|~a~}~{~^ ~a~} {on|off} : ~a" | |
| 326 | (format t "~% set ~{~a~^|~a~}~{~^ ~a~} {on|off} : ~a" | |
| 322 | 327 | key |
| 323 | 328 | (chaos-switch-subkey sw) |
| 324 | 329 | (chaos-switch-doc sw))) |
| 325 | (otherwise (format t "~& set ~{~a~^|~a~}~{~^ ~a~} <value> : ~a" | |
| 330 | (otherwise (format t "~% set ~{~a~^|~a~}~{~^ ~a~} <value> : ~a" | |
| 326 | 331 | key |
| 327 | 332 | (chaos-switch-subkey sw) |
| 328 | 333 | (chaos-switch-doc sw)))))))))) |
| 342 | 347 | ;;; some switch setters |
| 343 | 348 | ;;; |
| 344 | 349 | (defun chaos-set-search-path (path) |
| 345 | (let* ((add (if (equal "+" (car path)) | |
| 346 | t | |
| 347 | nil)) | |
| 348 | (paths (if add (cadr path) (car path)))) | |
| 350 | (let* ((add (equal "+" (car path))) | |
| 351 | (minus (equal "-" (car path))) | |
| 352 | (paths (if (or add minus) (cadr path) (car path)))) | |
| 353 | (unless paths | |
| 354 | (with-output-chaos-warning () | |
| 355 | (format t "No pathnames are specified.") | |
| 356 | (return-from chaos-set-search-path nil))) | |
| 349 | 357 | (if add |
| 350 | 358 | (set-search-path-plus paths) |
| 351 | (set-search-path paths)))) | |
| 359 | (if minus | |
| 360 | (set-search-path-minus paths) | |
| 361 | (set-search-path paths))) | |
| 362 | (pr-search-path))) | |
| 352 | 363 | |
| 353 | 364 | (defun chaos-set-tram-path (path) |
| 354 | 365 | (let ((path (car path))) |
| 381 | 392 | (parse-integer (car value) :junk-allowed t) |
| 382 | 393 | (if (= len (length (car value))) |
| 383 | 394 | (setq *cexec-limit* num) |
| 384 | (with-output-chaos-error ('invalid-value) | |
| 385 | (format t "invalid value for exec limit: ~a" (car value)) | |
| 386 | (print-next) | |
| 387 | (princ "must be a positive integer.") ))))) | |
| 395 | (with-output-chaos-error ('invalid-value) | |
| 396 | (format t "invalid value for exec limit: ~a" (car value)) | |
| 397 | (print-next) | |
| 398 | (princ "must be a positive integer.") ))))) | |
| 388 | 399 | |
| 389 | 400 | (defun chaos-set-print-depth (value) |
| 390 | 401 | (if (or (null value) |
| 394 | 405 | (parse-integer (car value) :junk-allowed t) |
| 395 | 406 | (if (= len (length (car value))) |
| 396 | 407 | (setq *term-print-depth* num) |
| 397 | (with-output-chaos-error ('invalid-value) | |
| 398 | (format t "invalid value for term print depth: ~a" (car value)) | |
| 399 | (print-next) | |
| 400 | (princ "must be a positive integer.")))))) | |
| 408 | (with-output-chaos-error ('invalid-value) | |
| 409 | (format t "invalid value for term print depth: ~a" (car value)) | |
| 410 | (print-next) | |
| 411 | (princ "must be a positive integer.")))))) | |
| 401 | 412 | |
| 402 | 413 | (defun chaos-set-print-mode (value) |
| 403 | 414 | (case-equal (car value) |
| 0 | 0 | ;;;-*- Mode:LISP; Package:CHAOS; Base:10; Syntax:Common-lisp -*- |
| 1 | 1 | ;;; |
| 2 | ;;; Copyright (c) 2000-2014, Toshimi Sawada. All rights reserved. | |
| 2 | ;;; Copyright (c) 2000-2015, Toshimi Sawada. All rights reserved. | |
| 3 | 3 | ;;; |
| 4 | 4 | ;;; Redistribution and use in source and binary forms, with or without |
| 5 | 5 | ;;; modification, are permitted provided that the following conditions |
| 27 | 27 | ;;; |
| 28 | 28 | (in-package :chaos) |
| 29 | 29 | #|============================================================================== |
| 30 | System: CHAOS | |
| 31 | Module: tools | |
| 32 | File: show.lisp | |
| 30 | System: CHAOS | |
| 31 | Module: tools | |
| 32 | File: show.lisp | |
| 33 | 33 | ==============================================================================|# |
| 34 | 34 | #-:chaos-debug |
| 35 | 35 | (declaim (optimize (speed 3) (safety 0) #-GCL (debug 0))) |
| 47 | 47 | (let ((mod (eval-mod-ext toks))) |
| 48 | 48 | (unless mod |
| 49 | 49 | (with-output-msg () |
| 50 | (princ "no current context, `select' some module first.")) | |
| 50 | (princ "no current context, `select' some module first.")) | |
| 51 | 51 | (return-from show-context nil)) |
| 52 | (if (eq *last-module* mod) | |
| 53 | (format t "~&-- current context :") | |
| 54 | (progn (format t "~&-- context of : ") | |
| 55 | (print-chaos-object mod))) | |
| 56 | (context-push-and-move *last-module* mod) | |
| 52 | (if (eq (get-context-module t) mod) | |
| 53 | (format t "~%-- current context :") | |
| 54 | (progn (format t "~%-- context of : ") | |
| 55 | (print-chaos-object mod))) | |
| 56 | (context-push-and-move (get-context-module t) mod) | |
| 57 | 57 | (with-in-module (mod) |
| 58 | (format t "~&[module] ") | |
| 58 | (format t "~%[module] ") | |
| 59 | 59 | (print-chaos-object *current-module*) |
| 60 | 60 | (format t "~&[special bindings]") |
| 61 | 61 | (when (and $$term (not (eq $$term 'void))) |
| 62 | (unless (check-$$term-context *current-module*) | |
| 63 | (format t "~&*Notice* : term and selected subterm are not valid in the current context."))) | |
| 62 | (unless (check-$$term-context *current-module*) | |
| 63 | (format t "~&*Notice* : term and selected subterm are not valid in the current context."))) | |
| 64 | 64 | (let ((*print-indent* (+ *print-indent* 2))) |
| 65 | (print-next) | |
| 66 | (princ "$$term = ") | |
| 67 | (if (and $$term (not (eq $$term 'void))) | |
| 68 | (show-term $$term nil) | |
| 69 | (princ "none.")) | |
| 70 | (print-next) | |
| 71 | (show-apply-selection *current-module*) | |
| 72 | (show-bindings *current-module*) | |
| 73 | (show-selection-stack *current-module*) | |
| 74 | (print-pending *current-module*) | |
| 75 | (show-stop-pattern *current-module*) | |
| 76 | ;; (when *proof-tree* (pr-ptree *proof-tree*)) | |
| 77 | )) | |
| 65 | (print-next) | |
| 66 | (princ "$$term = ") | |
| 67 | (if (and $$term (not (eq $$term 'void))) | |
| 68 | (show-term $$term nil) | |
| 69 | (princ "none.")) | |
| 70 | (print-next) | |
| 71 | (show-apply-selection *current-module*) | |
| 72 | (show-bindings *current-module*) | |
| 73 | (show-selection-stack *current-module*) | |
| 74 | (print-pending *current-module*) | |
| 75 | (show-stop-pattern *current-module*) | |
| 76 | ;; (when *proof-tree* (pr-ptree *proof-tree*)) | |
| 77 | )) | |
| 78 | 78 | (context-pop-and-recover))) |
| 79 | 79 | |
| 80 | 80 | ;;; SHOW BINDINGS |
| 81 | 81 | |
| 82 | (defun show-bindings (&optional (module *last-module*)) | |
| 83 | (unless module | |
| 84 | (with-output-msg () | |
| 85 | (princ "no context (current module) is specified.") | |
| 86 | (return-from show-bindings nil))) | |
| 82 | (defun show-bindings (&optional (module (get-context-module))) | |
| 87 | 83 | (with-in-module (module) |
| 88 | 84 | (let ((bindings (module-bindings *current-module*))) |
| 89 | 85 | (format t "~&[bindings] ") |
| 90 | 86 | (if bindings |
| 91 | (dolist (bind bindings) | |
| 92 | (print-next) | |
| 93 | (format t "~a = " (car bind)) | |
| 94 | (term-print (cdr bind))) | |
| 95 | (princ "empty."))))) | |
| 87 | (dolist (bind bindings) | |
| 88 | (print-next) | |
| 89 | (format t "~a = " (car bind)) | |
| 90 | (term-print (cdr bind))) | |
| 91 | (princ "empty."))))) | |
| 96 | 92 | |
| 97 | 93 | ;;: show stop pattern |
| 98 | 94 | (defun show-stop-pattern (&rest ignore) |
| 100 | 96 | (format t "~&[stop pattern] ") |
| 101 | 97 | (if *rewrite-stop-pattern* |
| 102 | 98 | (let ((*fancy-print* nil) |
| 103 | (*print-with-sort* t)) | |
| 104 | (term-print *rewrite-stop-pattern*)) | |
| 99 | (*print-with-sort* t)) | |
| 100 | (term-print *rewrite-stop-pattern*)) | |
| 105 | 101 | (princ "not specified."))) |
| 106 | ||
| 102 | ||
| 107 | 103 | ;;; show apply selection |
| 108 | 104 | |
| 109 | (defun show-apply-selection (&optional (module *last-module*)) | |
| 110 | (unless module | |
| 111 | (with-output-msg () | |
| 112 | (princ "no context (current module) is specified.") | |
| 113 | (return-from show-apply-selection nil))) | |
| 105 | (defun show-apply-selection (&optional (module (get-context-module))) | |
| 106 | (declare (ignore module)) ; TODO | |
| 114 | 107 | (when $$term-context |
| 115 | 108 | (with-in-module ($$term-context) |
| 116 | 109 | (format t "$$subterm = ") |
| 117 | 110 | (unless $$subterm |
| 118 | (format t "no subterm selection is made by `choose'.") | |
| 119 | (return-from show-apply-selection nil)) | |
| 111 | (format t "no subterm selection is made by `choose'.") | |
| 112 | (return-from show-apply-selection nil)) | |
| 120 | 113 | (if (term-eq $$term $$subterm) |
| 121 | (format t " $$term") | |
| 122 | (show-term $$subterm nil))))) | |
| 114 | (format t " $$term") | |
| 115 | (show-term $$subterm nil))))) | |
| 123 | 116 | |
| 124 | 117 | ;;; show selection stack |
| 125 | 118 | |
| 129 | 122 | (if (null $$selection-stack) |
| 130 | 123 | (format t " empty.") |
| 131 | 124 | (let ((depth 1)) |
| 132 | (terpri) | |
| 133 | (dolist (selection $$selection-stack) | |
| 134 | (dotimes (i (1- depth)) (princ " ")) | |
| 135 | (format t "~3d| " depth) | |
| 136 | (print-simple-princ-flat selection) | |
| 137 | (terpri) | |
| 138 | (incf depth))))) | |
| 139 | ||
| 140 | ;; (format t "~&[selections] ~{~a~^ of ~}" $$selection-stack) | |
| 125 | (terpri) | |
| 126 | (dolist (selection $$selection-stack) | |
| 127 | (dotimes (i (1- depth)) (princ " ")) | |
| 128 | (format t "~3d| " depth) | |
| 129 | (print-simple-princ-flat selection) | |
| 130 | (terpri) | |
| 131 | (incf depth))))) | |
| 141 | 132 | |
| 142 | 133 | ;;; |
| 143 | 134 | ;;; print-pending |
| 144 | 135 | ;;; |
| 145 | (defun print-pending (&optional (module *last-module*)) | |
| 146 | (unless module | |
| 147 | (with-output-msg () | |
| 148 | (princ "no context (current module) is specified.") | |
| 149 | (return-from print-pending nil))) | |
| 136 | (defun print-pending (&optional (module (get-context-module))) | |
| 150 | 137 | (with-in-module (module) |
| 151 | 138 | (format t"~&[pending actions] ") |
| 152 | 139 | (if (null $$action-stack) |
| 153 | (format t " none.") | |
| 154 | (let ((depth 1)) | |
| 155 | (terpri) | |
| 156 | (dolist (dact (reverse $$action-stack)) | |
| 157 | (dotimes (i (- depth 1)) (princ " ")) | |
| 158 | (format t "~3d| in " depth) | |
| 159 | (term-print (nth 0 dact)) | |
| 160 | (princ " at ") | |
| 161 | (if (term-eq (nth 0 dact) (nth 1 dact)) | |
| 162 | (princ "top") | |
| 163 | (term-print (nth 1 dact))) | |
| 164 | (terpri) | |
| 165 | (dotimes (i depth) (princ " ")) | |
| 166 | (princ "| rule ") (print-axiom-brief (nth 2 dact)) | |
| 167 | (terpri) | |
| 168 | (dotimes (i depth) (princ " ")) | |
| 169 | (princ "| condition ") (term-print (nth 3 dact)) | |
| 170 | (princ " replacement ") (term-print (nth 4 dact)) | |
| 171 | (terpri) | |
| 172 | (incf depth) | |
| 173 | ))))) | |
| 140 | (format t " none.") | |
| 141 | (let ((depth 1)) | |
| 142 | (terpri) | |
| 143 | (dolist (dact (reverse $$action-stack)) | |
| 144 | (dotimes (i (- depth 1)) (princ " ")) | |
| 145 | (format t "~3d| in " depth) | |
| 146 | (term-print (nth 0 dact)) | |
| 147 | (princ " at ") | |
| 148 | (if (term-eq (nth 0 dact) (nth 1 dact)) | |
| 149 | (princ "top") | |
| 150 | (term-print (nth 1 dact))) | |
| 151 | (terpri) | |
| 152 | (dotimes (i depth) (princ " ")) | |
| 153 | (princ "| rule ") (print-axiom-brief (nth 2 dact)) | |
| 154 | (terpri) | |
| 155 | (dotimes (i depth) (princ " ")) | |
| 156 | (princ "| condition ") (term-print (nth 3 dact)) | |
| 157 | (princ " replacement ") (term-print (nth 4 dact)) | |
| 158 | (terpri) | |
| 159 | (incf depth) | |
| 160 | ))))) | |
| 174 | 161 | |
| 175 | 162 | ;;; ************** |
| 176 | 163 | ;;; SHOW TERM .... |
| 178 | 165 | |
| 179 | 166 | (defun show-term (target tree?) |
| 180 | 167 | (when (and tree? |
| 181 | (not (equal tree? ".")) | |
| 182 | (not (equal tree? "tree")) | |
| 183 | (not (equal tree? "graph"))) | |
| 168 | (not (equal tree? ".")) | |
| 169 | (not (equal tree? "tree")) | |
| 170 | (not (equal tree? "graph"))) | |
| 184 | 171 | (with-output-chaos-warning () |
| 185 | 172 | (format t "unknown option for `show term' : ~a" tree?)) |
| 186 | 173 | (return-from show-term nil)) |
| 187 | (unless *last-module* | |
| 174 | (unless (get-context-module t) | |
| 188 | 175 | (with-output-msg () |
| 189 | 176 | (princ "no current context, `select' some module first.") |
| 190 | 177 | (return-from show-term nil))) |
| 191 | 178 | (unless target |
| 192 | 179 | (setq target "$$term")) |
| 193 | (with-in-module (*last-module*) | |
| 180 | (with-in-module ((get-context-module)) | |
| 194 | 181 | (when (stringp target) |
| 195 | 182 | ;; let variable |
| 196 | 183 | (catch 'term-context-error |
| 197 | (let ((val (get-bound-value target))) | |
| 198 | (unless val | |
| 199 | (with-output-msg () | |
| 200 | (format t "current module has no let binding for \"~a\"" | |
| 201 | target) | |
| 202 | (return-from show-term nil) | |
| 203 | )) | |
| 204 | (setq target val)))) | |
| 184 | (let ((val (get-bound-value target))) | |
| 185 | (unless val | |
| 186 | (with-output-msg () | |
| 187 | (format t "current module has no let binding for \"~a\"" | |
| 188 | target) | |
| 189 | (return-from show-term nil))) | |
| 190 | (setq target val)))) | |
| 205 | 191 | (when (stringp target) |
| 206 | 192 | ;; cought context error |
| 207 | ;; (setq target $$term) | |
| 208 | 193 | (return-from show-term nil)) |
| 209 | 194 | (let ((*fancy-print* nil) |
| 210 | (*print-indent* (+ *print-indent* 4))) | |
| 195 | (*print-indent* (+ *print-indent* 4))) | |
| 211 | 196 | (if (and $$term-context |
| 212 | (not (check-$$term-context *current-module*))) | |
| 213 | (with-in-module ($$term-context) | |
| 214 | (format t "~&** temporarily changing current context to ") | |
| 215 | (print-simple-mod-name $$term-context) | |
| 216 | (print-next) | |
| 217 | (term-print-with-sort target) | |
| 218 | ;; (princ " : ") | |
| 219 | ;; (print-check) | |
| 220 | ;; (print-sort-name (term-sort target) *current-module*) | |
| 221 | ) | |
| 222 | (progn | |
| 223 | (term-print-with-sort target) | |
| 224 | ;; (princ " : ") | |
| 225 | ;; (print-check) | |
| 226 | ;; (print-sort-name (term-sort target) *current-module*)) | |
| 227 | )) | |
| 197 | (not (check-$$term-context *current-module*))) | |
| 198 | (with-in-module ($$term-context) | |
| 199 | (format t "~%** temporarily changing current context to ") | |
| 200 | (print-simple-mod-name $$term-context) | |
| 201 | (print-next) | |
| 202 | (term-print-with-sort target)) | |
| 203 | (progn (print-next) | |
| 204 | (term-print-with-sort target))) | |
| 228 | 205 | ;; (terpri) |
| 229 | 206 | (when (equal tree? "tree") |
| 230 | (print-term-tree target *chaos-verbose*)) | |
| 207 | (print-term-tree target *chaos-verbose*)) | |
| 231 | 208 | (when (equal tree? "graph") |
| 232 | (print-term-graph target *chaos-verbose*))))) | |
| 209 | (print-term-graph target *chaos-verbose*))))) | |
| 233 | 210 | |
| 234 | 211 | ;;; ************ |
| 235 | 212 | ;;; SHOW MOD ... |
| 236 | 213 | ;;; ************ |
| 237 | 214 | (defun print-mod (toks &optional (desc nil)) |
| 238 | 215 | (let ((mod (if (not (equal "tree" (car toks))) |
| 239 | toks | |
| 240 | (cdr toks))) | |
| 241 | (tree (equal (car toks) "tree"))) | |
| 216 | toks | |
| 217 | (cdr toks))) | |
| 218 | (tree (equal (car toks) "tree"))) | |
| 242 | 219 | (let ((modval (eval-mod-ext mod))) |
| 243 | 220 | (when modval |
| 244 | (if tree | |
| 245 | (if desc | |
| 246 | (describe-module-graph (module-dag modval)) | |
| 247 | (print-module-graph modval)) | |
| 248 | (if desc | |
| 249 | (describe-module modval) | |
| 250 | (show-module modval))))))) | |
| 221 | (if tree | |
| 222 | (if desc | |
| 223 | (describe-module-graph (module-dag modval)) | |
| 224 | (print-module-graph modval)) | |
| 225 | (if desc | |
| 226 | (describe-module modval) | |
| 227 | (show-module modval))))))) | |
| 251 | 228 | |
| 252 | 229 | ;;; ************* |
| 253 | 230 | ;;; SHOW VIEW ... |
| 256 | 233 | (declare (ignore desc)) |
| 257 | 234 | (let ((view (find-view-in-env (normalize-modexp (car toks))))) |
| 258 | 235 | (if view |
| 259 | (print-view view *standard-output* nil nil) | |
| 260 | (with-output-chaos-error ('no-such-view) | |
| 261 | (format t "no such view : ~a" (car toks)) | |
| 262 | )))) | |
| 236 | (print-view view *standard-output* nil nil) | |
| 237 | (with-output-chaos-error ('no-such-view) | |
| 238 | (format t "no such view : ~a" (car toks)) | |
| 239 | )))) | |
| 263 | 240 | |
| 264 | 241 | ;;; ********** |
| 265 | 242 | ;;; SHOW SORTS |
| 266 | 243 | ;;; ********** |
| 267 | 244 | (defun show-sorts (toks &optional (desc nil) (all nil)) |
| 268 | 245 | (let ((mod (if (not (equal "tree" (car toks))) |
| 269 | toks | |
| 270 | (cdr toks))) | |
| 271 | (tree (equal (car toks) "tree"))) | |
| 246 | toks | |
| 247 | (cdr toks))) | |
| 248 | (tree (equal (car toks) "tree"))) | |
| 272 | 249 | (let ((modval (eval-mod-ext mod))) |
| 273 | 250 | (when modval |
| 274 | (if tree | |
| 275 | (print-module-sort-graph modval) | |
| 276 | (print-module-sorts modval desc all)))))) | |
| 251 | (if tree | |
| 252 | (print-module-sort-graph modval) | |
| 253 | (print-module-sorts modval desc all)))))) | |
| 277 | 254 | |
| 278 | 255 | ;;; ******** |
| 279 | 256 | ;;; SHOW OPS |
| 327 | 304 | (let ((mod (eval-mod-ext toks)) (i 1)) |
| 328 | 305 | (with-in-module (mod) |
| 329 | 306 | (!setup-reduction mod) |
| 330 | (format t "~& -- rewrite rules in module : ") | |
| 307 | (format t "~% -- rewrite rules in module : ") | |
| 331 | 308 | (print-simple-mod-name mod) |
| 332 | 309 | (dolist (r (get-module-axioms mod t)) |
| 333 | (format t "~&~3D : " i) | |
| 334 | (print-axiom-brief r) | |
| 335 | (incf i)) | |
| 310 | (format t "~&~3D : " i) | |
| 311 | (print-axiom-brief r) | |
| 312 | (incf i)) | |
| 336 | 313 | ))) |
| 337 | 314 | |
| 338 | 315 | ;;; ********* |
| 358 | 335 | (let ((mod (eval-mod-ext toks))) |
| 359 | 336 | (let ((num (print$mod-num mod))) |
| 360 | 337 | (if (= 0 num) |
| 361 | (princ "(...)") | |
| 362 | (progn (princ "MOD") (prin1 num)) | |
| 363 | ) | |
| 338 | (princ "(...)") | |
| 339 | (progn (princ "MOD") (prin1 num)) | |
| 340 | ) | |
| 364 | 341 | (princ " is ") |
| 365 | 342 | (let ((*print-abbrev-mod* nil)) |
| 366 | (print-mod-name mod)) | |
| 343 | (print-mod-name mod)) | |
| 367 | 344 | (terpri)))) |
| 368 | 345 | |# |
| 369 | 346 | |
| 381 | 358 | (defun show-sort (toks &optional (desc nil)) |
| 382 | 359 | (declare (ignore desc)) |
| 383 | 360 | (let* ((tree? (equal (car toks) "tree")) |
| 384 | (sort (if tree? | |
| 385 | (cdr toks) | |
| 386 | toks)) | |
| 387 | (mod nil)) | |
| 361 | (sort (if tree? | |
| 362 | (cdr toks) | |
| 363 | toks)) | |
| 364 | (mod nil)) | |
| 388 | 365 | (multiple-value-bind (sort-n modexp) |
| 389 | (check-qualified-sort-name sort) | |
| 366 | (check-qualified-sort-name sort) | |
| 390 | 367 | (cond (modexp |
| 391 | (setq mod (eval-modexp modexp)) | |
| 392 | #|| | |
| 393 | (find-module-in-env-ext modexp (or | |
| 394 | *current-module* | |
| 395 | *last-module*) | |
| 396 | :no-error) | |
| 397 | ||# | |
| 398 | (unless (module-p mod) | |
| 399 | (with-output-msg () | |
| 400 | (format t "no such module ~a" modexp) | |
| 401 | (return-from show-sort nil)))) | |
| 402 | (t (setq mod (or *current-module* | |
| 403 | *last-module*)) | |
| 404 | (unless (module-p mod) | |
| 405 | (with-output-msg () | |
| 406 | (princ "no context(current) module, select some first.") | |
| 407 | (return-from show-sort nil))))) | |
| 368 | (setq mod (eval-modexp modexp)) | |
| 369 | (unless (module-p mod) | |
| 370 | (with-output-msg () | |
| 371 | (format t "no such module ~a" modexp) | |
| 372 | (return-from show-sort nil)))) | |
| 373 | (t (setq mod (get-context-module)))) | |
| 408 | 374 | (with-in-module (mod) |
| 409 | (let ((srt (find-sort-in mod sort-n))) | |
| 410 | (if srt | |
| 411 | (if tree? | |
| 412 | (print-sort-graph srt) | |
| 413 | (describe-sort srt)) | |
| 414 | (with-output-msg () | |
| 415 | (format t "no such sort ~a" sort-n)))))))) | |
| 375 | (let ((srt (find-sort-in mod sort-n))) | |
| 376 | (if srt | |
| 377 | (if tree? | |
| 378 | (print-sort-graph srt) | |
| 379 | (describe-sort srt)) | |
| 380 | (with-output-msg () | |
| 381 | (format t "no such sort ~a" sort-n)))))))) | |
| 416 | 382 | |
| 417 | 383 | ;;; ******* |
| 418 | 384 | ;;; SHOW OP |
| 420 | 386 | (defun parse-op-name (tokens) |
| 421 | 387 | (let ((res nil)) |
| 422 | 388 | (if tokens |
| 423 | (progn | |
| 424 | (when (and (null (cdr tokens)) | |
| 425 | (stringp (car tokens))) | |
| 426 | (setq tokens (read-opname-from-string (car tokens)))) | |
| 427 | (let ((*modexp-parse-input* tokens)) | |
| 428 | (let ((val (parse-operator-reference nil))) | |
| 429 | (if (null *modexp-parse-input*) | |
| 430 | (setq res val))) | |
| 431 | res)) | |
| 389 | (progn | |
| 390 | (when (and (null (cdr tokens)) | |
| 391 | (stringp (car tokens))) | |
| 392 | (setq tokens (read-opname-from-string (car tokens)))) | |
| 393 | (let ((*modexp-parse-input* tokens)) | |
| 394 | (let ((val (parse-operator-reference nil))) | |
| 395 | (when *on-modexp-debug* | |
| 396 | (format t "[parse-op-name] *modexp... = ~s" *modexp-parse-input*)) | |
| 397 | (when (or (null *modexp-parse-input*) | |
| 398 | (and (null (cdr *modexp-parse-input*)) | |
| 399 | (equal "." (car *modexp-parse-input*)))) | |
| 400 | (setq res val)) | |
| 401 | res))) | |
| 432 | 402 | nil))) |
| 433 | 403 | |
| 434 | 404 | (defun get-module-from-opref (parsedop) |
| 435 | 405 | (let ((mod nil)) |
| 436 | 406 | (cond ((%opref-module parsedop) |
| 437 | #|| | |
| 438 | (setq mod (find-module-in-env-ext (%opref-module parsedop) | |
| 439 | (or *current-module* | |
| 440 | *last-module*) | |
| 441 | :no-error)) | |
| 442 | ||# | |
| 443 | (setq mod (%opref-module parsedop)) | |
| 444 | (unless (module-p mod) | |
| 445 | (setq mod (eval-modexp (%opref-module parsedop))) | |
| 446 | (unless (module-p mod) | |
| 447 | (with-output-chaos-error ('no-such-module) | |
| 448 | (princ "resolving operator reference ") | |
| 449 | (print-ast parsedop) | |
| 450 | (print-next) | |
| 451 | (princ "no such module ") | |
| 452 | (princ (%opref-module parsedop)))))) | |
| 453 | (t (setq mod (or *current-module* | |
| 454 | *last-module*)) | |
| 455 | (unless mod | |
| 456 | (with-output-chaos-error ('no-context) | |
| 457 | (princ "no context module is given."))))) | |
| 407 | (setq mod (%opref-module parsedop)) | |
| 408 | (unless (module-p mod) | |
| 409 | (setq mod (eval-modexp (%opref-module parsedop))) | |
| 410 | (unless (module-p mod) | |
| 411 | (with-output-chaos-error ('no-such-module) | |
| 412 | (princ "resolving operator reference ") | |
| 413 | (print-ast parsedop) | |
| 414 | (print-next) | |
| 415 | (princ "no such module ") | |
| 416 | (princ (%opref-module parsedop)))))) | |
| 417 | (t (setq mod (get-context-module)))) | |
| 458 | 418 | mod)) |
| 459 | 419 | |
| 460 | 420 | (defun resolve-operator-reference (opref &optional (no-error nil)) |
| 461 | 421 | (let ((mod (get-module-from-opref opref))) |
| 462 | 422 | (!setup-reduction mod) |
| 463 | 423 | (with-in-module (mod) |
| 464 | (let ((ops (find-all-qual-operators-in mod (%opref-name opref)))) | |
| 465 | (unless ops | |
| 466 | (if no-error | |
| 467 | (with-output-msg () | |
| 468 | (princ "no such operator") | |
| 469 | (print-chaos-object opref)) | |
| 470 | (with-output-chaos-error ('no-such-op) | |
| 471 | (princ "no such operator") | |
| 472 | (print-chaos-object opref)))) | |
| 473 | (values ops mod))))) | |
| 424 | (let* ((name (%opref-name opref)) | |
| 425 | (ops (find-all-qual-operators-in mod name))) | |
| 426 | (unless ops | |
| 427 | (when (equal "." (car (last name))) | |
| 428 | (setq name (butlast name)) | |
| 429 | (setq ops (find-all-qual-operators-in mod name)))) | |
| 430 | (unless ops | |
| 431 | (if no-error | |
| 432 | (with-output-simple-msg () | |
| 433 | (format t "no such operator: ~a " name) | |
| 434 | (return-from resolve-operator-reference | |
| 435 | (values nil mod))) | |
| 436 | (with-output-chaos-error ('no-such-op) | |
| 437 | (format t "no such operator: ~a" name)))) | |
| 438 | (values ops mod))))) | |
| 474 | 439 | |
| 475 | 440 | (defun show-op (toks &optional (desc nil)) |
| 476 | 441 | (let ((parsedop (parse-op-name toks))) |
| 477 | 442 | (multiple-value-bind (ops mod) |
| 478 | (resolve-operator-reference parsedop t) | |
| 443 | (resolve-operator-reference parsedop t) | |
| 479 | 444 | (with-in-module (mod) |
| 480 | (dolist (op ops) | |
| 481 | (if desc | |
| 482 | (describe-operator op) | |
| 483 | (describe-operator-brief op)))) | |
| 484 | ))) | |
| 445 | (dolist (op ops) | |
| 446 | (if desc | |
| 447 | (describe-operator op) | |
| 448 | (describe-operator-brief op))))))) | |
| 485 | 449 | |
| 486 | 450 | ;;; ******** |
| 487 | 451 | ;;; SHOW SUB |
| 488 | 452 | ;;; ******** |
| 489 | 453 | (defun show-sub (toks no &optional describe) |
| 490 | 454 | (let* ((mod (eval-mod-ext toks)) |
| 491 | (sub (nth-sub no mod))) | |
| 455 | (sub (nth-sub no mod))) | |
| 492 | 456 | (if sub |
| 493 | (progn | |
| 494 | (with-in-module (sub) | |
| 495 | (if describe | |
| 496 | (describe-module sub) | |
| 497 | (show-module sub)) | |
| 498 | (terpri))) | |
| 499 | (with-output-msg () | |
| 500 | (princ "no such sub-module"))) | |
| 457 | (progn | |
| 458 | (with-in-module (sub) | |
| 459 | (if describe | |
| 460 | (describe-module sub) | |
| 461 | (show-module sub)) | |
| 462 | (terpri))) | |
| 463 | (with-output-msg () | |
| 464 | (princ "no such sub-module"))) | |
| 501 | 465 | )) |
| 502 | 466 | |
| 503 | 467 | ;;; *********** |
| 505 | 469 | ;;; *********** |
| 506 | 470 | (defun show-param (toks no &optional describe) |
| 507 | 471 | (let ((mod (if toks |
| 508 | (eval-mod-ext toks) | |
| 509 | (or *last-module* *current-module*)))) | |
| 510 | (unless mod | |
| 511 | (with-output-msg () | |
| 512 | (format t "no context (current module) is specified.") | |
| 513 | (return-from show-param nil))) | |
| 472 | (eval-mod-ext toks) | |
| 473 | (get-context-module)))) | |
| 474 | (when (modexp-is-error mod) | |
| 475 | (with-output-chaos-error ('invalid-modexp) | |
| 476 | (format t "Invalid module expression: ~s" toks))) | |
| 514 | 477 | (let ((param (find-parameterized-submodule no mod))) |
| 515 | 478 | (if (and param (not (modexp-is-error param))) |
| 516 | (progn | |
| 517 | (with-in-module (param) | |
| 518 | (if describe | |
| 519 | (describe-module param) | |
| 520 | (show-module param))) | |
| 521 | (terpri)) | |
| 522 | (with-output-msg () | |
| 523 | (if (null (module-parameters mod)) | |
| 524 | (princ "module has no parameters.") | |
| 525 | (format t "no such parameter ~a" (if (integerp no) | |
| 526 | (1+ no) | |
| 527 | no)))))) | |
| 528 | )) | |
| 479 | (progn | |
| 480 | (with-in-module (param) | |
| 481 | (if describe | |
| 482 | (describe-module param) | |
| 483 | (show-module param))) | |
| 484 | (terpri)) | |
| 485 | (with-output-msg () | |
| 486 | (if (null (module-parameters mod)) | |
| 487 | (princ "module has no parameters.") | |
| 488 | (format t "no such parameter ~a" (if (integerp no) | |
| 489 | (1+ no) | |
| 490 | no)))))))) | |
| 529 | 491 | |
| 530 | 492 | ;;; ************ |
| 531 | 493 | ;;; SHOW MODULES |
| 533 | 495 | (defun print-modules (x) |
| 534 | 496 | (declare (ignore x)) |
| 535 | 497 | (let ((*print-indent-contin* nil) |
| 536 | (*print-line-limit* 80) | |
| 537 | (mods nil)) | |
| 498 | (*print-line-limit* 80) | |
| 499 | (mods nil)) | |
| 538 | 500 | (dolist (entry *modules-so-far-table*) |
| 539 | 501 | (let ((m (cdr entry))) |
| 540 | (cond ((or (module-hidden m) (module-is-parameter-theory m)) | |
| 541 | (when (or *on-debug* *chaos-verbose*) | |
| 542 | (push m mods))) | |
| 543 | (t (unless (equal (module-name m) "%") (push m mods)))))) | |
| 502 | (cond ((or (module-hidden m) (module-is-parameter-theory m)) | |
| 503 | (when (or *on-debug* *chaos-verbose*) | |
| 504 | (push m mods))) | |
| 505 | (t (unless (equal (module-name m) "%") (push m mods)))))) | |
| 544 | 506 | ;; |
| 545 | 507 | (dolist (m (sort mods #'ob< :key #'(lambda (x) |
| 546 | (let ((name (module-name x))) | |
| 547 | (if (atom name) | |
| 548 | name | |
| 549 | (car name)))))) | |
| 508 | (let ((name (module-name x))) | |
| 509 | (if (atom name) | |
| 510 | name | |
| 511 | (car name)))))) | |
| 550 | 512 | (print-check) |
| 551 | 513 | (when (< 0 (filecol *standard-output*)) |
| 552 | (princ " ")) | |
| 514 | (princ " ")) | |
| 553 | 515 | ;; (print-modexp-simple m) |
| 554 | 516 | (print-mod-name m *standard-output* t t) |
| 555 | 517 | (print-check)) |
| 563 | 525 | (let ((*print-indent-contin* nil)) |
| 564 | 526 | #|| |
| 565 | 527 | (maphash #'(lambda (key m) |
| 566 | (declare (ignore m)) | |
| 567 | (print-check) | |
| 568 | (when (< 0 (filecol *standard-output*)) | |
| 569 | (princ " ")) | |
| 570 | (princ key) | |
| 571 | (print-check)) | |
| 572 | *modexp-view-table*) | |
| 528 | (declare (ignore m)) | |
| 529 | (print-check) | |
| 530 | (when (< 0 (filecol *standard-output*)) | |
| 531 | (princ " ")) | |
| 532 | (princ key) | |
| 533 | (print-check)) | |
| 534 | *modexp-view-table*) | |
| 573 | 535 | ||# |
| 574 | 536 | (dolist (entry *modexp-view-table*) |
| 575 | 537 | (let ((key (car entry))) |
| 576 | (print-check) | |
| 577 | (when (< 0 (filecol *standard-output*)) | |
| 578 | (princ " ")) | |
| 579 | (princ key) | |
| 580 | (print-check))) | |
| 538 | (print-check) | |
| 539 | (when (< 0 (filecol *standard-output*)) | |
| 540 | (princ " ")) | |
| 541 | (princ key) | |
| 542 | (print-check))) | |
| 581 | 543 | )) |
| 582 | 544 | |
| 583 | 545 | ;;; |
| 591 | 553 | (print-mod-name *memoized-module*) |
| 592 | 554 | (dump-term-hash *term-memo-table*))) |
| 593 | 555 | |
| 556 | ;;; | |
| 557 | ;;; print-term-horizontal | |
| 558 | ;;; | |
| 559 | (defun print-term-horizontal (term module &optional (stream *standard-output*)) | |
| 560 | (with-in-module (module) | |
| 561 | (let ((*standard-output* stream)) | |
| 562 | (print-next) | |
| 563 | (cond ((term-is-applform? term) | |
| 564 | (format t "~{~a~}" (method-symbol (term-head term))) | |
| 565 | (dotimes (x (length (term-subterms term))) | |
| 566 | (let ((*print-indent* (+ 4 *print-indent*))) | |
| 567 | (print-term-horizontal (term-arg-n term x) module)))) | |
| 568 | ((term-is-builtin-constant? term) | |
| 569 | (term-print term)) | |
| 570 | (t (print-chaos-object term)))))) | |
| 594 | 571 | ;;; EOF |
| 0 | 0 | ;;;-*- Mode:LISP; Package:CHAOS; Base:10; Syntax:Common-lisp -*- |
| 1 | 1 | ;;; |
| 2 | ;;; Copyright (c) 2000-2014, Toshimi Sawada. All rights reserved. | |
| 2 | ;;; Copyright (c) 2000-2015, Toshimi Sawada. All rights reserved. | |
| 3 | 3 | ;;; |
| 4 | 4 | ;;; Redistribution and use in source and binary forms, with or without |
| 5 | 5 | ;;; modification, are permitted provided that the following conditions |
| 27 | 27 | ;;; |
| 28 | 28 | (in-package :chaos) |
| 29 | 29 | #|============================================================================== |
| 30 | System: CHAOS | |
| 30 | System: CHAOS | |
| 31 | 31 | Module: tools |
| 32 | File: sort-tree.lisp | |
| 32 | File: sort-tree.lisp | |
| 33 | 33 | ==============================================================================|# |
| 34 | 34 | #-:chaos-debug |
| 35 | 35 | (declaim (optimize (speed 3) (safety 0) #-GCL (debug 0))) |
| 39 | 39 | (defun make-module-sort-tree (mod) |
| 40 | 40 | (prepare-for-parsing mod) |
| 41 | 41 | (let* ((sorder (module-sort-order mod)) |
| 42 | (kinds (get-kinds sorder)) | |
| 43 | (sls (module-sort-relations mod))) | |
| 42 | (kinds (get-kinds sorder)) | |
| 43 | (sls (module-sort-relations mod))) | |
| 44 | 44 | (labels ((make-tree (s) |
| 45 | (let ((sl (assq s sls))) | |
| 46 | (if sl | |
| 47 | (cons s (mapcar #'(lambda (x) (make-tree x)) | |
| 48 | (maximal-sorts (_subsorts sl) sorder))) | |
| 49 | (list s))))) | |
| 45 | (let ((sl (assq s sls))) | |
| 46 | (if sl | |
| 47 | (cons s (mapcar #'(lambda (x) (make-tree x)) | |
| 48 | (maximal-sorts (_subsorts sl) sorder))) | |
| 49 | (list s))))) | |
| 50 | 50 | (mapc #'(lambda (k) |
| 51 | (setf (cdr k) | |
| 52 | (maximal-sorts (cdr k) sorder))) | |
| 53 | kinds) | |
| 51 | (setf (cdr k) | |
| 52 | (maximal-sorts (cdr k) sorder))) | |
| 53 | kinds) | |
| 54 | 54 | (mapc #'(lambda (k) |
| 55 | (setf (cdr k) | |
| 56 | (mapcar #'(lambda (x) (make-tree x)) | |
| 57 | (cdr k)))) | |
| 58 | kinds) | |
| 55 | (setf (cdr k) | |
| 56 | (mapcar #'(lambda (x) (make-tree x)) | |
| 57 | (cdr k)))) | |
| 58 | kinds) | |
| 59 | 59 | kinds))) |
| 60 | 60 | |
| 61 | (defun make-sort-tree (sort &optional (mod (or *current-module* *last-module*))) | |
| 61 | (defun make-sort-tree (sort &optional (mod (get-object-context sort))) | |
| 62 | 62 | (let* ((so (module-sort-order mod)) |
| 63 | (kind (the-err-sort sort so)) | |
| 64 | (sls (module-sort-relations mod)) | |
| 65 | (fam (maximal-sorts (get-family kind so) so))) | |
| 63 | (kind (the-err-sort sort so)) | |
| 64 | (sls (module-sort-relations mod)) | |
| 65 | (fam (maximal-sorts (get-family kind so) so))) | |
| 66 | 66 | (labels ((make-tree (s) |
| 67 | (let ((sl (assq s sls))) | |
| 68 | (if sl | |
| 69 | (cons s (mapcar #'(lambda (x) (make-tree x)) | |
| 70 | (maximal-sorts (_subsorts sl) so))) | |
| 71 | (list s))))) | |
| 67 | (let ((sl (assq s sls))) | |
| 68 | (if sl | |
| 69 | (cons s (mapcar #'(lambda (x) (make-tree x)) | |
| 70 | (maximal-sorts (_subsorts sl) so))) | |
| 71 | (list s))))) | |
| 72 | 72 | (cons kind |
| 73 | (mapcar #'(lambda (x) (make-tree x)) fam))))) | |
| 73 | (mapcar #'(lambda (x) (make-tree x)) fam))))) | |
| 74 | 74 | |
| 75 | 75 | ;;; PRINT-SORT-TREE |
| 76 | 76 | |
| 77 | 77 | (defun print-sort-tree (sort &optional |
| 78 | (stream *standard-output*) | |
| 79 | (mod (or *current-module* *last-module*))) | |
| 78 | (stream *standard-output*) | |
| 79 | (mod (get-object-context sort))) | |
| 80 | 80 | (!print-sort-tree sort stream mod nil)) |
| 81 | 81 | |
| 82 | 82 | (defun print-sort-graph (sort &optional |
| 83 | (stream *standard-output*) | |
| 84 | (mod (or *current-module* *last-module*))) | |
| 83 | (stream *standard-output*) | |
| 84 | (mod (get-object-context sort))) | |
| 85 | 85 | (!print-sort-tree sort stream mod t)) |
| 86 | 86 | |
| 87 | 87 | (defun !print-sort-tree (sort stream mod show-as-graph) |
| 88 | 88 | (let* ((leaf? #'(lambda (tree) (null (cdr tree)))) |
| 89 | (leaf-name #'(lambda (tree) | |
| 90 | (with-output-to-string (str) | |
| 91 | (print-sort-name (car tree) mod str) | |
| 92 | str))) | |
| 93 | (leaf-info #'(lambda (tree) (declare (ignore tree)) t)) | |
| 94 | (int-node-name #'(lambda (tree) | |
| 95 | (funcall leaf-name tree))) | |
| 96 | (int-node-children #'(lambda (tree) (cdr tree)))) | |
| 89 | (leaf-name #'(lambda (tree) | |
| 90 | (with-output-to-string (str) | |
| 91 | (print-sort-name (car tree) mod str) | |
| 92 | str))) | |
| 93 | (leaf-info #'(lambda (tree) (declare (ignore tree)) t)) | |
| 94 | (int-node-name #'(lambda (tree) | |
| 95 | (funcall leaf-name tree))) | |
| 96 | (int-node-children #'(lambda (tree) (cdr tree)))) | |
| 97 | 97 | (force-output stream) |
| 98 | 98 | (print-next nil *print-indent* stream) |
| 99 | 99 | (print-trees (list (if show-as-graph |
| 100 | (augment-tree-as-graph (make-sort-tree sort mod)) | |
| 101 | (augment-tree (make-sort-tree sort mod)))) | |
| 102 | stream))) | |
| 100 | (augment-tree-as-graph (make-sort-tree sort mod)) | |
| 101 | (augment-tree (make-sort-tree sort mod)))) | |
| 102 | stream))) | |
| 103 | 103 | |
| 104 | 104 | ;;; PRINT-MODULE-SORT-TREE |
| 105 | 105 | |
| 106 | (defun print-module-sort-tree (&optional (mod (or *current-module* *last-module*)) | |
| 107 | (stream *standard-output*)) | |
| 106 | (defun print-module-sort-tree (&optional (mod (get-context-module)) | |
| 107 | (stream *standard-output*)) | |
| 108 | 108 | (!print-module-sort-tree mod stream nil)) |
| 109 | 109 | |
| 110 | (defun print-module-sort-graph (&optional (mod (or *current-module* *last-module*)) | |
| 111 | (stream *standard-output*)) | |
| 110 | (defun print-module-sort-graph (&optional (mod (get-context-module)) | |
| 111 | (stream *standard-output*)) | |
| 112 | 112 | (!print-module-sort-tree mod stream t)) |
| 113 | 113 | |
| 114 | 114 | (defun !print-module-sort-tree (mod stream show-as-graph) |
| 115 | 115 | (let* ((leaf? #'(lambda (tree) (null (cdr tree)))) |
| 116 | (leaf-name #'(lambda (tree) | |
| 117 | (with-output-to-string (str) | |
| 118 | (print-sort-name (car tree) mod str) | |
| 119 | str))) | |
| 120 | (leaf-info #'(lambda (tree) (declare (ignore tree)) t)) | |
| 121 | (int-node-name #'(lambda (tree) | |
| 122 | (funcall leaf-name tree))) | |
| 123 | (int-node-children #'(lambda (tree) (cdr tree)))) | |
| 116 | (leaf-name #'(lambda (tree) | |
| 117 | (with-output-to-string (str) | |
| 118 | (print-sort-name (car tree) mod str) | |
| 119 | str))) | |
| 120 | (leaf-info #'(lambda (tree) (declare (ignore tree)) t)) | |
| 121 | (int-node-name #'(lambda (tree) | |
| 122 | (funcall leaf-name tree))) | |
| 123 | (int-node-children #'(lambda (tree) (cdr tree)))) | |
| 124 | 124 | (dolist (tree (make-module-sort-tree mod)) |
| 125 | 125 | (force-output stream) |
| 126 | 126 | (print-next nil *print-indent* stream) |
| 127 | 127 | (princ "------------------------------------------------------------") |
| 128 | 128 | (print-next nil *print-indent* stream) |
| 129 | 129 | (print-trees (list (if show-as-graph |
| 130 | (augment-tree-as-graph tree) | |
| 131 | (augment-tree tree))) | |
| 132 | stream)))) | |
| 130 | (augment-tree-as-graph tree) | |
| 131 | (augment-tree tree))) | |
| 132 | stream)))) | |
| 133 | 133 | |
| 134 | 134 | ;;; EOF |
| 0 | 0 | ;;;-*-Mode:LISP; Package: CHAOS; Base:10; Syntax:Common-lisp -*- |
| 1 | 1 | ;;; |
| 2 | ;;; Copyright (c) 2000-2014, Toshimi Sawada. All rights reserved. | |
| 2 | ;;; Copyright (c) 2000-2015, Toshimi Sawada. All rights reserved. | |
| 3 | 3 | ;;; |
| 4 | 4 | ;;; Redistribution and use in source and binary forms, with or without |
| 5 | 5 | ;;; modification, are permitted provided that the following conditions |
| 144 | 144 | ;; |
| 145 | 145 | (with-output-chaos-error ('tram-fail) |
| 146 | 146 | (format t "failed to invoke TRAM compiler") |
| 147 | (when *last-module* | |
| 148 | (context-pop-and-recover)) | |
| 149 | )) | |
| 147 | (when (get-context-module) | |
| 148 | (context-pop-and-recover)))) | |
| 150 | 149 | |
| 151 | 150 | ;; |
| 152 | 151 | (setq *tram_in_file* in-file |
| 153 | 152 | *tram_out_file* out-file) |
| 154 | 153 | |
| 155 | #|| | |
| 156 | ;; wait for a while untill i/o files are prepared | |
| 157 | (dotimes (x 30) | |
| 158 | x | |
| 159 | (sleep 1) | |
| 160 | (when (probe-file in-file) (return nil))) | |
| 161 | ||# | |
| 162 | ||
| 163 | 154 | ;; try open streams |
| 164 | 155 | (setq out-stream (open out-file |
| 165 | 156 | :direction :output |
| 171 | 162 | (unless (and in-stream out-stream) |
| 172 | 163 | (with-output-chaos-error ('tram-fail) |
| 173 | 164 | (format t "failed to open TRAM I/O streams") |
| 174 | (when *last-module* | |
| 175 | (context-pop-and-recover)) | |
| 176 | )) | |
| 177 | (setq *tram-process* (cons in-stream out-stream)) | |
| 178 | )) | |
| 165 | (when (get-context-module) | |
| 166 | (context-pop-and-recover)))) | |
| 167 | (setq *tram-process* (cons in-stream out-stream)))) | |
| 179 | 168 | |
| 180 | 169 | (defun kill-tram-process () |
| 181 | 170 | (setq *tram-last-module* nil) |
| 289 | 278 | (format t "Unkonwn TRAM term ~s is returned.~ |
| 290 | 279 | ~% This can happen if signature is not regular..." |
| 291 | 280 | tram-term) |
| 292 | (when *last-module* | |
| 281 | (when (get-context-module) | |
| 293 | 282 | (context-pop-and-recover)) |
| 294 | 283 | (chaos-error 'tram-panic))))))) |
| 295 | 284 | |
| 751 | 740 | ;;; TRAM-COMPILE-CHAOS-MODULE |
| 752 | 741 | ;;; |
| 753 | 742 | (defun tram-compile-chaos-module (&optional all? |
| 754 | (module (or *current-module* | |
| 755 | *last-module*)) | |
| 743 | (module (get-context-module)) | |
| 756 | 744 | debug) |
| 757 | 745 | ;; |
| 758 | 746 | (unless debug (run-tram-process-if-need)) |
| 0 | 0 | ;;;-*-Mode:LISP; Package: Chaos; Base:10; Syntax:Common-lisp -*- |
| 1 | 1 | ;;; |
| 2 | ;;; Copyright (c) 2000-2014, Toshimi Sawada. All rights reserved. | |
| 2 | ;;; Copyright (c) 2000-2015, Toshimi Sawada. All rights reserved. | |
| 3 | 3 | ;;; |
| 4 | 4 | ;;; Redistribution and use in source and binary forms, with or without |
| 5 | 5 | ;;; modification, are permitted provided that the following conditions |
| 0 | 0 | ;;;-*-Mode:LISP; Package: Chaos; Base:10; Syntax:Common-lisp -*- |
| 1 | 1 | ;;; |
| 2 | ;;; Copyright (c) 2000-2014, Toshimi Sawada. All rights reserved. | |
| 2 | ;;; Copyright (c) 2000-2015, Toshimi Sawada. All rights reserved. | |
| 3 | 3 | ;;; |
| 4 | 4 | ;;; Redistribution and use in source and binary forms, with or without |
| 5 | 5 | ;;; modification, are permitted provided that the following conditions |
| 0 | 0 | ;;;-*-Mode:LISP; Package: CHAOS; Base:10; Syntax:Common-lisp -*- |
| 1 | 1 | ;;; |
| 2 | ;;; Copyright (c) 2000-2014, Toshimi Sawada. All rights reserved. | |
| 2 | ;;; Copyright (c) 2000-2015, Toshimi Sawada. All rights reserved. | |
| 3 | 3 | ;;; |
| 4 | 4 | ;;; Redistribution and use in source and binary forms, with or without |
| 5 | 5 | ;;; modification, are permitted provided that the following conditions |
| 0 | 0 | ;;; |
| 1 | ;;; Copyright (c) 2000-2014, Toshimi Sawada. All rights reserved. | |
| 1 | ;;; Copyright (c) 2000-2015, Toshimi Sawada. All rights reserved. | |
| 2 | 2 | ;;; |
| 3 | 3 | ;;; Redistribution and use in source and binary forms, with or without |
| 4 | 4 | ;;; modification, are permitted provided that the following conditions |
| 0 | 0 | ;;;-*- Mode:LISP; Package: COMMON-LISP-USER; Base:10; Syntax:Common-Lisp -*- |
| 1 | 1 | ;;; |
| 2 | ;;; Copyright (c) 2000-2014, Toshimi Sawada. All rights reserved. | |
| 2 | ;;; Copyright (c) 2000-2015, Toshimi Sawada. All rights reserved. | |
| 3 | 3 | ;;; |
| 4 | 4 | ;;; Redistribution and use in source and binary forms, with or without |
| 5 | 5 | ;;; modification, are permitted provided that the following conditions |
| 101 | 101 | |
| 102 | 102 | (defpackage "CHAOS" |
| 103 | 103 | (:shadow "METHOD-NAME" |
| 104 | "METHOD" | |
| 105 | "MAKE-METHOD" | |
| 106 | #-:GCL "OBJECT" | |
| 107 | ;; #+(:ALLEGRO-VERSION>= 7.0) "WHILE" | |
| 108 | #+:EXCL | |
| 109 | "CLASS" | |
| 110 | "TIMER" | |
| 111 | "MODULE" | |
| 112 | "MODULE-P" | |
| 113 | "LOAD-FILE" | |
| 114 | ) | |
| 104 | "METHOD" | |
| 105 | "MAKE-METHOD" | |
| 106 | #-:GCL "OBJECT" | |
| 107 | ;; #+(:ALLEGRO-VERSION>= 7.0) "WHILE" | |
| 108 | #+:EXCL | |
| 109 | "CLASS" | |
| 110 | "TIMER" | |
| 111 | "MODULE" | |
| 112 | "MODULE-P" | |
| 113 | "LOAD-FILE" | |
| 114 | ) | |
| 115 | 115 | (:use #+:GCL "LISP" #-:GCL "COMMON-LISP" |
| 116 | ;; "FMCS" | |
| 117 | #+:MCL "CCL" #+:EXCL "EXCL" | |
| 118 | #+:GCL "DEFPACKAGE" | |
| 119 | ;; #+:common-graphics "COMMON-GRAPHICS" | |
| 120 | ) | |
| 116 | ;; "FMCS" | |
| 117 | #+:MCL "CCL" #+:EXCL "EXCL" | |
| 118 | #+:GCL "DEFPACKAGE" | |
| 119 | ;; #+:common-graphics "COMMON-GRAPHICS" | |
| 120 | ) | |
| 121 | 121 | ) |
| 122 | 122 | |
| 123 | 123 | |
| 1173 | 1173 | (symbol-value symbol)) |
| 1174 | 1174 | output-list))) |
| 1175 | 1175 | #-(or :cormanlisp :clisp) |
| 1176 | (format t "~&~S ~<~;~^~A~@{~:@_~A~}~;~:>" symbol output-list) | |
| 1176 | (format t "~%~S ~<~;~^~A~@{~:@_~A~}~;~:>" symbol output-list) | |
| 1177 | 1177 | #+(or :cormanlisp :clisp) |
| 1178 | 1178 | (loop for line in output-list |
| 1179 | do (format t "~&~S ~A" symbol line))) | |
| 1179 | do (format t "~%~S ~A" symbol line))) | |
| 1180 | 1180 | (condition () |
| 1181 | 1181 | ;; this seems to be necessary due to some errors I encountered |
| 1182 | 1182 | ;; with LispWorks |
| 0 | 0 | ;;;-*- Mode:Lisp; Syntax:Common-Lisp; Package:CHAOS -*- |
| 1 | 1 | ;;; |
| 2 | ;;; Copyright (c) 2000-2014, Toshimi Sawada. All rights reserved. | |
| 2 | ;;; Copyright (c) 2000-2015, Toshimi Sawada. All rights reserved. | |
| 3 | 3 | ;;; |
| 4 | 4 | ;;; Redistribution and use in source and binary forms, with or without |
| 5 | 5 | ;;; modification, are permitted provided that the following conditions |
| 27 | 27 | ;;; |
| 28 | 28 | (in-package :CHAOS) |
| 29 | 29 | #|============================================================================== |
| 30 | System: Chaos | |
| 31 | Module: comlib | |
| 32 | File: dag.lisp | |
| 30 | System: Chaos | |
| 31 | Module: comlib | |
| 32 | File: dag.lisp | |
| 33 | 33 | ==============================================================================|# |
| 34 | 34 | #-:chaos-debug |
| 35 | 35 | (declaim (optimize (speed 3) (safety 0) #-GCL (debug 0))) |
| 53 | 53 | (once-only (dag) |
| 54 | 54 | `(setf (dag-node-subnodes ,dag) |
| 55 | 55 | (nconc (dag-node-subnodes ,dag) |
| 56 | (mapcar #'(lambda (d) (create-dag-node d nil)) | |
| 57 | ,datums))))) | |
| 56 | (mapcar #'(lambda (d) (create-dag-node d nil)) | |
| 57 | ,datums))))) | |
| 58 | 58 | |
| 59 | 59 | (defmacro push-sub-node (dag datum) |
| 60 | 60 | `(push (create-dag-node ,datum nil) |
| 61 | (dag-node-subnodes ,dag))) | |
| 61 | (dag-node-subnodes ,dag))) | |
| 62 | 62 | |
| 63 | 63 | ;;; |
| 64 | 64 | (defmacro dag-node-is-marked? (node) `(dag-node-flag ,node)) |
| 77 | 77 | ;;; |
| 78 | 78 | (defun dag-dfs (dag &optional (function #'identity)) |
| 79 | 79 | (declare (type dag-node dag) |
| 80 | (type (or symbol function) function) | |
| 81 | (values t)) | |
| 80 | (type (or symbol function) function) | |
| 81 | (values t)) | |
| 82 | 82 | (labels ((do-dag-dfs (d) |
| 83 | (unless (dag-node-is-marked? d) | |
| 84 | (dolist (sub (dag-node-subnodes d)) | |
| 85 | (unless (dag-node-is-marked? sub) | |
| 86 | (do-dag-dfs sub))) | |
| 87 | (funcall function d) | |
| 88 | (mark-dag-node d)))) | |
| 83 | (unless (dag-node-is-marked? d) | |
| 84 | (dolist (sub (dag-node-subnodes d)) | |
| 85 | (unless (dag-node-is-marked? sub) | |
| 86 | (do-dag-dfs sub))) | |
| 87 | (funcall function d) | |
| 88 | (mark-dag-node d)))) | |
| 89 | 89 | (unmark-all-dag-nodes dag) |
| 90 | 90 | (do-dag-dfs dag))) |
| 91 | 91 | |
| 94 | 94 | ;;; |
| 95 | 95 | (defun dag-wfs (dag &optional (function #'identity)) |
| 96 | 96 | (declare (type dag-node dag) |
| 97 | (type (or symbol function) function) | |
| 98 | (values t)) | |
| 97 | (type (or symbol function) function) | |
| 98 | (values t)) | |
| 99 | 99 | (labels ((do-dag-wfs (ld) |
| 100 | (dolist (d ld) | |
| 101 | (unless (dag-node-is-marked? d) | |
| 102 | (funcall function d) | |
| 103 | (mark-dag-node d))) | |
| 104 | (dolist (d ld) | |
| 105 | (do-dag-wfs (dag-node-subnodes d))))) | |
| 100 | (dolist (d ld) | |
| 101 | (unless (dag-node-is-marked? d) | |
| 102 | (funcall function d) | |
| 103 | (mark-dag-node d))) | |
| 104 | (dolist (d ld) | |
| 105 | (do-dag-wfs (dag-node-subnodes d))))) | |
| 106 | 106 | (unmark-all-dag-nodes dag) |
| 107 | 107 | (do-dag-wfs (list dag)))) |
| 108 | 108 | |
| 115 | 115 | (once-only (subnodes datum) |
| 116 | 116 | `(let ((bdag (make-bdag :datum ,datum :subnodes ,subnodes :parent nil))) |
| 117 | 117 | (dolist (s ,subnodes) |
| 118 | (setf (bdag-parent s) bdag)) | |
| 118 | (setf (bdag-parent s) bdag)) | |
| 119 | 119 | bdag))) |
| 120 | 120 | |
| 121 | 121 | (defmacro add-bdag-subnodes (bdag datums) |
| 122 | 122 | (once-only (bdag datums) |
| 123 | 123 | `(setf (dag-node-subnodes ,bdag) |
| 124 | 124 | (nconc (dag-node-subnodes ,bdag) |
| 125 | (mapcar #'(lambda (d) | |
| 126 | (let ((sub (create-bdag-node d nil))) | |
| 127 | (setf (bdag-parent sub) ,bdag) | |
| 128 | sub)) | |
| 129 | ,datums))))) | |
| 125 | (mapcar #'(lambda (d) | |
| 126 | (let ((sub (create-bdag-node d nil))) | |
| 127 | (setf (bdag-parent sub) ,bdag) | |
| 128 | sub)) | |
| 129 | ,datums))))) | |
| 130 | 130 | |
| 131 | 131 | (defmacro push-bdag-node (dag datum) |
| 132 | 132 | (once-only (dag) |
| 133 | 133 | `(push (let ((s (create-bdag-node ,datum nil))) |
| 134 | (setf (bdag-parent s) ,dag) | |
| 135 | s) | |
| 136 | (dag-node-subnodes ,dag)))) | |
| 134 | (setf (bdag-parent s) ,dag) | |
| 135 | s) | |
| 136 | (dag-node-subnodes ,dag)))) | |
| 137 | 137 | |
| 138 | 138 | |
| 139 | 139 | (defun get-bdag-parents (bdag) |
| 140 | 140 | (declare (type bdag bdag)) |
| 141 | 141 | (let ((res nil) |
| 142 | (parent (bdag-parent bdag))) | |
| 142 | (parent (bdag-parent bdag))) | |
| 143 | 143 | (while parent |
| 144 | 144 | (push parent res) |
| 145 | 145 | (setq parent (bdag-parent parent))) |
| 0 | 0 | ;;;-*- Mode:LISP; Package:CHAOS; Base:10; Syntax:Common-lisp -*- |
| 1 | 1 | ;;; |
| 2 | ;;; Copyright (c) 2000-2014, Toshimi Sawada. All rights reserved. | |
| 2 | ;;; Copyright (c) 2000-2015, Toshimi Sawada. All rights reserved. | |
| 3 | 3 | ;;; |
| 4 | 4 | ;;; Redistribution and use in source and binary forms, with or without |
| 5 | 5 | ;;; modification, are permitted provided that the following conditions |
| 27 | 27 | ;;; |
| 28 | 28 | (in-package :chaos) |
| 29 | 29 | #|============================================================================== |
| 30 | System: CHAOS | |
| 31 | Module: comlib | |
| 32 | File: error.lisp | |
| 30 | System: CHAOS | |
| 31 | Module: comlib | |
| 32 | File: error.lisp | |
| 33 | 33 | ==============================================================================|# |
| 34 | 34 | #-:chaos-debug |
| 35 | 35 | (declaim (optimize (speed 3) (safety 0) #-GCL (debug 0))) |
| 69 | 69 | (defmacro with-chaos-error ((&optional error-proc) &body body) |
| 70 | 70 | (if error-proc |
| 71 | 71 | ` (let ((ret-val nil)) |
| 72 | (let ((val (catch 'chaos-main-error | |
| 73 | (setq ret-val | |
| 74 | (progn ,@body)) | |
| 75 | nil))) | |
| 76 | (if val | |
| 77 | (funcall ,error-proc val) | |
| 78 | ret-val))) | |
| 79 | ` (let ((ret-val nil)) | |
| 80 | (let ((val (catch 'chaos-main-error | |
| 81 | (setq ret-val | |
| 82 | (progn ,@body)) | |
| 83 | nil))) | |
| 84 | (if val | |
| 85 | (let ((std-proc (get-chaos-error-proc val))) | |
| 86 | (if std-proc | |
| 87 | (funcall std-proc val) | |
| 88 | (chaos-to-top))) | |
| 89 | ret-val))))) | |
| 72 | (let ((val (catch 'chaos-main-error | |
| 73 | (setq ret-val | |
| 74 | (progn ,@body)) | |
| 75 | nil))) | |
| 76 | (if val | |
| 77 | (funcall ,error-proc val) | |
| 78 | ret-val))) | |
| 79 | ` (let ((ret-val nil)) | |
| 80 | (let ((val (catch 'chaos-main-error | |
| 81 | (setq ret-val | |
| 82 | (progn ,@body)) | |
| 83 | nil))) | |
| 84 | (if val | |
| 85 | (let ((std-proc (get-chaos-error-proc val))) | |
| 86 | (if std-proc | |
| 87 | (funcall std-proc val) | |
| 88 | (chaos-to-top))) | |
| 89 | ret-val))))) | |
| 90 | 90 | |
| 91 | 91 | (defun chaos-indicate-position () |
| 92 | 92 | (unless *suppress-err-handler-msg* |
| 93 | (when *chaos-input-source* ; nil means may be from terminal | |
| 94 | (format t "~&filename: ~a" (namestring *chaos-input-source*)) | |
| 93 | (when *chaos-input-source* ; nil means may be from terminal | |
| 94 | (format t "~%filename: ~a" (namestring *chaos-input-source*)) | |
| 95 | 95 | (when (file-position *standard-input*) |
| 96 | (format t " in top-level form ending at character position: ~d" | |
| 97 | (file-position *standard-input*))) | |
| 96 | (format t " in top-level form ending at character position: ~d" | |
| 97 | (file-position *standard-input*))) | |
| 98 | 98 | (terpri)))) |
| 99 | 99 | |
| 100 | 100 | (defun chaos-to-top (&rest ignore) |
| 108 | 108 | (defmacro with-chaos-top-error ((&optional error-proc) &body body) |
| 109 | 109 | (if error-proc |
| 110 | 110 | ` (let ((ret-val nil)) |
| 111 | (let ((val (catch 'chaos-top-level-error | |
| 112 | (setq ret-val | |
| 113 | (progn ,@body)) | |
| 114 | nil))) | |
| 115 | (if val | |
| 116 | (funcall ,error-proc val) | |
| 117 | ret-val))) | |
| 118 | ` (let ((ret-val nil)) | |
| 119 | (let ((val (catch 'chaos-top-level-error | |
| 120 | (setq ret-val | |
| 121 | (progn ,@body)) | |
| 122 | nil))) | |
| 123 | (if val | |
| 124 | (let ((std-proc (get-chaos-error-proc val))) | |
| 125 | (if std-proc | |
| 126 | (funcall std-proc val) | |
| 127 | ;; we assume no more error handlers. | |
| 128 | nil)) | |
| 129 | ret-val))))) | |
| 111 | (let ((val (catch 'chaos-top-level-error | |
| 112 | (setq ret-val | |
| 113 | (progn ,@body)) | |
| 114 | nil))) | |
| 115 | (if val | |
| 116 | (funcall ,error-proc val) | |
| 117 | ret-val))) | |
| 118 | ` (let ((ret-val nil)) | |
| 119 | (let ((val (catch 'chaos-top-level-error | |
| 120 | (setq ret-val | |
| 121 | (progn ,@body)) | |
| 122 | nil))) | |
| 123 | (if val | |
| 124 | (let ((std-proc (get-chaos-error-proc val))) | |
| 125 | (if std-proc | |
| 126 | (funcall std-proc val) | |
| 127 | ;; we assume no more error handlers. | |
| 128 | nil)) | |
| 129 | ret-val))))) | |
| 130 | 130 | |
| 131 | 131 | (defmacro ignoring-chaos-error (&body body) |
| 132 | 132 | ` (catch 'chaos-top-level-error |
| 133 | 133 | (catch 'chaos-main-error |
| 134 | ,@body))) | |
| 134 | ,@body))) | |
| 135 | 135 | ;;; EOF |
| 0 | 0 | ;;;-*- Mode:Lisp; Syntax:Common-Lisp; Package:CHAOS -*- |
| 1 | 1 | ;;; |
| 2 | ;;; Copyright (c) 2000-2014, Toshimi Sawada. All rights reserved. | |
| 2 | ;;; Copyright (c) 2000-2015, Toshimi Sawada. All rights reserved. | |
| 3 | 3 | ;;; |
| 4 | 4 | ;;; Redistribution and use in source and binary forms, with or without |
| 5 | 5 | ;;; modification, are permitted provided that the following conditions |
| 51 | 51 | (values t)) |
| 52 | 52 | (when (and (eql #\~ (char fname 0)) (eql #\/ (char fname 1))) |
| 53 | 53 | (setq fname |
| 54 | (concatenate 'string | |
| 55 | (namestring (user-homedir-pathname)) | |
| 54 | (concatenate 'string | |
| 55 | (namestring (user-homedir-pathname)) | |
| 56 | 56 | (subseq fname 2)))) |
| 57 | 57 | (load fname)) |
| 58 | 58 | |
| 101 | 101 | (probe-file (concatenate 'string dpath "/")) |
| 102 | 102 | #+:SBCL |
| 103 | 103 | (let ((directory-delimiter "/") ; sbcl uses / on all platforms! |
| 104 | (p (probe-file dpath))) | |
| 105 | ; (format t "DEBUG is-directory? dpath ~s path ~s p ~s~%" dpath path p) | |
| 104 | (p (probe-file dpath))) | |
| 106 | 105 | (if p |
| 107 | (and (string-equal (subseq (namestring p) | |
| 108 | (1- (length (namestring p)))) | |
| 109 | directory-delimiter) | |
| 110 | p) | |
| 111 | nil)) | |
| 106 | (and (string-equal (subseq (namestring p) | |
| 107 | (1- (length (namestring p)))) | |
| 108 | directory-delimiter) | |
| 109 | p) | |
| 110 | nil)) | |
| 112 | 111 | #+:Allegro |
| 113 | 112 | (if (excl:file-directory-p dpath) |
| 114 | ;; (concatenate 'string dpath "/") | |
| 115 | (pathname dpath) | |
| 113 | (pathname (concatenate 'string dpath "/")) | |
| 116 | 114 | nil) |
| 117 | 115 | #+(and :CCL (not :openmcl)) (if (directoryp dpath) dpath nil) |
| 118 | 116 | #+:CLISP |
| 134 | 132 | nil)) |
| 135 | 133 | (error "is-simple-file-name? : given non string arg ~a" path)))) |
| 136 | 134 | |
| 135 | (defun is-relative-file-name? (path) | |
| 136 | (declare (type (or simple-string pathname) path) | |
| 137 | (values (or null t))) | |
| 138 | (let ((pn (if (pathnamep path) | |
| 139 | path | |
| 140 | (if (stringp path) | |
| 141 | (pathname path) | |
| 142 | (error "is-relative-file-name? : given non string arg ~a" path))))) | |
| 143 | (if (or (null (pathname-directory pn)) | |
| 144 | (member ':relative (pathname-directory pn) :test #'equal)) | |
| 145 | t | |
| 146 | nil))) | |
| 147 | ||
| 137 | 148 | (defun supply-suffixes (path suffixes) |
| 138 | 149 | (declare (type (or simple-string pathname) path) |
| 139 | 150 | (type list suffixes) |
| 140 | 151 | (values list)) |
| 152 | #+:SBCL | |
| 153 | (when (position #\. (if (pathnamep path) | |
| 154 | (pathname-name path) | |
| 155 | path) | |
| 156 | :from-end t) | |
| 157 | (return-from supply-suffixes (list path))) | |
| 141 | 158 | (mapcar #'pathname |
| 142 | 159 | (mapcar #'(lambda (x) (concatenate 'string |
| 143 | 160 | (namestring path) |
| 148 | 165 | (declare (type (or simple-string pathname) file) |
| 149 | 166 | (type (or simple-string list) load-path) |
| 150 | 167 | (type list suffixes)) |
| 151 | (when (pathnamep file) | |
| 168 | (when (and (pathnamep file) (not (is-directory? file))) | |
| 152 | 169 | (return-from chaos-probe-file (probe-file file))) |
| 153 | 170 | ;; |
| 154 | 171 | (setq file (expand-file-name file)) |
| 155 | 172 | (when (atom suffixes) |
| 156 | 173 | (setq suffixes (list suffixes))) |
| 157 | (if load-path | |
| 158 | (when (atom load-path) | |
| 159 | (setq load-path (list load-path)))) | |
| 174 | (when (and load-path (atom load-path)) | |
| 175 | (setq load-path (list load-path))) | |
| 160 | 176 | ;; |
| 161 | (cond ((is-simple-file-name? file) | |
| 177 | (cond ((is-relative-file-name? file) | |
| 162 | 178 | (let ((file-path (chaos-get-relative-path* |
| 163 | 179 | (concatenate 'string "./" file))) |
| 164 | 180 | (res nil)) |
| 165 | 181 | ;; |
| 166 | 182 | (setq res (probe-file file-path)) |
| 183 | (when (and res (is-directory? res)) | |
| 184 | (setq res nil)) | |
| 167 | 185 | (unless res |
| 168 | 186 | (dolist (fx (supply-suffixes file-path suffixes)) |
| 169 | (when (probe-file fx) | |
| 187 | (when (and (probe-file fx) (not (is-directory? fx))) | |
| 170 | 188 | (setq res fx) |
| 171 | 189 | (return))) |
| 172 | 190 | ;; search through load paths |
| 173 | 191 | (unless res |
| 174 | 192 | (dolist (lpath load-path) |
| 175 | 193 | (let ((libdir (is-directory? lpath))) |
| 176 | (declare (type (or null string pathname) libdir)) | |
| 194 | (declare (type (or null string pathname) libdir)) | |
| 177 | 195 | (when libdir |
| 178 | (unless (pathnamep libdir) (setq libdir (pathname libdir))) | |
| 196 | (unless (pathnamep libdir) (setq libdir (pathname libdir))) | |
| 179 | 197 | (let ((f (make-pathname |
| 180 | :host (pathname-host libdir) | |
| 181 | :device (pathname-device libdir) | |
| 198 | :host (pathname-host libdir) | |
| 199 | :device (pathname-device libdir) | |
| 182 | 200 | :directory |
| 183 | #+:CLISP libdir | |
| 184 | ;; #+:Allegro (namestring libdir) | |
| 185 | #-:CLISP (pathname-directory libdir) | |
| 201 | #+:CLISP libdir | |
| 202 | ;; #+:Allegro (namestring libdir) | |
| 203 | #-:CLISP (pathname-directory libdir) | |
| 186 | 204 | :name (namestring file)))) |
| 187 | (if (probe-file f) | |
| 205 | (if (and (probe-file f) (not (is-directory? f))) | |
| 188 | 206 | (progn (setq res f) (return)) |
| 189 | 207 | (let ((x (supply-suffixes f suffixes))) |
| 190 | 208 | (dolist (fx x) |
| 191 | (when (probe-file fx) | |
| 209 | (when (and (probe-file fx) (not (is-directory? fx))) | |
| 192 | 210 | (setq res fx) |
| 193 | 211 | (return))))))))))) |
| 194 | 212 | res)) |
| 195 | 213 | (t (let ((file-path (chaos-get-relative-path* file))) |
| 196 | (if (probe-file file-path) | |
| 214 | (if (and (probe-file file-path) (not (is-directory? file-path))) | |
| 197 | 215 | file-path |
| 198 | 216 | (dolist (fx (supply-suffixes file-path suffixes)) |
| 199 | (when (probe-file fx) | |
| 217 | (when (and (probe-file fx) (not (is-directory? fx))) | |
| 200 | 218 | (return-from chaos-probe-file fx)))))))) |
| 201 | 219 | |
| 202 | 220 | (defun bare-chaos-pwd () |
| 214 | 232 | (defun chaos-relative-pathname? (f-name) |
| 215 | 233 | (let ((fdp (pathname-directory (pathname f-name)))) |
| 216 | 234 | (or (null fdp) |
| 217 | (and fdp ; not simple file name. | |
| 218 | (not (eq (car (pathname-directory (pathname f-name))) | |
| 219 | :root)))))) | |
| 235 | (and fdp ; not simple file name. | |
| 236 | (not (eq (car (pathname-directory (pathname f-name))) | |
| 237 | :root)))))) | |
| 220 | 238 | |
| 221 | 239 | (defun chaos-get-relative-path (f-name) |
| 222 | 240 | (setq f-name (expand-file-name f-name)) |
| 225 | 243 | ; #+:SBCL |
| 226 | 244 | ; (defun chaos-get-directory (file-path) |
| 227 | 245 | ; (let* ((ns (namestring file-path)) |
| 228 | ; (dpos (position #\/ ns :from-end t)) | |
| 229 | ; (dir nil)) | |
| 246 | ; (dpos (position #\/ ns :from-end t)) | |
| 247 | ; (dir nil)) | |
| 230 | 248 | ; (unless dpos |
| 231 | 249 | ; (with-output-chaos-error ('internal-error) |
| 232 | ; (format t ":get-relative-path: could not find proper directory path, ~a" file-path))) | |
| 250 | ; (format t ":get-relative-path: could not find proper directory path, ~a" file-path))) | |
| 233 | 251 | ; (subseq ns 0 (1+ dpos)))) |
| 234 | 252 | |
| 235 | 253 | #+(or :Allegro :SBCL) |
| 237 | 255 | (unless (pathnamep file-path) |
| 238 | 256 | (setq file-path (pathname file-path))) |
| 239 | 257 | (let ((dir-path (make-pathname :host (pathname-host file-path) |
| 240 | :device (pathname-device file-path) | |
| 241 | :directory (pathname-directory file-path)))) | |
| 258 | :device (pathname-device file-path) | |
| 259 | :directory (pathname-directory file-path)))) | |
| 242 | 260 | ;;(namestring dir-path) |
| 243 | 261 | dir-path)) |
| 244 | 262 | |
| 249 | 267 | (let ((f-path nil)) |
| 250 | 268 | (unwind-protect |
| 251 | 269 | (let ((host (pathname-host (pathname f-name))) |
| 252 | (device (pathname-device (pathname f-name))) | |
| 253 | (fd (pathname-directory (pathname f-name))) | |
| 270 | (device (pathname-device (pathname f-name))) | |
| 271 | (fd (pathname-directory (pathname f-name))) | |
| 254 | 272 | (f (file-namestring (pathname f-name)))) |
| 255 | 273 | ;; #-GCL (declare (ignore fd)) |
| 256 | ;; (chaos-pushd (directory-namestring *chaos-input-source*)) | |
| 257 | (chaos-pushd (chaos-get-directory *chaos-input-source*)) | |
| 274 | ;; (chaos-pushd (directory-namestring *chaos-input-source*)) | |
| 275 | (chaos-pushd (chaos-get-directory *chaos-input-source*)) | |
| 258 | 276 | #+GCL |
| 259 | 277 | (setq f-path (truename (make-pathname :directory fd :name f))) |
| 260 | 278 | #+:CLISP |
| 261 | 279 | (setq f-path (make-pathname |
| 262 | :host host | |
| 263 | :device device | |
| 280 | :host host | |
| 281 | :device device | |
| 264 | 282 | :directory fd ;; (pathname fd) |
| 265 | 283 | :name f)) |
| 266 | 284 | #-(or GCL :CLISP) |
| 267 | 285 | (progn |
| 268 | 286 | (setq f-path (make-pathname |
| 269 | :host host | |
| 270 | :device device | |
| 287 | :host host | |
| 288 | :device device | |
| 271 | 289 | :directory fd |
| 272 | 290 | :name f)))) |
| 273 | 291 | (chaos-popd)) |
| 292 | 310 | #+GCL (system comm) |
| 293 | 311 | #+EXCL (excl:shell comm) |
| 294 | 312 | #+SBCL (apply #'sb-ext:run-program |
| 295 | #+win32 "CMD" #-win32 "/bin/sh" | |
| 296 | #+win32 (list "/c" "dir") #-win32 (list "-c" comm) | |
| 297 | :input nil :output *terminal-io* | |
| 298 | #+win32 '(:search t) #-win32 nil) | |
| 313 | #+win32 "CMD" #-win32 "/bin/sh" | |
| 314 | #+win32 (list "/c" "dir") #-win32 (list "-c" comm) | |
| 315 | :input nil :output *terminal-io* | |
| 316 | #+win32 '(:search t) #-win32 nil) | |
| 299 | 317 | #+LUCID (lucid::%execute-system-command comm) |
| 300 | 318 | #+CLISP (ext::shell comm))) |
| 301 | 319 | |
| 317 | 335 | (defvar *chaos-directory-stack* nil) |
| 318 | 336 | |
| 319 | 337 | (defun chaos-print-directory-stack (&optional (stream *standard-output*)) |
| 320 | (format stream "~&~a" *chaos-directory-stack*)) | |
| 338 | (format stream "~%~a" *chaos-directory-stack*)) | |
| 321 | 339 | |
| 322 | 340 | (defun fsys-parse-number (tok) |
| 323 | 341 | (declare (type (or simple-string pathname) tok)) |
| 324 | 342 | (if (stringp tok) |
| 325 | 343 | (let ((minusp nil)) |
| 326 | (if (char= (char tok 0) #\-) | |
| 327 | (setq minusp t) | |
| 328 | (unless (char= (char tok 0) #\+) | |
| 329 | (return-from fsys-parse-number | |
| 330 | (values tok nil)))) | |
| 331 | (let ((num (read-from-string tok))) | |
| 332 | (if (numberp num) | |
| 333 | (values num minusp) | |
| 334 | (values tok nil)))) | |
| 344 | (if (char= (char tok 0) #\-) | |
| 345 | (setq minusp t) | |
| 346 | (unless (char= (char tok 0) #\+) | |
| 347 | (return-from fsys-parse-number | |
| 348 | (values tok nil)))) | |
| 349 | (let ((num (read-from-string tok))) | |
| 350 | (if (numberp num) | |
| 351 | (values num minusp) | |
| 352 | (values tok nil)))) | |
| 335 | 353 | (values tok nil))) |
| 336 | 354 | |
| 337 | 355 | (defun chaos-pushd (arg &optional (always-return nil)) |
| 354 | 372 | (progn |
| 355 | 373 | (pop *chaos-directory-stack*) |
| 356 | 374 | nil)))) |
| 357 | (t (chaos-pushd "+1"))))) | |
| 375 | (t (if (<= (length *chaos-directory-stack*) 1) | |
| 376 | (with-output-chaos-warning () | |
| 377 | (format t "No other directory.") | |
| 378 | (return-from chaos-pushd nil)) | |
| 379 | (chaos-pushd "+1")))))) | |
| 358 | 380 | |
| 359 | 381 | (defun chaos-popd (&optional num) |
| 360 | 382 | (declare (ignore num)) |
| 390 | 412 | (setq ng t)) |
| 391 | 413 | #+SBCL |
| 392 | 414 | (if (setq directory-path (is-directory? path)) |
| 393 | (progn | |
| 394 | (setq *default-pathname-defaults* directory-path) | |
| 395 | (sb-posix:chdir directory-path)) | |
| 415 | (progn | |
| 416 | (setq *default-pathname-defaults* directory-path) | |
| 417 | (sb-posix:chdir directory-path)) | |
| 396 | 418 | (setq ng t)) |
| 397 | 419 | #+(and :CCL (not :openmcl)) |
| 398 | 420 | (if (setq directory-path (is-directory? path)) |
| 488 | 510 | (dolist (p (parse-with-delimiter paths #\:)) |
| 489 | 511 | (push p path)) |
| 490 | 512 | (setq *chaos-libpath* |
| 491 | (append (nreverse path) *chaos-libpath*)))) | |
| 513 | (append (nreverse path) *chaos-libpath*)))) | |
| 514 | ||
| 515 | (defun set-search-path-minus (paths) | |
| 516 | (when (consp paths) (setq paths (car paths))) | |
| 517 | (let ((path nil)) | |
| 518 | (dolist (p (parse-with-delimiter paths #\:)) | |
| 519 | (push p path)) | |
| 520 | (dolist (p path) | |
| 521 | (if (not (member p *chaos-libpath* :test #'equal)) | |
| 522 | (with-output-chaos-warning () | |
| 523 | (format t "The path ~s does not in 'libpath'." p)) | |
| 524 | (setq *chaos-libpath* (remove p *chaos-libpath* :test #'equal)))) | |
| 525 | *chaos-libpath*)) | |
| 526 | ||
| 527 | (defun pr-search-path (&optional (stream *standard-output*)) | |
| 528 | (format stream "libpath = ~{~a~^:~}" *chaos-libpath*)) | |
| 492 | 529 | |
| 493 | 530 | ;;; |
| 494 | 531 | ;;; INITIALIZATION |
| 0 | 0 | ;;;-*- Mode:LISP; Package:CHAOS; Base:10; Syntax:Common-lisp -*- |
| 1 | 1 | ;;; |
| 2 | ;;; Copyright (c) 2000-2014, Toshimi Sawada. All rights reserved. | |
| 2 | ;;; Copyright (c) 2000-2015, Toshimi Sawada. All rights reserved. | |
| 3 | 3 | ;;; |
| 4 | 4 | ;;; Redistribution and use in source and binary forms, with or without |
| 5 | 5 | ;;; modification, are permitted provided that the following conditions |
| 27 | 27 | ;;; |
| 28 | 28 | (in-package :chaos) |
| 29 | 29 | #|============================================================================== |
| 30 | System: CHAOS | |
| 31 | Module: comlib | |
| 32 | File: globals.lisp | |
| 30 | System: CHAOS | |
| 31 | Module: comlib | |
| 32 | File: globals.lisp | |
| 33 | 33 | ==============================================================================|# |
| 34 | 34 | #-:chaos-debug |
| 35 | 35 | (declaim (optimize (speed 3) (safety 0) #-GCL (debug 0))) |
| 59 | 59 | ;;; *current-ext-rule-table* : extented rules for A, and AC |
| 60 | 60 | ;;; |
| 61 | 61 | |
| 62 | (declaim (special *current-module* ; the module currently the target of | |
| 63 | ; operations. | |
| 64 | *current-sort-order* ; closure of sort relations of current | |
| 65 | ; module. | |
| 66 | *current-opinfo-table* ; operator information table of the | |
| 67 | ; current module. | |
| 68 | *current-ext-rule-table* | |
| 69 | *top-level-definition-in-progress* | |
| 70 | *on-preparing-for-parsing* ; parsing preparation in progress | |
| 71 | )) | |
| 62 | (declaim (special *current-module* ; the module currently the target of | |
| 63 | ; operations. | |
| 64 | *current-sort-order* ; closure of sort relations of current | |
| 65 | ; module. | |
| 66 | *current-opinfo-table* ; operator information table of the | |
| 67 | ; current module. | |
| 68 | *current-ext-rule-table* | |
| 69 | *top-level-definition-in-progress* | |
| 70 | *on-preparing-for-parsing* ; parsing preparation in progress | |
| 71 | )) | |
| 72 | 72 | |
| 73 | 73 | (defvar *top-level-definition-in-progress* nil) |
| 74 | 74 | |
| 75 | ;;; *last-module* bounds the module object which was the target of the operation | |
| 76 | ;;; in the last time, i.e., whenever the context is swithced, *last-module* | |
| 77 | ;;; bounds the last `current module'. | |
| 78 | 75 | ;;; *open-module* bounds the 'opening' module. |
| 79 | 76 | ;;; |
| 80 | (declaim (special *open-module* ; the module crrently opened. | |
| 81 | *last-module* ; the module which was the current last | |
| 82 | ; time. | |
| 83 | *last-before-open* ; the module which was *last* before the | |
| 84 | ; currently opened module. | |
| 85 | )) | |
| 77 | (declaim (special *open-module* ; the module crrently opened. | |
| 78 | *last-before-open* ; the module which was *last* before the | |
| 79 | ; currently opened module. | |
| 80 | )) | |
| 86 | 81 | |
| 87 | 82 | (defvar *current-module* nil) |
| 88 | 83 | (defvar *current-sort-order* nil) |
| 89 | 84 | (defvar *current-opinfo-table* nil) |
| 90 | 85 | (defvar *current-ext-rule-table* nil) |
| 91 | 86 | (defvar *open-module* nil) |
| 92 | (defvar *last-module* nil) | |
| 93 | 87 | (defvar *last-before-open* nil) |
| 94 | 88 | |
| 95 | 89 | ;;; Feature for require & provide |
| 101 | 95 | (declaim (special *chaos-verbose* *chaos-quiet* *chaos-input-source*)) |
| 102 | 96 | (defvar *chaos-verbose* nil) |
| 103 | 97 | (defvar *chaos-quiet* nil) |
| 104 | (defvar *chaos-input-source* nil) ; binds a file name when processing | |
| 105 | ; input from the file. | |
| 98 | (defvar *chaos-input-source* nil) ; binds a file name when processing | |
| 99 | ; input from the file. | |
| 106 | 100 | (declaim (special *chaos-input-level*) |
| 107 | (type (integer 0 11) | |
| 108 | *chaos-input-level* | |
| 109 | *chaos-input-nesting-limit*)) | |
| 101 | (type (integer 0 11) | |
| 102 | *chaos-input-level* | |
| 103 | *chaos-input-nesting-limit*)) | |
| 110 | 104 | |
| 111 | 105 | (defvar *chaos-input-level* 0) |
| 112 | 106 | (defvar *chaos-input-nesting-limit* 10) |
| 128 | 122 | (declaim (special *self*)) |
| 129 | 123 | (defvar *self* nil) |
| 130 | 124 | (defvar $$cond nil) |
| 131 | (defvar $$trace-rewrite nil) ; flag, non-nil -> trace. | |
| 132 | (defvar $$trace-rewrite-whole nil) ; flag, non-nil -> trace whole. | |
| 133 | (defvar $$trace-proof nil) ; flag, non-nil -> trace CITP proof. | |
| 125 | (defvar $$trace-rewrite nil) ; flag, non-nil -> trace. | |
| 126 | (defvar $$trace-rewrite-whole nil) ; flag, non-nil -> trace whole. | |
| 127 | (defvar $$trace-proof nil) ; flag, non-nil -> trace CITP proof. | |
| 134 | 128 | ;;; *proof-tree* binds current proof tree structure |
| 135 | 129 | (defvar *proof-tree* nil) |
| 136 | 130 | (defvar *next-default-proof-node* nil) |
| 137 | 131 | (defvar *citp-verbose* nil) |
| 138 | ||
| 139 | (defvar *rewrite-stepping* nil) ; flag, non-nil -> under stepping. | |
| 132 | (defvar *citp-normalize-instance* t) | |
| 133 | ||
| 134 | (defvar *rewrite-stepping* nil) ; flag, non-nil -> under stepping. | |
| 140 | 135 | (declaim (type (or null fixnum) *rewrite-count-limit*)) |
| 141 | 136 | (defvar *rewrite-count-limit* nil) |
| 142 | ; flag, non-nil(integer) -> limitation | |
| 143 | ; for rewriting steps. | |
| 144 | (defvar *rewrite-stop-pattern* nil) ; flag, non-nil(term) -> stop rewriting | |
| 145 | ; iff matches to the pattern. | |
| 146 | (defvar *steps-to-be-done* nil) ; remaining steps before stop | |
| 137 | ; flag, non-nil(integer) -> limitation | |
| 138 | ; for rewriting steps. | |
| 139 | (defvar *rewrite-stop-pattern* nil) ; flag, non-nil(term) -> stop rewriting | |
| 140 | ; iff matches to the pattern. | |
| 141 | (defvar *steps-to-be-done* nil) ; remaining steps before stop | |
| 147 | 142 | (defvar $$mod 'void) |
| 148 | 143 | ;;; |
| 149 | 144 | (defvar *old-context* nil) |
| 150 | 145 | (declaim (special *old-context*)) |
| 151 | 146 | (declaim (special *allow-$$term*)) |
| 152 | 147 | (defvar *allow-$$term* t) |
| 153 | (defvar $$term 'void) ; current target term, destructively | |
| 154 | ; modified | |
| 155 | (defvar $$subterm nil) ; subterm of $$term selected | |
| 156 | (defvar $$term-context nil) ; context module of $$term | |
| 148 | (defvar $$term 'void) ; current target term, destructively | |
| 149 | ; modified | |
| 150 | (defvar $$subterm nil) ; subterm of $$term selected | |
| 151 | (defvar $$term-context nil) ; context module of $$term | |
| 157 | 152 | (defvar $$selection-stack nil) |
| 158 | 153 | (defvar $$action-stack nil) |
| 159 | 154 | ;;; |
| 167 | 162 | (declaim (special *rewrite-exec-condition*)) |
| 168 | 163 | (defvar *rewrite-exec-condition* nil) |
| 169 | 164 | (declaim (special *rewrite-semantic-reduce*) |
| 170 | (type (or null (not null)) *rewrite-semantic-reduce)) | |
| 165 | (type (or null (not null)) *rewrite-semantic-reduce)) | |
| 171 | 166 | (defvar *rewrite-semantic-reduce* nil) |
| 172 | 167 | (declaim (special *beh-rewrite*) |
| 173 | (type (or null (not null)) *beh-rewrite*)) | |
| 168 | (type (or null (not null)) *beh-rewrite*)) | |
| 174 | 169 | (defvar *beh-rewrite* nil) |
| 175 | (declaim (type fixnum *rule-count*)) | |
| 170 | (declaim (type fixnum *rule-count*) | |
| 171 | (special *rule-count*)) | |
| 176 | 172 | (defvar *rule-count* 0) |
| 177 | 173 | (defvar *show-stats* t) |
| 178 | 174 | (defvar *try-try* nil) |
| 179 | 175 | (defvar *reduce-conditions* nil) |
| 180 | 176 | (declaim (type fixnum $$trials)) |
| 181 | 177 | (defvar $$trials 1) |
| 182 | (declaim (type fixnum $$matches)) | |
| 178 | (declaim (type fixnum $$matches) | |
| 179 | (special $$matches)) | |
| 183 | 180 | (defvar $$matches 0) |
| 184 | 181 | (defvar *on-reduction* t) |
| 185 | 182 | (defvar *reduce-builtin-eager* nil) |
| 198 | 195 | (defvar *m-pattern-subst* nil) |
| 199 | 196 | |
| 200 | 197 | ;; memoization |
| 201 | (defvar *memo-rewrite* t) ; use memo mechanism | |
| 198 | (defvar *memo-rewrite* t) ; use memo mechanism | |
| 202 | 199 | (defvar *clean-memo-in-normalize* nil) |
| 203 | 200 | (defvar *always-memo* nil) |
| 204 | 201 | (declaim (special *hash-hit*) |
| 205 | (type (unsigned-byte 29) *hash-hit*)) | |
| 202 | (type (unsigned-byte 29) *hash-hit*)) | |
| 206 | 203 | (defvar *term-memo-hash-hit* 0) |
| 207 | 204 | |
| 208 | 205 | (defvar *allow-illegal-beh-axiom* t) |
| 243 | 240 | |
| 244 | 241 | (declaim (special *print-indent*)) |
| 245 | 242 | (declaim (type (integer 0 128) |
| 246 | *chaos-print-level* | |
| 247 | *print-indent* *print-indent-increment*)) | |
| 243 | *chaos-print-level* | |
| 244 | *print-indent* *print-indent-increment*)) | |
| 248 | 245 | ;; (defvar *chaos-verbose* nil) |
| 249 | 246 | (defvar *module-all-rules-every* nil) |
| 250 | 247 | (defvar *fancy-print* t) |
| 251 | 248 | (defvar *print-term-struct* nil) |
| 252 | 249 | (defvar *print-xmode* :normal) |
| 253 | (defvar *show-mode* :cafeobj) ; one of :chaos or :cafeobj | |
| 250 | (defvar *show-mode* :cafeobj) ; one of :chaos or :cafeobj | |
| 254 | 251 | (defvar *print-indent* 0) |
| 255 | 252 | (defparameter *print-indent-increment* 1) |
| 256 | (defvar *print-explicit* nil) ;if t then give more detail on sorts, etc. | |
| 257 | (defvar *print-abbrev-mod* nil) ; abbreviate module names | |
| 253 | (defvar *print-explicit* nil) ;if t then give more detail on sorts, etc. | |
| 254 | (defvar *print-abbrev-mod* nil) ; abbreviate module names | |
| 258 | 255 | (defvar *print-abbrev-num* 0) |
| 259 | 256 | (defvar *print-abbrev-table* nil) |
| 260 | 257 | (defvar *print-abbrev-quals* nil) |
| 273 | 270 | (defvar *chaos-input-quiet* nil) |
| 274 | 271 | (defvar *print-variables* nil) |
| 275 | 272 | (declaim (special .file-col.) |
| 276 | (type fixnum .file-col.)) | |
| 273 | (type fixnum .file-col.)) | |
| 277 | 274 | (defvar .file-col. 0) |
| 278 | 275 | ;;; |
| 279 | 276 | (declaim (type (or null fixnum) *term-print-depth*)) |
| 342 | 339 | (defconstant $name-parameter '|*Parameter*|) |
| 343 | 340 | |
| 344 | 341 | ;;; builtin sorts |
| 345 | (defvar *cosmos* 'void) ; the whole | |
| 342 | (defvar *cosmos* 'void) ; the whole | |
| 346 | 343 | (defvar *chaos-object* 'void) |
| 347 | 344 | (defvar *chaos-expr-sort* 'void) |
| 348 | 345 | (defvar *term-sort* 'void) |
| 349 | (defvar *universal-sort* 'void) ; visible universe | |
| 350 | (defvar *huniversal-sort* 'void) ; hidden universe | |
| 351 | (defvar *bottom-sort* 'void) ; visible bottom sort | |
| 352 | (defvar *hbottom-sort* 'void) ; hidden bottom sort | |
| 346 | (defvar *universal-sort* 'void) ; visible universe | |
| 347 | (defvar *huniversal-sort* 'void) ; hidden universe | |
| 348 | (defvar *bottom-sort* 'void) ; visible bottom sort | |
| 349 | (defvar *hbottom-sort* 'void) ; hidden bottom sort | |
| 353 | 350 | (defvar *sort-sort* 'void) |
| 354 | 351 | (defvar *general-sort* 'void) |
| 355 | 352 | (defvar *builtin-sort* 'void) |
| 532 | 529 | ;;; *************** |
| 533 | 530 | |
| 534 | 531 | (declaim (special *parse-variables* |
| 535 | *fill-rc-attribute* | |
| 536 | *lhs-attrid-vars* | |
| 537 | *parsing-axiom-lhs* | |
| 538 | *parse-lhs-attr-vars*)) ; binds variables during a parsing | |
| 539 | ; process. | |
| 540 | (declaim (special *reader-schema-env* ; current schema. | |
| 541 | *reader-input* ; current token sequence. | |
| 542 | )) | |
| 543 | ||
| 544 | (declaim (special *macroexpand*)) ; expand macro if t | |
| 545 | ||
| 546 | (defvar *fill-rc-attribute* nil) ; a flag, t if requires generalizing the | |
| 547 | ; pattern of record/object terms. | |
| 532 | *fill-rc-attribute* | |
| 533 | *lhs-attrid-vars* | |
| 534 | *parsing-axiom-lhs* | |
| 535 | *parse-lhs-attr-vars*)) ; binds variables during a parsing | |
| 536 | ; process. | |
| 537 | (declaim (special *reader-schema-env* ; current schema. | |
| 538 | *reader-input* ; current token sequence. | |
| 539 | )) | |
| 540 | ||
| 541 | (declaim (special *macroexpand*)) ; expand macro if t | |
| 542 | ||
| 543 | (defvar *fill-rc-attribute* nil) ; a flag, t if requires generalizing the | |
| 544 | ; pattern of record/object terms. | |
| 548 | 545 | |
| 549 | 546 | (defvar *parsing-axiom-lhs* nil) |
| 550 | 547 | (defvar *parse-lhs-attr-vars* nil) |
| 653 | 650 | |
| 654 | 651 | ;;; find command control |
| 655 | 652 | (defvar *find-all-rules* nil) |
| 653 | ||
| 654 | ;;; NO ID COMPLETION | |
| 655 | (defvar *no-id-completion* nil) | |
| 656 | 656 | |
| 657 | 657 | ;;; DEBUG FLAGS |
| 658 | 658 | (defvar *rewrite-debug* nil) |
| 678 | 678 | (defvar *cexec-debug* nil) |
| 679 | 679 | (defvar *debug-meta* nil) |
| 680 | 680 | (defvar *debug-citp* nil) |
| 681 | (defvar *debug-print* nil) | |
| 681 | 682 | ;;; |
| 682 | 683 | ;;; ** TO DO for other platforms |
| 683 | 684 | #+SBCL |
| 0 | 0 | ;;;-*- Mode:LISP; Package:CHAOS; Base:10; Syntax:Common-lisp -*- |
| 1 | 1 | ;;; |
| 2 | ;;; Copyright (c) 2000-2014, Toshimi Sawada. All rights reserved. | |
| 2 | ;;; Copyright (c) 2000-2015, Toshimi Sawada. All rights reserved. | |
| 3 | 3 | ;;; |
| 4 | 4 | ;;; Redistribution and use in source and binary forms, with or without |
| 5 | 5 | ;;; modification, are permitted provided that the following conditions |
| 27 | 27 | ;;; |
| 28 | 28 | (in-package :chaos) |
| 29 | 29 | #|============================================================================== |
| 30 | System:Chaos | |
| 31 | Module:comlib | |
| 32 | File: lex.lisp | |
| 30 | System:Chaos | |
| 31 | Module:comlib | |
| 32 | File: lex.lisp | |
| 33 | 33 | ==============================================================================|# |
| 34 | 34 | #-:chaos-debug |
| 35 | 35 | (declaim (optimize (speed 3) (safety 0) #-GCL (debug 0))) |
| 45 | 45 | ;;; |
| 46 | 46 | |
| 47 | 47 | ;;;============================================================================= |
| 48 | ;;; *** CHAOS BUILTIN LEXICAL CATEGORIES *** | |
| 48 | ;;; *** CHAOS BUILTIN LEXICAL CATEGORIES *** | |
| 49 | 49 | ;;;============================================================================= |
| 50 | 50 | |
| 51 | 51 | (eval-when (:execute :compile-toplevel :load-toplevel) |
| 111 | 111 | (defvar *reader-read-table*) |
| 112 | 112 | (eval-when (:execute :load-toplevel) |
| 113 | 113 | (setf *reader-read-table* (make-array (list .reader-char-code-limit.) |
| 114 | :initial-element nil))) | |
| 114 | :initial-element nil))) | |
| 115 | 115 | |
| 116 | 116 | (defmacro !set-syntax (ch val) |
| 117 | 117 | `(setf (aref *reader-read-table* (the fixnum (char-code ,ch))) ,val)) |
| 120 | 120 | (dotimes (x .reader-char-code-limit.) |
| 121 | 121 | (let ((syntax (aref *reader-read-table* x))) |
| 122 | 122 | (when syntax |
| 123 | (format stream "~&~S : ~S" (code-char x) syntax))))) | |
| 123 | (format stream "~%~S : ~S" (code-char x) syntax))))) | |
| 124 | 124 | |
| 125 | 125 | ;;; !INIT-READ-TABLE : List[Char] List[Char] List[Char] -> Void |
| 126 | 126 | ;;; initialize Chaos read table. |
| 130 | 130 | ;;; |
| 131 | 131 | (defun !init-read-table (space return single) |
| 132 | 132 | (declare (type list space return single) |
| 133 | (values t)) | |
| 133 | (values t)) | |
| 134 | 134 | #|| |
| 135 | 135 | (do ((i 0 (1+ i))) |
| 136 | 136 | ((= i .reader-char-code-limit.)) |
| 161 | 161 | ;;; |
| 162 | 162 | (defun !set-single-reader (l) |
| 163 | 163 | (declare (type list l) |
| 164 | (values t)) | |
| 164 | (values t)) | |
| 165 | 165 | (mapcar #'(lambda (x) |
| 166 | (declare (type (or simple-string character) x)) | |
| 167 | (let ((chr (if (and (stringp x) | |
| 168 | (= (length x) 1)) | |
| 169 | (char (the string x) 0) | |
| 170 | (if (characterp x) | |
| 171 | x | |
| 172 | (with-output-chaos-error ('invalid-str) | |
| 173 | (format t "delimiter must be a single character, but ~a is given" x)))))) | |
| 174 | (prog1 | |
| 175 | (cons chr (reader-get-syntax chr)) | |
| 176 | ;; (print chr) | |
| 177 | (!set-syntax chr (intern (string x)))))) | |
| 178 | l)) | |
| 166 | (declare (type (or simple-string character) x)) | |
| 167 | (let ((chr (if (and (stringp x) | |
| 168 | (= (length x) 1)) | |
| 169 | (char (the string x) 0) | |
| 170 | (if (characterp x) | |
| 171 | x | |
| 172 | (with-output-chaos-error ('invalid-str) | |
| 173 | (format t "delimiter must be a single character, but ~a is given" x)))))) | |
| 174 | (prog1 | |
| 175 | (cons chr (reader-get-syntax chr)) | |
| 176 | ;; (print chr) | |
| 177 | (!set-syntax chr (intern (string x)))))) | |
| 178 | l)) | |
| 179 | 179 | |
| 180 | 180 | ;;; !SET-READER list-of-chars |
| 181 | 181 | ;;; modify a sequence of characters for syntax as given by associated values. |
| 183 | 183 | ;;; |
| 184 | 184 | (defun !set-reader (l) |
| 185 | 185 | (declare (type list l) |
| 186 | (values t)) | |
| 186 | (values t)) | |
| 187 | 187 | (mapc #'(lambda (x) |
| 188 | (declare (type list x)) | |
| 188 | (declare (type list x)) | |
| 189 | 189 | (let ((s (car x))) |
| 190 | (declare (type (or simple-string character) s)) | |
| 191 | (!set-syntax | |
| 192 | (if (stringp s) | |
| 193 | (char (the string s) 0) | |
| 194 | s) | |
| 195 | (cdr x)))) | |
| 196 | l)) | |
| 190 | (declare (type (or simple-string character) s)) | |
| 191 | (!set-syntax | |
| 192 | (if (stringp s) | |
| 193 | (char (the string s) 0) | |
| 194 | s) | |
| 195 | (cdr x)))) | |
| 196 | l)) | |
| 197 | 197 | |
| 198 | 198 | ;;; !READ-IN |
| 199 | 199 | ;;; read a token iff the last input is not processed yet, |
| 221 | 221 | ` (when (eq *reader-input* *reader-void*) |
| 222 | 222 | (setq *reader-input* (read-sym)))) |
| 223 | 223 | |
| 224 | (defmacro reader-is-at-eof () | |
| 225 | `(eq *lex-eof* *reader-input*)) | |
| 226 | ||
| 227 | (defmacro at-eof-or-control-d () | |
| 228 | `(or (reader-is-at-eof) | |
| 229 | (equal *reader-input* control-d-string))) | |
| 230 | ||
| 231 | 224 | ;;; !READ-DISCARD |
| 232 | 225 | ;;; discard the last input token. |
| 233 | 226 | ;;; |
| 234 | 227 | (defmacro !read-discard () |
| 235 | 228 | `(progn ;; (clear-input) |
| 236 | ;; (setq *token-buf* nil) | |
| 237 | (setq *reader-input* *reader-void*))) | |
| 229 | ;; (setq *token-buf* nil) | |
| 230 | (setq *reader-input* *reader-void*))) | |
| 238 | 231 | |
| 239 | 232 | ;;; !READ-SYM |
| 240 | 233 | ;;; read a token. |
| 241 | 234 | ;;; |
| 242 | 235 | (defun !read-sym () |
| 243 | 236 | (cond ((eq *reader-input* *reader-void*) (read-sym)) |
| 244 | (t (prog1 *reader-input* | |
| 245 | (!read-discard))))) | |
| 237 | (t (prog1 *reader-input* | |
| 238 | (!read-discard))))) | |
| 246 | 239 | |
| 247 | 240 | ;;; |
| 248 | 241 | (defun test-lex (file) |
| 249 | 242 | (!lex-read-init) |
| 250 | 243 | (with-open-file (str file :direction :input) |
| 251 | 244 | (let ((tok nil) |
| 252 | (*standard-input* str)) | |
| 245 | (*standard-input* str)) | |
| 253 | 246 | (while-not (eq tok *lex-eof*) |
| 254 | 247 | (setf tok (!read-sym)) |
| 255 | (print tok))))) | |
| 248 | (print tok))))) | |
| 256 | 249 | |
| 257 | 250 | ;;; SIMPLE READER_______________________________________________________________ |
| 258 | 251 | ;;; |
| 272 | 265 | |
| 273 | 266 | (defun read-lines (&optional (stream *standard-input*)) |
| 274 | 267 | (declare (type stream stream) |
| 275 | (values simple-string fixnum)) | |
| 268 | (values simple-string fixnum)) | |
| 276 | 269 | (let (res |
| 277 | line | |
| 278 | (ll 0) | |
| 279 | l-char | |
| 280 | (l-total 0)) | |
| 270 | line | |
| 271 | (ll 0) | |
| 272 | l-char | |
| 273 | (l-total 0)) | |
| 281 | 274 | (declare (type fixnum l-total ll)) |
| 282 | 275 | (loop (setq line (read-line stream nil .read-line-eof.)) |
| 283 | 276 | (when (eq line .read-line-eof.) (return)) |
| 284 | 277 | (when (<= (setq ll (length (the simple-string line))) 0) |
| 285 | (return)) | |
| 278 | (return)) | |
| 286 | 279 | (incf l-total ll) |
| 287 | 280 | (decf ll) |
| 288 | 281 | (setq l-char (char line ll)) |
| 289 | 282 | (if (char= line-continue-char (the character l-char)) |
| 290 | (progn | |
| 291 | (setq res (concatenate 'string res | |
| 292 | (setq line (subseq (the simple-string line) | |
| 293 | 0 ll)) | |
| 294 | newline-string | |
| 295 | )) | |
| 296 | ;; (decf l-total) | |
| 297 | (when (at-top-level) | |
| 298 | (princ "> ") | |
| 299 | (force-output))) | |
| 300 | (progn | |
| 301 | (setq res (concatenate 'string | |
| 302 | res | |
| 303 | (if (char= #\. (the character l-char)) | |
| 304 | (progn | |
| 305 | ;; (decf l-total) | |
| 306 | (subseq line 0 ll)) | |
| 307 | line))) | |
| 308 | (return)))) | |
| 283 | (progn | |
| 284 | (setq res (concatenate 'string res | |
| 285 | (setq line (subseq (the simple-string line) | |
| 286 | 0 ll)) | |
| 287 | newline-string | |
| 288 | )) | |
| 289 | ;; (decf l-total) | |
| 290 | (when (at-top-level) | |
| 291 | (princ "> ") | |
| 292 | (force-output))) | |
| 293 | (progn | |
| 294 | (setq res (concatenate 'string | |
| 295 | res | |
| 296 | (if (char= #\. (the character l-char)) | |
| 297 | (progn | |
| 298 | ;; (decf l-total) | |
| 299 | (subseq line 0 ll)) | |
| 300 | line))) | |
| 301 | (return)))) | |
| 309 | 302 | (if (eq line .read-line-eof.) |
| 310 | (values *lex-eof* 0) | |
| 303 | (values *lex-eof* 0) | |
| 311 | 304 | (let ((str (if res |
| 312 | (if *live-newline* | |
| 313 | (add-new-line res) | |
| 314 | res) | |
| 315 | ""))) | |
| 316 | (values str (length str)))))) | |
| 305 | (if *live-newline* | |
| 306 | (add-new-line res) | |
| 307 | res) | |
| 308 | ""))) | |
| 309 | (values str (length str)))))) | |
| 317 | 310 | |
| 318 | 311 | ;;; the global .reader-ch. holds the last char read. |
| 319 | 312 | ;;; if the character has a property other than 'nil, the property value is set, |
| 328 | 321 | (defvar .default-escape-char. #\\) |
| 329 | 322 | |
| 330 | 323 | ;;; |
| 331 | #-CMU (defparameter control-d #\^D) | |
| 332 | #+CMU (defparameter control-d #\) | |
| 324 | (defparameter control-d #\Eot) | |
| 333 | 325 | (defparameter control-d-string "") |
| 334 | 326 | (defparameter input-escape #\esc) |
| 335 | 327 | (defparameter input-escape-string "") |
| 336 | 328 | |
| 337 | (defmacro at-eof () `(eq *lex-eof* .reader-ch.)) | |
| 338 | ||
| 339 | 329 | (defmacro see-ctrl-d () |
| 340 | 330 | `(eq .reader-ch. control-d)) |
| 341 | 331 | |
| 332 | (defmacro reader-is-at-eof () | |
| 333 | `(eq *lex-eof* *reader-input*)) | |
| 334 | ||
| 335 | (defmacro at-eof () `(or (see-ctrl-d) (eq *lex-eof* .reader-ch.))) | |
| 336 | ||
| 337 | (defmacro at-eof-or-control-d () | |
| 338 | `(or (at-eof) | |
| 339 | (equal *reader-input* control-d-string))) | |
| 340 | ||
| 341 | ||
| 342 | ||
| 342 | 343 | (defmacro see-input-escape () |
| 343 | 344 | `(eq .reader-ch. input-escape)) |
| 344 | ;; (defmacro see-input-escape () | |
| 345 | ;; `(eq .reader-ch. control-d)) | |
| 346 | 345 | |
| 347 | 346 | (defun str-match? (x y) |
| 348 | 347 | (declare (type t x) |
| 349 | (type (or symbol simple-string) y) | |
| 350 | (values (or null t))) | |
| 348 | (type (or symbol simple-string) y) | |
| 349 | (values (or null t))) | |
| 351 | 350 | (or (eq x y) |
| 352 | 351 | (and (stringp x) |
| 353 | (string= (the simple-string x) | |
| 354 | (if (stringp y) | |
| 355 | (the simple-string y) | |
| 356 | (string-downcase (string (the symbol y)))))))) | |
| 352 | (string= (the simple-string x) | |
| 353 | (if (stringp y) | |
| 354 | (the simple-string y) | |
| 355 | (string-downcase (string (the symbol y)))))))) | |
| 357 | 356 | |
| 358 | 357 | (defun lex-string-match(x y) |
| 359 | 358 | (declare (type t x) |
| 360 | (type (or atom list) y) | |
| 361 | (values (or null t))) | |
| 359 | (type (or atom list) y) | |
| 360 | (values (or null t))) | |
| 362 | 361 | (if (atom y) |
| 363 | 362 | (str-match? x y) |
| 364 | 363 | (member x y :test #'str-match?))) |
| 367 | 366 | ;;; reads a one character from stream, set .reader-ch. handling ESCAPE sequence. |
| 368 | 367 | ;;; |
| 369 | 368 | (declaim (special .reader-escape.)) |
| 370 | (defvar .reader-escape. nil) ; flags indicating we are now in `escaped' | |
| 371 | ; status. | |
| 369 | (defvar .reader-escape. nil) ; flags indicating we are now in `escaped' | |
| 370 | ; status. | |
| 372 | 371 | |
| 373 | 372 | ;; (defvar .read-buffer. nil) |
| 374 | 373 | ;; (defvar .read-pos. 0) |
| 379 | 378 | |
| 380 | 379 | (defun reader-get-char (stream) |
| 381 | 380 | (declare (type stream stream) |
| 382 | (values t)) | |
| 381 | (values t)) | |
| 383 | 382 | (let ((inch (read-char stream nil *lex-eof*))) |
| 384 | 383 | (cond ((eq inch *lex-eof*) |
| 385 | (setf .reader-ch. *lex-eof*)) | |
| 386 | #|| | |
| 387 | (.reader-escape. | |
| 388 | (setf .reader-ch. inch)) | |
| 389 | ((char= .escape-char. inch) | |
| 390 | (let ((.reader-escape. t)) | |
| 391 | (setf .reader-ch. 'space) | |
| 392 | (reader-get-char stream))) | |
| 393 | ||# | |
| 394 | (t (unless *chaos-input-source* | |
| 395 | ;; interactive session | |
| 396 | (if (and (char= inch #\newline) | |
| 397 | *last-newline*) | |
| 398 | (incf .newline-count.) | |
| 399 | (if (char= inch #\newline) | |
| 400 | (setq *last-newline* t) | |
| 401 | (setf .newline-count. 0 | |
| 402 | *last-newline* nil))) | |
| 403 | (when (> .newline-count. 2) | |
| 404 | (!read-discard) | |
| 405 | (clear-input) | |
| 406 | (setq *last-newline* nil) | |
| 407 | (setq .newline-count. 0) | |
| 408 | (throw :aborting-read :aborting-read))) | |
| 409 | ;; | |
| 410 | (let ((val (reader-get-syntax inch))) | |
| 411 | (setf .reader-ch. (if val val inch))))))) | |
| 384 | (setf .reader-ch. *lex-eof*)) | |
| 385 | #|| | |
| 386 | (.reader-escape. | |
| 387 | (setf .reader-ch. inch)) | |
| 388 | ((char= .escape-char. inch) | |
| 389 | (let ((.reader-escape. t)) | |
| 390 | (setf .reader-ch. 'space) | |
| 391 | (reader-get-char stream))) | |
| 392 | ||# | |
| 393 | (t (unless *chaos-input-source* | |
| 394 | ;; interactive session | |
| 395 | (if (and (char= inch #\newline) | |
| 396 | *last-newline*) | |
| 397 | (incf .newline-count.) | |
| 398 | (if (char= inch #\newline) | |
| 399 | (setq *last-newline* t) | |
| 400 | (setf .newline-count. 0 | |
| 401 | *last-newline* nil))) | |
| 402 | (when (> .newline-count. 2) | |
| 403 | (!read-discard) | |
| 404 | (clear-input) | |
| 405 | (setq *last-newline* nil) | |
| 406 | (setq .newline-count. 0) | |
| 407 | (throw :aborting-read :aborting-read))) | |
| 408 | ;; | |
| 409 | (let ((val (reader-get-syntax inch))) | |
| 410 | (setf .reader-ch. (if val val inch))))))) | |
| 412 | 411 | |
| 413 | 412 | ; (defun reader-get-char (stream) |
| 414 | 413 | ; (declare (type stream stream) |
| 415 | ; (values t)) | |
| 414 | ; (values t)) | |
| 416 | 415 | ; (let ((inch (read-char stream nil *lex-eof*))) |
| 417 | 416 | ; (cond ((eq inch *lex-eof*) |
| 418 | ; (setf .reader-ch. *lex-eof*)) | |
| 419 | ; #|| | |
| 420 | ; (.reader-escape. | |
| 421 | ; (setf .reader-ch. inch)) | |
| 422 | ; ((char= .escape-char. inch) | |
| 423 | ; (let ((.reader-escape. t)) | |
| 424 | ; (setf .reader-ch. 'space) | |
| 425 | ; (reader-get-char stream))) | |
| 426 | ; ||# | |
| 427 | ; (t (let ((val (reader-get-syntax inch))) | |
| 428 | ; (setf .reader-ch. (if val val inch))))))) | |
| 417 | ; (setf .reader-ch. *lex-eof*)) | |
| 418 | ; #|| | |
| 419 | ; (.reader-escape. | |
| 420 | ; (setf .reader-ch. inch)) | |
| 421 | ; ((char= .escape-char. inch) | |
| 422 | ; (let ((.reader-escape. t)) | |
| 423 | ; (setf .reader-ch. 'space) | |
| 424 | ; (reader-get-char stream))) | |
| 425 | ; ||# | |
| 426 | ; (t (let ((val (reader-get-syntax inch))) | |
| 427 | ; (setf .reader-ch. (if val val inch))))))) | |
| 429 | 428 | |
| 430 | 429 | ;;; READ-LEXICON : STREAM -> TOKEN |
| 431 | 430 | ;;; read a lexicon. |
| 445 | 444 | (defun read-lexicon (&optional (stream *standard-input*)) |
| 446 | 445 | (declare (type stream stream)) |
| 447 | 446 | (let ((p -1) |
| 448 | res) | |
| 447 | res) | |
| 449 | 448 | (declare (type fixnum p) |
| 450 | (type (or symbol list simple-string) res)) | |
| 449 | (type (or symbol list simple-string) res)) | |
| 451 | 450 | (setq res |
| 452 | (loop (cond ((member .reader-ch. '(#\Rubout #\Backspace)) | |
| 453 | (if (<= 0 p) | |
| 454 | (decf p 1))) | |
| 455 | ((characterp .reader-ch.) | |
| 456 | (incf p) | |
| 457 | (setf (aref .reader-buf. p) .reader-ch.)) | |
| 458 | (t (let ((c (string .reader-ch.))) | |
| 459 | (setq .reader-ch. 'space) | |
| 460 | (return c)))) | |
| 461 | (reader-get-char stream) | |
| 462 | (when (at-eof) | |
| 463 | (if (<= 0 p) | |
| 464 | (progn (setq .reader-ch. 'space) | |
| 465 | (return (subseq .reader-buf. 0 (1+ p)))) | |
| 466 | (return *lex-eof*))) | |
| 467 | (when (symbolp .reader-ch.) | |
| 468 | (return (subseq .reader-buf. 0 (1+ p)))) | |
| 469 | )) | |
| 451 | (loop (cond ((member .reader-ch. '(#\Rubout #\Backspace)) | |
| 452 | (if (<= 0 p) | |
| 453 | (decf p 1))) | |
| 454 | ((characterp .reader-ch.) | |
| 455 | (incf p) | |
| 456 | (setf (aref .reader-buf. p) .reader-ch.)) | |
| 457 | (t (let ((c (string .reader-ch.))) | |
| 458 | (setq .reader-ch. 'space) | |
| 459 | (return c)))) | |
| 460 | (reader-get-char stream) | |
| 461 | (when (at-eof) | |
| 462 | (if (<= 0 p) | |
| 463 | (progn (setq .reader-ch. 'space) | |
| 464 | (return (subseq .reader-buf. 0 (1+ p)))) | |
| 465 | (return *lex-eof*))) | |
| 466 | (when (symbolp .reader-ch.) | |
| 467 | (return (subseq .reader-buf. 0 (1+ p)))) | |
| 468 | )) | |
| 470 | 469 | ;; |
| 471 | 470 | (lex-consider-token res))) |
| 472 | 471 | |
| 475 | 474 | (if (equal .chaos-simple-LISP-keyword. tok) |
| 476 | 475 | (progn (reader-suppress-ch tok) (list .lisp-simple-sexpr. (read))) |
| 477 | 476 | (if (equal .chaos-general-lisp-keyword. tok) |
| 478 | (progn (reader-suppress-ch tok) (list .lisp-general-sexpr. (read))) | |
| 477 | (progn (reader-suppress-ch tok) (list .lisp-general-sexpr. (read))) | |
| 479 | 478 | (if (equal .chaos-value-keyword. tok) |
| 480 | (progn (reader-suppress-ch tok) (list .chaos-value-sexpr. (read))) | |
| 481 | tok)))) | |
| 479 | (progn (reader-suppress-ch tok) (list .chaos-value-sexpr. (read))) | |
| 480 | tok)))) | |
| 482 | 481 | |
| 483 | 482 | (defun reader-suppress-ch (context &optional (stream *standard-input*)) |
| 484 | 483 | (declare (ignore context) |
| 485 | (type stream stream) | |
| 486 | (values t)) | |
| 484 | (type stream stream) | |
| 485 | (values t)) | |
| 487 | 486 | (unless (at-eof) |
| 488 | 487 | (unless (memq .reader-ch. '(space return)) |
| 489 | 488 | (unread-char (if (characterp .reader-ch.) |
| 490 | .reader-ch. | |
| 491 | (char (the simple-string (string .reader-ch.)) 0)) | |
| 492 | stream) | |
| 489 | .reader-ch. | |
| 490 | (char (the simple-string (string .reader-ch.)) 0)) | |
| 491 | stream) | |
| 493 | 492 | (setq .reader-ch. 'space)))) |
| 494 | 493 | |
| 495 | 494 | (defun reader-unread (ch stream) |
| 496 | 495 | (declare (type (or symbol character) ch) |
| 497 | (type stream stream) | |
| 498 | (values t)) | |
| 496 | (type stream stream) | |
| 497 | (values t)) | |
| 499 | 498 | (unless (memq ch '(space return)) |
| 500 | 499 | (unread-char (if (characterp ch) |
| 501 | ch | |
| 502 | (char (the simple-string (string (the symbol ch))) 0)) | |
| 503 | stream) | |
| 500 | ch | |
| 501 | (char (the simple-string (string (the symbol ch))) 0)) | |
| 502 | stream) | |
| 504 | 503 | ch)) |
| 505 | 504 | |
| 506 | 505 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; |
| 510 | 509 | (loop |
| 511 | 510 | (reader-get-char stream) |
| 512 | 511 | (cond ((at-eof) |
| 513 | (setf .reader-ch. 'space) | |
| 514 | (!read-discard) | |
| 515 | (return-from skip-multi-comment *lex-eof*)) | |
| 516 | (t (case .reader-ch. | |
| 517 | (#\" (lex-read-string stream)) | |
| 518 | (#\| | |
| 519 | (reader-get-char stream) | |
| 520 | (when (equal .reader-ch. #\#) | |
| 521 | (!read-discard) | |
| 522 | (setq .reader-ch. 'space) | |
| 523 | (return-from skip-multi-comment nil)) | |
| 524 | (when (at-eof) | |
| 525 | (setf .reader-ch. 'space) | |
| 526 | (!read-discard) | |
| 527 | (return-from skip-multi-comment *lex-eof*)) | |
| 528 | (reader-unread .reader-ch. stream)))))))) | |
| 512 | (setf .reader-ch. 'space) | |
| 513 | (!read-discard) | |
| 514 | (return-from skip-multi-comment *lex-eof*)) | |
| 515 | (t (case .reader-ch. | |
| 516 | (#\" (lex-read-string stream)) | |
| 517 | (#\| | |
| 518 | (reader-get-char stream) | |
| 519 | (when (equal .reader-ch. #\#) | |
| 520 | (!read-discard) | |
| 521 | (setq .reader-ch. 'space) | |
| 522 | (return-from skip-multi-comment nil)) | |
| 523 | (when (at-eof) | |
| 524 | (setf .reader-ch. 'space) | |
| 525 | (!read-discard) | |
| 526 | (return-from skip-multi-comment *lex-eof*)) | |
| 527 | (reader-unread .reader-ch. stream)))))))) | |
| 529 | 528 | |
| 530 | 529 | ;;; READ-SYM : STREAM -> TOKEN |
| 531 | 530 | ;;; read characters considered to be constructs of a token, returns |
| 543 | 542 | |
| 544 | 543 | (defun read-sym (&optional (stream *standard-input*) (parse-list nil)) |
| 545 | 544 | (declare (type stream stream) |
| 546 | (type (or null t) parse-list)) | |
| 545 | (type (or null t) parse-list)) | |
| 547 | 546 | (flet ((skip-whites () |
| 548 | ;; skip white chars. | |
| 549 | (while (memq .reader-ch. (if *live-newline* '(space) | |
| 550 | '(space return))) | |
| 551 | (reader-get-char stream)))) | |
| 547 | ;; skip white chars. | |
| 548 | (while (memq .reader-ch. (if *live-newline* '(space) | |
| 549 | '(space return))) | |
| 550 | (reader-get-char stream)))) | |
| 552 | 551 | (when *token-buf* |
| 553 | 552 | (return-from read-sym (pop *token-buf*))) |
| 554 | 553 | ;; skip white chars. |
| 556 | 555 | ;; get token |
| 557 | 556 | ;; (setq *last-token* nil) |
| 558 | 557 | (cond ((at-eof) (setf .reader-ch. 'space) |
| 559 | (!read-discard) | |
| 560 | (return-from read-sym (progn (setq *last-token* *reader-void*) *lex-eof*))) | |
| 561 | ((see-input-escape) | |
| 562 | ;; user forces aborting reading process. | |
| 563 | (setq .reader-ch. 'space) | |
| 564 | (!read-discard) | |
| 565 | (clear-input) | |
| 566 | (throw :aborting-read :aborting-read)) | |
| 567 | (t (case .reader-ch. | |
| 568 | (|(| (if parse-list | |
| 569 | (setq *last-token* (lex-read-list stream)) | |
| 570 | (progn | |
| 571 | (setq .reader-ch. 'space) | |
| 572 | (setq *last-token* "("))) | |
| 573 | (return-from read-sym *last-token*)) | |
| 574 | (return | |
| 575 | (setq .reader-ch. 'space) | |
| 576 | (setq *last-token* (if *live-newline* | |
| 577 | '(return) | |
| 578 | *reader-void*)) | |
| 579 | (return-from read-sym *last-token*)) | |
| 580 | (#\" ; string | |
| 581 | (return-from read-sym (setq *last-token* (list (lex-read-string stream))))) | |
| 582 | (#\# ; #! or #!! | |
| 583 | (reader-get-char stream) | |
| 584 | (cond ((memq .reader-ch. '(space return)) | |
| 585 | (return-from read-sym (setq *last-token* '("#")))) | |
| 586 | ((eq .reader-ch. *lisp-escape-char*) | |
| 587 | (return-from read-sym (setq *last-token* (lex-read-lisp-escape stream)))) | |
| 588 | ((eq .reader-ch. *chaos-escape-char*) | |
| 589 | (return-from read-sym (setq *last-token* (lex-read-chaos-value stream)))) | |
| 590 | ((equal .reader-ch. #\|) ; begin multi comment | |
| 591 | (setq .lex-inner-multi-comment. t) | |
| 592 | (skip-multi-comment stream) | |
| 593 | (setq .lex-inner-multi-comment. nil) | |
| 594 | (skip-whites)) | |
| 595 | (t (reader-unread .reader-ch. stream) | |
| 596 | (setq .reader-ch. #\#) | |
| 597 | (let ((tok (read-lexicon stream))) | |
| 598 | (if (equal tok *lex-eof*) | |
| 599 | (return-from read-sym | |
| 600 | (progn (setq *last-token* *reader-void*) | |
| 601 | *lex-eof*)) | |
| 602 | (return-from read-sym (setq *last-token* tok)))))))) | |
| 603 | ;; | |
| 604 | (if (symbolp .reader-ch.) | |
| 605 | (let ((str (string .reader-ch.))) | |
| 606 | (setq .reader-ch. 'space) | |
| 607 | (return-from read-sym (setq *last-token* (lex-consider-token str)))) | |
| 608 | (let ((tok (read-lexicon stream))) | |
| 609 | (if (eq tok *lex-eof*) | |
| 610 | (return-from read-sym | |
| 611 | (progn (setq *last-token* *reader-void*) | |
| 612 | *lex-eof*)) | |
| 613 | (return-from read-sym (setq *last-token* tok))))))))) | |
| 558 | (!read-discard) | |
| 559 | (return-from read-sym (progn (setq *last-token* *reader-void*) *lex-eof*))) | |
| 560 | ((see-input-escape) | |
| 561 | ;; user forces aborting reading process. | |
| 562 | (setq .reader-ch. 'space) | |
| 563 | (!read-discard) | |
| 564 | (clear-input) | |
| 565 | (throw :aborting-read :aborting-read)) | |
| 566 | (t (case .reader-ch. | |
| 567 | (|(| (if parse-list | |
| 568 | (setq *last-token* (lex-read-list stream)) | |
| 569 | (progn | |
| 570 | (setq .reader-ch. 'space) | |
| 571 | (setq *last-token* "("))) | |
| 572 | (return-from read-sym *last-token*)) | |
| 573 | (return | |
| 574 | (setq .reader-ch. 'space) | |
| 575 | (setq *last-token* (if *live-newline* | |
| 576 | '(return) | |
| 577 | *reader-void*)) | |
| 578 | (return-from read-sym *last-token*)) | |
| 579 | (#\" ; string | |
| 580 | (return-from read-sym (setq *last-token* (list (lex-read-string stream))))) | |
| 581 | (#\# ; #! or #!! | |
| 582 | (reader-get-char stream) | |
| 583 | (cond ((memq .reader-ch. '(space return)) | |
| 584 | (return-from read-sym (setq *last-token* '("#")))) | |
| 585 | ((eq .reader-ch. *lisp-escape-char*) | |
| 586 | (return-from read-sym (setq *last-token* (lex-read-lisp-escape stream)))) | |
| 587 | ((eq .reader-ch. *chaos-escape-char*) | |
| 588 | (return-from read-sym (setq *last-token* (lex-read-chaos-value stream)))) | |
| 589 | ((equal .reader-ch. #\|) ; begin multi comment | |
| 590 | (setq .lex-inner-multi-comment. t) | |
| 591 | (skip-multi-comment stream) | |
| 592 | (setq .lex-inner-multi-comment. nil) | |
| 593 | (skip-whites)) | |
| 594 | (t (reader-unread .reader-ch. stream) | |
| 595 | (setq .reader-ch. #\#) | |
| 596 | (let ((tok (read-lexicon stream))) | |
| 597 | (if (equal tok *lex-eof*) | |
| 598 | (return-from read-sym | |
| 599 | (progn (setq *last-token* *reader-void*) | |
| 600 | *lex-eof*)) | |
| 601 | (return-from read-sym (setq *last-token* tok)))))))) | |
| 602 | ;; | |
| 603 | (if (symbolp .reader-ch.) | |
| 604 | (let ((str (string .reader-ch.))) | |
| 605 | (setq .reader-ch. 'space) | |
| 606 | (return-from read-sym (setq *last-token* (lex-consider-token str)))) | |
| 607 | (let ((tok (read-lexicon stream))) | |
| 608 | (if (eq tok *lex-eof*) | |
| 609 | (return-from read-sym | |
| 610 | (progn (setq *last-token* *reader-void*) | |
| 611 | *lex-eof*)) | |
| 612 | (return-from read-sym (setq *last-token* tok))))))))) | |
| 614 | 613 | |
| 615 | 614 | ;;; builtin string reader |
| 616 | 615 | (defun lex-read-string (stream) |
| 617 | 616 | (declare (type stream stream) |
| 618 | (values t)) | |
| 617 | (values t)) | |
| 619 | 618 | (reader-unread .reader-ch. stream) |
| 620 | 619 | (let ((str (read stream nil *lex-eof*))) |
| 621 | 620 | (if (eq str *lex-eof*) |
| 622 | *lex-eof* | |
| 623 | (prog1 | |
| 624 | (list .String-token. str) | |
| 625 | (setf .reader-ch. 'space))))) | |
| 621 | *lex-eof* | |
| 622 | (prog1 | |
| 623 | (list .String-token. str) | |
| 624 | (setf .reader-ch. 'space))))) | |
| 626 | 625 | |
| 627 | 626 | ;; builtin lisp expression |
| 628 | 627 | (defun lex-read-lisp-escape (stream) |
| 629 | 628 | (declare (type stream stream) |
| 630 | (values list)) | |
| 629 | (values list)) | |
| 631 | 630 | (let ((nx nil)) |
| 632 | 631 | (setq nx (reader-get-char stream)) |
| 633 | 632 | (while (memq .reader-ch. '(space return)) |
| 636 | 635 | ((*lisp-escape-char* *chaos-escape-char*) |
| 637 | 636 | ;; #!! |
| 638 | 637 | (let ((expr (read stream nil *lex-eof*))) |
| 639 | (setq .reader-ch. 'space) | |
| 640 | (if (equal expr *lex-eof*) | |
| 641 | (progn (setq *last-token* *reader-void*) | |
| 642 | (setq .reader-ch. 'space) | |
| 643 | *lex-eof*) | |
| 644 | (list .lisp-general-sexpr. expr)))) | |
| 638 | (setq .reader-ch. 'space) | |
| 639 | (if (equal expr *lex-eof*) | |
| 640 | (progn (setq *last-token* *reader-void*) | |
| 641 | (setq .reader-ch. 'space) | |
| 642 | *lex-eof*) | |
| 643 | (list .lisp-general-sexpr. expr)))) | |
| 645 | 644 | (otherwise |
| 646 | 645 | ;; #! |
| 647 | 646 | (let ((expr nil)) |
| 648 | (setq .reader-ch. 'space) | |
| 649 | (reader-unread nx stream) | |
| 650 | (setq expr (read stream nil *lex-eof*)) | |
| 651 | (if (equal expr *lex-eof*) | |
| 652 | (progn (setq *last-token* *reader-void*) | |
| 653 | *lex-eof*) | |
| 654 | (list .lisp-simple-sexpr. expr)))))) | |
| 647 | (setq .reader-ch. 'space) | |
| 648 | (reader-unread nx stream) | |
| 649 | (setq expr (read stream nil *lex-eof*)) | |
| 650 | (if (equal expr *lex-eof*) | |
| 651 | (progn (setq *last-token* *reader-void*) | |
| 652 | *lex-eof*) | |
| 653 | (list .lisp-simple-sexpr. expr)))))) | |
| 655 | 654 | ) |
| 656 | 655 | |
| 657 | 656 | (defun lex-read-chaos-value (stream) |
| 658 | 657 | (declare (type stream stream) |
| 659 | (values list)) | |
| 658 | (values list)) | |
| 660 | 659 | (let ((expr (read stream nil *lex-eof*))) |
| 661 | 660 | (setq .reader-ch. 'space) |
| 662 | 661 | (if (equal expr *lex-eof*) |
| 663 | (progn (setq *last-token* *reader-void*) | |
| 664 | *lex-eof*) | |
| 662 | (progn (setq *last-token* *reader-void*) | |
| 663 | *lex-eof*) | |
| 665 | 664 | (list .chaos-value-sexpr. expr)))) |
| 666 | 665 | |
| 667 | 666 | ;;; builtin character reader : obsolate |
| 669 | 668 | (defun lex-read-character (stream) |
| 670 | 669 | (let ((char (read-char stream nil *lex-eof*))) |
| 671 | 670 | (if (eq char *lex-eof*) |
| 672 | *lex-eof* | |
| 673 | (progn | |
| 674 | (when (eql char #\\) ; escape char | |
| 675 | (let ((echar (read-char stream nil *lex-eof*))) | |
| 676 | (if (eq echar *lex-eof*) | |
| 677 | (return-from lex-read-character *lex-eof*) | |
| 678 | (setf char | |
| 679 | (case echar | |
| 680 | (#\n #\Newline) | |
| 681 | (#\r #\Return) | |
| 682 | (#\t #\Tab) | |
| 683 | (#\s #\Space) | |
| 684 | (#\l #\LineFeed) | |
| 685 | (#\p #\Page) | |
| 686 | (otherwise echar)))))) | |
| 687 | (setf .reader-ch. 'space) | |
| 688 | (list .Char-token. char))))) | |
| 671 | *lex-eof* | |
| 672 | (progn | |
| 673 | (when (eql char #\\) ; escape char | |
| 674 | (let ((echar (read-char stream nil *lex-eof*))) | |
| 675 | (if (eq echar *lex-eof*) | |
| 676 | (return-from lex-read-character *lex-eof*) | |
| 677 | (setf char | |
| 678 | (case echar | |
| 679 | (#\n #\Newline) | |
| 680 | (#\r #\Return) | |
| 681 | (#\t #\Tab) | |
| 682 | (#\s #\Space) | |
| 683 | (#\l #\LineFeed) | |
| 684 | (#\p #\Page) | |
| 685 | (otherwise echar)))))) | |
| 686 | (setf .reader-ch. 'space) | |
| 687 | (list .Char-token. char))))) | |
| 689 | 688 | ||# |
| 690 | 689 | |
| 691 | 690 | ;;; read up to matching close parenthesis |
| 697 | 696 | |
| 698 | 697 | (defun lex-read-rest-of-list (&optional (stream *standard-input*)) |
| 699 | 698 | (declare (type stream stream) |
| 700 | (values list)) | |
| 699 | (values list)) | |
| 701 | 700 | (while (memq .reader-ch. '(space return)) |
| 702 | 701 | (reader-get-char stream)) |
| 703 | 702 | (if (at-eof) |
| 704 | 703 | *lex-eof* |
| 705 | 704 | (if (eq '|)| .reader-ch.) |
| 706 | (progn | |
| 707 | (reader-get-char stream) | |
| 708 | (list "(" ")")) | |
| 709 | (let ((res (list "(")) | |
| 710 | x) | |
| 711 | (loop (setq x (lex-read stream)) | |
| 712 | (when (eq *lex-eof* x) | |
| 713 | (return *lex-eof*)) | |
| 714 | (setq res (append res x)) | |
| 715 | ;; (wait-until-non-white stream) | |
| 716 | (while (memq .reader-ch. '(space return)) | |
| 717 | (reader-get-char stream)) | |
| 718 | (when (eq '|)| .reader-ch.) | |
| 719 | (reader-get-char stream) | |
| 720 | (return (nconc res (list ")")))) | |
| 721 | (when (at-eof) | |
| 722 | (return *lex-eof*))) | |
| 723 | )))) | |
| 705 | (progn | |
| 706 | (reader-get-char stream) | |
| 707 | (list "(" ")")) | |
| 708 | (let ((res (list "(")) | |
| 709 | x) | |
| 710 | (loop (setq x (lex-read stream)) | |
| 711 | (when (eq *lex-eof* x) | |
| 712 | (return *lex-eof*)) | |
| 713 | (setq res (append res x)) | |
| 714 | ;; (wait-until-non-white stream) | |
| 715 | (while (memq .reader-ch. '(space return)) | |
| 716 | (reader-get-char stream)) | |
| 717 | (when (eq '|)| .reader-ch.) | |
| 718 | (reader-get-char stream) | |
| 719 | (return (nconc res (list ")")))) | |
| 720 | (when (at-eof) | |
| 721 | (return *lex-eof*))) | |
| 722 | )))) | |
| 724 | 723 | |
| 725 | 724 | ;;; LEX-READ : STREAM -> List[Token] |
| 726 | 725 | ;;; standard routine to get token from stream. |
| 727 | 726 | ;;; |
| 728 | 727 | (defun bi-token? (tok) |
| 729 | 728 | (declare (type t tok) |
| 730 | (values (or null t))) | |
| 729 | (values (or null t))) | |
| 731 | 730 | (and (consp tok) |
| 732 | 731 | (let ((tm (car tok))) |
| 733 | (and (symbolp tm) | |
| 734 | (get tm ':bi-token))))) | |
| 732 | (and (symbolp tm) | |
| 733 | (get tm ':bi-token))))) | |
| 735 | 734 | |
| 736 | 735 | (defun lex-read (&optional (stream *standard-input*)) |
| 737 | 736 | (declare (type stream stream) |
| 738 | (values t)) | |
| 737 | (values t)) | |
| 739 | 738 | (let ((tok (read-sym stream t))) |
| 740 | 739 | (if (eq *lex-eof* tok) |
| 741 | *lex-eof* | |
| 742 | (cond ((atom tok) | |
| 743 | (if tok | |
| 744 | (list tok) | |
| 745 | nil)) | |
| 746 | (t (if (bi-token? tok) | |
| 747 | (list tok) | |
| 748 | tok)))))) | |
| 740 | *lex-eof* | |
| 741 | (cond ((atom tok) | |
| 742 | (if tok | |
| 743 | (list tok) | |
| 744 | nil)) | |
| 745 | (t (if (bi-token? tok) | |
| 746 | (list tok) | |
| 747 | tok)))))) | |
| 749 | 748 | |
| 750 | 749 | ;;; returns t iff the characters in the string are all digit char. |
| 751 | 750 | |
| 753 | 752 | (once-only (string) |
| 754 | 753 | ` (the (or null t) |
| 755 | 754 | (do ((s (the fixnum ,start) (1+ s))) |
| 756 | ((>= s ,end) t) | |
| 757 | (declare (type fixnum s end)) | |
| 758 | (if (not (digit-char-p (schar ,string s))) (return nil)))))) | |
| 755 | ((>= s ,end) t) | |
| 756 | (declare (type fixnum s end)) | |
| 757 | (if (not (digit-char-p (schar ,string s))) (return nil)))))) | |
| 759 | 758 | |
| 760 | 759 | ;;; BUFFERED-INPUT______________________________________________________________ |
| 761 | 760 | ;;; one token is bufferd. |
| 791 | 790 | |
| 792 | 791 | (defun !force-single-reader (l) |
| 793 | 792 | (declare (type list l) |
| 794 | (values t)) | |
| 793 | (values t)) | |
| 795 | 794 | (dolist (x l) |
| 796 | 795 | (let* ((chr (if (and (stringp x) |
| 797 | (= (length x) 1)) | |
| 798 | (char (the string x) 0) | |
| 799 | (if (characterp x) | |
| 800 | x | |
| 801 | (with-output-chaos-error ('invalid-str) | |
| 802 | (format t "delimiter must be a single character, but ~a is given" x))))) | |
| 803 | (sym (intern (string x)))) | |
| 796 | (= (length x) 1)) | |
| 797 | (char (the string x) 0) | |
| 798 | (if (characterp x) | |
| 799 | x | |
| 800 | (with-output-chaos-error ('invalid-str) | |
| 801 | (format t "delimiter must be a single character, but ~a is given" x))))) | |
| 802 | (sym (intern (string x)))) | |
| 804 | 803 | (format t "~&setting delimiters ~S : ~S" chr sym) |
| 805 | 804 | (!set-syntax chr sym)))) |
| 806 | 805 | |
| 807 | 806 | (defun !unset-single-reader (l) |
| 808 | 807 | (declare (type list l) |
| 809 | (values t)) | |
| 808 | (values t)) | |
| 810 | 809 | (dolist (x l) |
| 811 | 810 | (let ((chr (if (and (stringp x) |
| 812 | (= (length x) 1)) | |
| 813 | (char (the string x) 0) | |
| 814 | (if (characterp x) | |
| 815 | x | |
| 816 | (with-output-chaos-error ('invalid-str) | |
| 817 | (format t "Delimiter must be a single character, but ~a is given" x)))))) | |
| 811 | (= (length x) 1)) | |
| 812 | (char (the string x) 0) | |
| 813 | (if (characterp x) | |
| 814 | x | |
| 815 | (with-output-chaos-error ('invalid-str) | |
| 816 | (format t "Delimiter must be a single character, but ~a is given" x)))))) | |
| 818 | 817 | (if (assoc chr .default-single-chars.) |
| 819 | (warn "Character '~A' is a hardwired self delimiting charcter, ignored." | |
| 820 | chr) | |
| 821 | (progn | |
| 822 | (format t "~&unsetting delimiters ~S" chr) | |
| 823 | (!set-syntax chr nil)))))) | |
| 818 | (warn "Character '~A' is a hardwired self delimiting charcter, ignored." | |
| 819 | chr) | |
| 820 | (progn | |
| 821 | (format t "~&unsetting delimiters ~S" chr) | |
| 822 | (!set-syntax chr nil)))))) | |
| 824 | 823 | ;;; |
| 825 | 824 | ;;; |
| 826 | 825 | ;;; |
| 827 | 826 | (defun !lex-read-init (&key (space .default-space-chars.) |
| 828 | (return .default-return-chars.) | |
| 829 | (single .default-single-chars.) | |
| 830 | (escape .default-escape-char.)) | |
| 827 | (return .default-return-chars.) | |
| 828 | (single .default-single-chars.) | |
| 829 | (escape .default-escape-char.)) | |
| 831 | 830 | (!init-read-table space return single) |
| 832 | 831 | (setq .escape-char. escape) |
| 833 | 832 | (setq .reader-ch. 'space) |
| 834 | 833 | (setq *reader-input* *reader-void* |
| 835 | *last-token* *reader-void* | |
| 836 | *token-buf* nil)) | |
| 834 | *last-token* *reader-void* | |
| 835 | *token-buf* nil)) | |
| 837 | 836 | |
| 838 | 837 | ;;; EOF |
| 0 | 0 | ;;;-*- Mode:Lisp; Syntax:Common-Lisp; Package:CHAOS -*- |
| 1 | 1 | ;;; |
| 2 | ;;; Copyright (c) 2000-2014, Toshimi Sawada. All rights reserved. | |
| 2 | ;;; Copyright (c) 2000-2015, Toshimi Sawada. All rights reserved. | |
| 3 | 3 | ;;; |
| 4 | 4 | ;;; Redistribution and use in source and binary forms, with or without |
| 5 | 5 | ;;; modification, are permitted provided that the following conditions |
| 27 | 27 | ;;; |
| 28 | 28 | (in-package :CHAOS) |
| 29 | 29 | #|============================================================================== |
| 30 | System: Chaos | |
| 31 | Module: comlib | |
| 32 | File: list.lisp | |
| 30 | System: Chaos | |
| 31 | Module: comlib | |
| 32 | File: list.lisp | |
| 33 | 33 | ==============================================================================|# |
| 34 | 34 | #-:chaos-debug |
| 35 | 35 | (declaim (optimize (speed 3) (safety 0) #-GCL (debug 0))) |
| 59 | 59 | (defun flatten-list (L) |
| 60 | 60 | ;; (declare (optimize (speed 3) (safety 0))) |
| 61 | 61 | (cond ((null L) '()) |
| 62 | ((atom L) L) | |
| 63 | ((consp L) | |
| 64 | (if (consp (car L)) | |
| 65 | (append (flatten-list (car L)) (flatten-list (cdr L))) | |
| 66 | (cons (car L) (flatten-list (cdr L))))) | |
| 67 | )) | |
| 62 | ((atom L) L) | |
| 63 | ((consp L) | |
| 64 | (if (consp (car L)) | |
| 65 | (append (flatten-list (car L)) (flatten-list (cdr L))) | |
| 66 | (cons (car L) (flatten-list (cdr L))))) | |
| 67 | )) | |
| 68 | 68 | |
| 69 | 69 | ;;; firstn |
| 70 | 70 | ;;; Returns a new list the same as List with only the first N elements. |
| 71 | 71 | |
| 72 | 72 | (defun firstn (list &optional (n 1)) |
| 73 | 73 | (declare ;; (optimize (speed 3) (safety 0)) |
| 74 | (type list list) | |
| 75 | (type fixnum n)) | |
| 74 | (type list list) | |
| 75 | (type fixnum n)) | |
| 76 | 76 | (cond ((> n (length list)) list) |
| 77 | ((< n 0) nil) | |
| 78 | (t (ldiff list (nthcdr n list))))) | |
| 77 | ((< n 0) nil) | |
| 78 | (t (ldiff list (nthcdr n list))))) | |
| 79 | 79 | |
| 80 | 80 | ;;; in-order-union |
| 81 | 81 | ;;; Append and remove duplicates. Like union, but the objects are |
| 97 | 97 | ;;; |
| 98 | 98 | (defun rotate-list (list num minusp) |
| 99 | 99 | (declare (type fixnum num) |
| 100 | (type t minusp)) | |
| 100 | (type t minusp)) | |
| 101 | 101 | (let ((len (length list)) |
| 102 | (new-stack (copy-list list))) | |
| 102 | (new-stack (copy-list list))) | |
| 103 | 103 | (declare (type fixnum len) |
| 104 | (type list new-stack)) | |
| 104 | (type list new-stack)) | |
| 105 | 105 | (when (>= (abs num) len) |
| 106 | 106 | (return-from rotate-list nil)) |
| 107 | 107 | (cond ((or (< num 0) (and (= num 0) minusp)) |
| 108 | (setq num (- len (1+ (abs num)))) | |
| 109 | (print num) | |
| 110 | (setq new-stack | |
| 111 | (setq new-stack (nconc (nthcdr num new-stack) | |
| 112 | (firstn new-stack num)))) | |
| 113 | ) | |
| 114 | (t (rotatef (nth 0 new-stack) | |
| 115 | (nth num new-stack)))) | |
| 108 | (setq num (- len (1+ (abs num)))) | |
| 109 | (print num) | |
| 110 | (setq new-stack | |
| 111 | (setq new-stack (nconc (nthcdr num new-stack) | |
| 112 | (firstn new-stack num)))) | |
| 113 | ) | |
| 114 | (t (rotatef (nth 0 new-stack) | |
| 115 | (nth num new-stack)))) | |
| 116 | 116 | new-stack)) |
| 117 | 117 | |
| 118 | 118 | |
| 122 | 122 | (defun delete-nth (nth lst) |
| 123 | 123 | (declare (fixnum nth)) |
| 124 | 124 | (let ((len (length lst)) |
| 125 | (new-lst nil)) | |
| 125 | (new-lst nil)) | |
| 126 | 126 | (when (>= nth len) |
| 127 | 127 | (return-from delete-nth nil)) |
| 128 | 128 | (setq new-lst (nconc (firstn lst nth) |
| 129 | (nthcdr (1+ nth) lst))) | |
| 129 | (nthcdr (1+ nth) lst))) | |
| 130 | 130 | new-lst)) |
| 131 | 131 | |
| 132 | 132 | |
| 0 | 0 | ;;;-*- Mode:Lisp; Syntax:Common-Lisp; Package:CHAOS -*- |
| 1 | 1 | ;;; |
| 2 | ;;; Copyright (c) 2000-2014, Toshimi Sawada. All rights reserved. | |
| 2 | ;;; Copyright (c) 2000-2015, Toshimi Sawada. All rights reserved. | |
| 3 | 3 | ;;; |
| 4 | 4 | ;;; Redistribution and use in source and binary forms, with or without |
| 5 | 5 | ;;; modification, are permitted provided that the following conditions |
| 0 | 0 | ;;;-*- Mode:LISP; Package:CHAOS; Base:10; Syntax:Common-lisp -*- |
| 1 | 1 | ;;; |
| 2 | ;;; Copyright (c) 2000-2014, Toshimi Sawada. All rights reserved. | |
| 2 | ;;; Copyright (c) 2000-2015, Toshimi Sawada. All rights reserved. | |
| 3 | 3 | ;;; |
| 4 | 4 | ;;; Redistribution and use in source and binary forms, with or without |
| 5 | 5 | ;;; modification, are permitted provided that the following conditions |
| 27 | 27 | ;;; |
| 28 | 28 | (in-package :chaos) |
| 29 | 29 | #|============================================================================== |
| 30 | System: CHAOS | |
| 31 | Module: comlib | |
| 32 | File: message.lisp | |
| 30 | System: CHAOS | |
| 31 | Module: comlib | |
| 32 | File: message.lisp | |
| 33 | 33 | ==============================================================================|# |
| 34 | 34 | #-:chaos-debug |
| 35 | 35 | (declaim (optimize (speed 3) (safety 0) #-GCL (debug 0))) |
| 70 | 70 | (dolist (msg msgs) |
| 71 | 71 | (register-message type msg)))) |
| 72 | 72 | (with-open-file (strm path :if-does-not-exist :error |
| 73 | :external-format :utf-8) | |
| 73 | :external-format :utf-8) | |
| 74 | 74 | (loop for type = (read strm nil :eof) |
| 75 | 75 | while (not (eq type :eof)) |
| 76 | 76 | do (case type |
| 146 | 146 | ` (progn |
| 147 | 147 | (let ((*standard-output* *error-output*) |
| 148 | 148 | (*print-indent* 4)) |
| 149 | (output-msg ',msg-id "~&[Error]" ,args) | |
| 149 | (output-msg ',msg-id "~%[Error]" ,args) | |
| 150 | 150 | ,@body) |
| 151 | 151 | ,(if (and tag-p (eq tag 'to-top)) |
| 152 | 152 | `(chaos-to-top) |
| 157 | 157 | ` (unless *chaos-quiet* |
| 158 | 158 | (let ((*standard-output* *error-output*) |
| 159 | 159 | (*print-indent* 4)) |
| 160 | (output-msg ',msg-id "~&[Warning]" ,args) | |
| 160 | (output-msg ',msg-id "~%[Warning]" ,args) | |
| 161 | 161 | ,@body) |
| 162 | 162 | (flush-all))) |
| 163 | 163 | |
| 164 | 164 | (defmacro with-output-panic-message-n ((msg-id args) &body body) |
| 165 | 165 | ` (progn |
| 166 | 166 | (let ((*standard-output* *error-output*)) |
| 167 | (output-msg ',msg-id "~&!! PANIC !!" ,args) | |
| 167 | (output-msg ',msg-id "~%[!! PANIC !!]" ,args) | |
| 168 | 168 | ,@body) |
| 169 | 169 | (chaos-to-top))) |
| 170 | 170 | |
| 172 | 172 | ` (unless *chaos-quiet* |
| 173 | 173 | (let ((*standard-output* ,stream) |
| 174 | 174 | (*print-indent* 3)) |
| 175 | (output-msg ',msg-id "~&-- " ,args) | |
| 175 | (output-msg ',msg-id "~%-- " ,args) | |
| 176 | 176 | ,@body) |
| 177 | 177 | (flush-all))) |
| 178 | 178 | |
| 180 | 180 | ` (unless *chaos-quiet* |
| 181 | 181 | (let ((*standard-output* ,stream) |
| 182 | 182 | (*print-indent* 2)) |
| 183 | (output-msg ',msg-id "~&" ,args) | |
| 183 | (output-msg ',msg-id "~%" ,args) | |
| 184 | 184 | ,@body) |
| 185 | 185 | (flush-all))) |
| 186 | 186 | |
| 191 | 191 | ;; (flush-all) |
| 192 | 192 | ;; (fresh-all) |
| 193 | 193 | (let ((*standard-output* *error-output*) |
| 194 | (*print-indent* 4)) | |
| 195 | (format t "~&[Error]: ") | |
| 196 | ,@body) | |
| 194 | (*print-indent* 4)) | |
| 195 | (format t "~%[Error]: ") | |
| 196 | ,@body) | |
| 197 | 197 | ,(if (eq tag 'to-top) |
| 198 | `(chaos-to-top) | |
| 199 | `(chaos-error ,tag) | |
| 198 | `(chaos-to-top) | |
| 199 | `(chaos-error ,tag) | |
| 200 | 200 | ))) |
| 201 | 201 | |
| 202 | 202 | (defmacro with-output-chaos-warning ((&optional (stream '*error-output*)) &body body) |
| 203 | 203 | ` (unless *chaos-quiet* |
| 204 | ;; (fresh-all) | |
| 205 | ;; (flush-all) | |
| 206 | (let ((*standard-output* ,stream) | |
| 207 | (*print-indent* 4)) | |
| 208 | (format t "~&[Warning]: ") | |
| 209 | ,@body) | |
| 204 | (let ((*standard-output* ,stream) | |
| 205 | (*print-indent* 4)) | |
| 206 | (format t "~%[Warning]: ") | |
| 207 | ,@body) | |
| 210 | 208 | (flush-all))) |
| 211 | 209 | |
| 212 | 210 | (defmacro with-output-panic-message ((&optional (stream '*error-output*)) &body body) |
| 214 | 212 | ;; (fresh-all) |
| 215 | 213 | ;; (flush-all) |
| 216 | 214 | (let ((*standard-output* ,stream)) |
| 217 | (print-next) | |
| 218 | (princ "!! PANIC !!: ") | |
| 219 | ,@body) | |
| 215 | (print-next) | |
| 216 | (princ "!! PANIC !!: ") | |
| 217 | ,@body) | |
| 220 | 218 | (chaos-to-top))) |
| 221 | 219 | |
| 222 | 220 | ;;; |
| 223 | 221 | (defmacro with-output-msg ((&optional (stream '*standard-output*)) &body body) |
| 222 | ` (unless *chaos-quiet* | |
| 223 | (let ((*standard-output* ,stream) | |
| 224 | (*print-indent* 3)) | |
| 225 | (format t "~%-- ") | |
| 226 | ,@body) | |
| 227 | (flush-all))) | |
| 228 | ||
| 229 | (defmacro with-output-simple-msg ((&optional (stream '*standard-output*)) &body body) | |
| 224 | 230 | ` (unless *chaos-quiet* |
| 225 | 231 | ;; (fresh-all) |
| 226 | 232 | ;; (flush-all) |
| 227 | 233 | (let ((*standard-output* ,stream) |
| 228 | (*print-indent* 3)) | |
| 229 | (format t "~&-- ") | |
| 230 | ,@body) | |
| 231 | (flush-all))) | |
| 232 | ||
| 233 | (defmacro with-output-simple-msg ((&optional (stream '*standard-output*)) &body body) | |
| 234 | ` (unless *chaos-quiet* | |
| 235 | ;; (fresh-all) | |
| 236 | ;; (flush-all) | |
| 237 | (let ((*standard-output* ,stream) | |
| 238 | (*print-indent* 2)) | |
| 239 | (format t "~&") | |
| 240 | ,@body) | |
| 234 | (*print-indent* 2)) | |
| 235 | (format t "~%") | |
| 236 | ,@body) | |
| 241 | 237 | (flush-all))) |
| 242 | 238 | |
| 243 | 239 | ;;; |
| 256 | 252 | (fresh-all) |
| 257 | 253 | (flush-all) |
| 258 | 254 | (with-output-panic-message () |
| 259 | (format t "in ~a : no current module is specified!" ',me) | |
| 260 | (force-output) | |
| 261 | (finish-output) | |
| 262 | (return-from ,me nil)))) | |
| 255 | (format t "in ~a : no current module is specified!" ',me) | |
| 256 | (force-output) | |
| 257 | (finish-output) | |
| 258 | (return-from ,me nil)))) | |
| 263 | 259 | |
| 264 | 260 | ;;; EOF |
| 0 | 0 | ;;;-*- Mode:Lisp; Syntax:Common-Lisp; Package:CHAOS -*- |
| 1 | 1 | ;;; |
| 2 | ;;; Copyright (c) 2000-2014, Toshimi Sawada. All rights reserved. | |
| 2 | ;;; Copyright (c) 2000-2015, Toshimi Sawada. All rights reserved. | |
| 3 | 3 | ;;; |
| 4 | 4 | ;;; Redistribution and use in source and binary forms, with or without |
| 5 | 5 | ;;; modification, are permitted provided that the following conditions |
| 27 | 27 | ;;; |
| 28 | 28 | (in-package :CHAOS) |
| 29 | 29 | #|============================================================================== |
| 30 | System: Chaos | |
| 31 | Module: comlib | |
| 32 | File: misc.lisp | |
| 30 | System: Chaos | |
| 31 | Module: comlib | |
| 32 | File: misc.lisp | |
| 33 | 33 | ==============================================================================|# |
| 34 | 34 | #-:chaos-debug |
| 35 | 35 | (declaim (optimize (speed 3) (safety 0) #-GCL (debug 0))) |
| 56 | 56 | |
| 57 | 57 | (defun make-keyword (name) |
| 58 | 58 | (declare (type (or symbol simple-string) name) |
| 59 | (values symbol)) | |
| 59 | (values symbol)) | |
| 60 | 60 | (if (stringp name) |
| 61 | 61 | (intern name *keyword-package*) |
| 62 | 62 | ;; name must be a symbol |
| 67 | 67 | ;;; the key it is returned. |
| 68 | 68 | |
| 69 | 69 | (defun extract-keyword (key arglist &optional (default nil) |
| 70 | &key (no-value nil)) | |
| 70 | &key (no-value nil)) | |
| 71 | 71 | (declare (type list arglist) |
| 72 | (type t default) | |
| 73 | (type keyword key) | |
| 74 | (values symbol) | |
| 75 | ) | |
| 72 | (type t default) | |
| 73 | (type keyword key) | |
| 74 | (values symbol) | |
| 75 | ) | |
| 76 | 76 | (let ((binding (member key arglist :test #'eql))) |
| 77 | 77 | (cond ((and (null binding) no-value) |
| 78 | no-value) | |
| 79 | ((cdr binding) | |
| 80 | (cadr binding)) | |
| 81 | (t | |
| 82 | default)))) | |
| 78 | no-value) | |
| 79 | ((cdr binding) | |
| 80 | (cadr binding)) | |
| 81 | (t | |
| 82 | default)))) | |
| 83 | 83 | |
| 84 | 84 | ;;; ***************** |
| 85 | 85 | ;;; OBJECT ALLOCATION____________________________________________________________ |
| 228 | 228 | (declare (type t x y)) |
| 229 | 229 | (typecase x |
| 230 | 230 | (integer (typecase y |
| 231 | (integer (if (< (the integer x) (the integer y)) | |
| 232 | :lt | |
| 233 | (if (< (the integer y) (the integer x)) | |
| 234 | :gt | |
| 235 | :eq))) | |
| 236 | (otherwise :lt))) | |
| 231 | (integer (if (< (the integer x) (the integer y)) | |
| 232 | :lt | |
| 233 | (if (< (the integer y) (the integer x)) | |
| 234 | :gt | |
| 235 | :eq))) | |
| 236 | (otherwise :lt))) | |
| 237 | 237 | (symbol (typecase y |
| 238 | (symbol (if (eq x y) | |
| 239 | :eq | |
| 240 | (if (string-lessp (string (the symbol x)) | |
| 241 | (string (the symbol y))) | |
| 242 | :lt | |
| 243 | :gt))) | |
| 244 | (integer :gt) | |
| 245 | (otherwise :lt))) | |
| 238 | (symbol (if (eq x y) | |
| 239 | :eq | |
| 240 | (if (string-lessp (string (the symbol x)) | |
| 241 | (string (the symbol y))) | |
| 242 | :lt | |
| 243 | :gt))) | |
| 244 | (integer :gt) | |
| 245 | (otherwise :lt))) | |
| 246 | 246 | (cons (typecase y |
| 247 | (cons (let ((comp-car (ob-compare (car x ) (car y)))) | |
| 248 | (if (eq :eq comp-car) | |
| 249 | (ob-compare (cdr x) (cdr y)) | |
| 250 | comp-car))) | |
| 251 | ((or symbol integer) :gt) | |
| 252 | (otherwise :lt))) | |
| 247 | (cons (let ((comp-car (ob-compare (car x ) (car y)))) | |
| 248 | (if (eq :eq comp-car) | |
| 249 | (ob-compare (cdr x) (cdr y)) | |
| 250 | comp-car))) | |
| 251 | ((or symbol integer) :gt) | |
| 252 | (otherwise :lt))) | |
| 253 | 253 | (number (typecase y |
| 254 | (number (if (< (the number x) (the number y)) | |
| 255 | :lt | |
| 256 | (if (< (the number y) (the number x)) | |
| 257 | :gt | |
| 258 | :eq))) | |
| 259 | ((or symbol integer cons) :gt) | |
| 260 | (otherwise :lt))) | |
| 254 | (number (if (< (the number x) (the number y)) | |
| 255 | :lt | |
| 256 | (if (< (the number y) (the number x)) | |
| 257 | :gt | |
| 258 | :eq))) | |
| 259 | ((or symbol integer cons) :gt) | |
| 260 | (otherwise :lt))) | |
| 261 | 261 | (character (typecase y |
| 262 | (character (if (char< (the character x) | |
| 263 | (the character y)) | |
| 264 | :lt | |
| 265 | (if (char< (the character y) | |
| 266 | (the character x)) | |
| 267 | :gt | |
| 268 | :eq))) | |
| 269 | ((or number cons symbol) :gt) | |
| 270 | (otherwise :lt))) | |
| 262 | (character (if (char< (the character x) | |
| 263 | (the character y)) | |
| 264 | :lt | |
| 265 | (if (char< (the character y) | |
| 266 | (the character x)) | |
| 267 | :gt | |
| 268 | :eq))) | |
| 269 | ((or number cons symbol) :gt) | |
| 270 | (otherwise :lt))) | |
| 271 | 271 | (string (typecase y |
| 272 | (string (if (string-lessp (the string x) (the string y)) | |
| 273 | :lt | |
| 274 | (if (string-lessp (the string y) (the string x)) | |
| 275 | :gt | |
| 276 | :eq))) | |
| 277 | ((or character number cons symbol) :gt) | |
| 278 | (otherwise :lt))) | |
| 272 | (string (if (string-lessp (the string x) (the string y)) | |
| 273 | :lt | |
| 274 | (if (string-lessp (the string y) (the string x)) | |
| 275 | :gt | |
| 276 | :eq))) | |
| 277 | ((or character number cons symbol) :gt) | |
| 278 | (otherwise :lt))) | |
| 279 | 279 | (sequence (typecase y |
| 280 | (sequence (let ((lenx (length (the sequence x))) | |
| 281 | (leny (length (the sequence y)))) | |
| 282 | (declare (type fixnum lenx leny)) | |
| 283 | (dotimes (i (min lenx leny) (ob-compare lenx leny)) | |
| 284 | (declare (type fixnum i)) | |
| 285 | (let ((xi (elt x i)) | |
| 286 | (yi (elt y i))) | |
| 287 | (let ((cmp (ob-compare xi yi))) | |
| 288 | (unless (eq :eq cmp) | |
| 289 | (return cmp))))) | |
| 290 | :eq)) | |
| 291 | (otherwise :gt))) | |
| 280 | (sequence (let ((lenx (length (the sequence x))) | |
| 281 | (leny (length (the sequence y)))) | |
| 282 | (declare (type fixnum lenx leny)) | |
| 283 | (dotimes (i (min lenx leny) (ob-compare lenx leny)) | |
| 284 | (declare (type fixnum i)) | |
| 285 | (let ((xi (elt x i)) | |
| 286 | (yi (elt y i))) | |
| 287 | (let ((cmp (ob-compare xi yi))) | |
| 288 | (unless (eq :eq cmp) | |
| 289 | (return cmp))))) | |
| 290 | :eq)) | |
| 291 | (otherwise :gt))) | |
| 292 | 292 | (otherwise :lt) |
| 293 | 293 | ;; (structure :lt) |
| 294 | 294 | ;; |
| 306 | 306 | ;;; |
| 307 | 307 | (defun topo-sort (lst pred) |
| 308 | 308 | (declare (type list lst) |
| 309 | (type (or symbol function) pred)) | |
| 310 | (let ((res lst)) ; save original list as final value | |
| 309 | (type (or symbol function) pred)) | |
| 310 | (let ((res lst)) ; save original list as final value | |
| 311 | 311 | ;; run through the positions of lst successively filling them in |
| 312 | 312 | (loop |
| 313 | 313 | (when (null lst) (return)) |
| 314 | 314 | ;; pos is location of val which is current minimal value |
| 315 | 315 | (let ((pos lst) (val (car lst)) (rest (cdr lst))) |
| 316 | 316 | ;; scan through remainder of list rest updating pos and val |
| 317 | (loop ; -- select minimal | |
| 318 | (when (null rest) (return)) | |
| 319 | (let ((valr (car rest))) | |
| 320 | (when (funcall pred valr val) | |
| 321 | (setq pos rest val valr))) ; have found new minimal value | |
| 322 | (setq rest (cdr rest))) ; loop -- select minimal | |
| 317 | (loop ; -- select minimal | |
| 318 | (when (null rest) (return)) | |
| 319 | (let ((valr (car rest))) | |
| 320 | (when (funcall pred valr val) | |
| 321 | (setq pos rest val valr))) ; have found new minimal value | |
| 322 | (setq rest (cdr rest))) ; loop -- select minimal | |
| 323 | 323 | ;; swap values at front of lst and at pos |
| 324 | 324 | (rplaca pos (car lst)) |
| 325 | 325 | (rplaca lst val)) |
| 376 | 376 | ;;; QUERY-INPUT_________________________________________________________________ |
| 377 | 377 | ;;; ************ |
| 378 | 378 | (defun query-input (&optional (default #\y) (timeout 20) |
| 379 | format-string &rest args) | |
| 379 | format-string &rest args) | |
| 380 | 380 | (clear-input *query-io*) |
| 381 | 381 | (when format-string |
| 382 | 382 | (fresh-line *query-io*) |
| 387 | 387 | (finish-output *query-io*)) |
| 388 | 388 | (let ((read-char (read-char-wait timeout *query-io*))) |
| 389 | 389 | (cond ((null read-char) (return-from query-input default)) |
| 390 | (t (unread-char read-char *query-io*) | |
| 391 | (read *query-io*))))) | |
| 390 | (t (unread-char read-char *query-io*) | |
| 391 | (read *query-io*))))) | |
| 392 | 392 | |
| 393 | 393 | ;;; ************* |
| 394 | 394 | ;;; Y-OR-N-P-WAIT________________________________________________________________ |
| 398 | 398 | (defun internal-real-time-in-seconds () |
| 399 | 399 | (declare (values float)) |
| 400 | 400 | (float (/ (get-internal-real-time) |
| 401 | internal-time-units-per-second))) | |
| 401 | internal-time-units-per-second))) | |
| 402 | 402 | |
| 403 | 403 | (defun read-char-wait (&optional (timeout 20) input-stream &aux char) |
| 404 | 404 | (do ((start (internal-real-time-in-seconds))) |
| 405 | 405 | ((or (setq char (read-char-no-hang input-stream nil)) ;(listen *query-io*) |
| 406 | (< (+ start timeout) (internal-real-time-in-seconds))) | |
| 406 | (< (+ start timeout) (internal-real-time-in-seconds))) | |
| 407 | 407 | char))) |
| 408 | 408 | |
| 409 | 409 | (defvar *use-timeouts* t |
| 422 | 422 | ;;; you enter any other characters. |
| 423 | 423 | |
| 424 | 424 | (defun y-or-n-p-wait (&optional (default #\y) (timeout 20) |
| 425 | format-string &rest args) | |
| 425 | format-string &rest args) | |
| 426 | 426 | (when *clear-input-before-query* (clear-input *query-io*)) |
| 427 | 427 | (when format-string |
| 428 | 428 | (fresh-line *query-io*) |
| 433 | 433 | (finish-output *query-io*)) |
| 434 | 434 | (loop |
| 435 | 435 | (let* ((read-char (if *use-timeouts* |
| 436 | (read-char-wait timeout *query-io*) | |
| 437 | (read-char *query-io*))) | |
| 438 | (char (or read-char default))) | |
| 436 | (read-char-wait timeout *query-io*) | |
| 437 | (read-char *query-io*))) | |
| 438 | (char (or read-char default))) | |
| 439 | 439 | ;; We need to ignore #\newline because otherwise the bugs in |
| 440 | 440 | ;; clear-input will cause y-or-n-p-wait to print the "Type ..." |
| 441 | 441 | ;; message every time... *sigh* |
| 443 | 443 | ;; clear-input is fixed. |
| 444 | 444 | (unless (find char '(#\tab #\newline #\return)) |
| 445 | 445 | (when (null read-char) |
| 446 | (format *query-io* "~@[~A~]" default) | |
| 447 | (finish-output *query-io*)) | |
| 446 | (format *query-io* "~@[~A~]" default) | |
| 447 | (finish-output *query-io*)) | |
| 448 | 448 | (cond ((null char) (return t)) |
| 449 | ((find char '(#\y #\Y #\space) :test #'char=) (return t)) | |
| 450 | ((find char '(#\n #\N) :test #'char=) (return nil)) | |
| 451 | (t | |
| 452 | (when *clear-input-before-query* (clear-input *query-io*)) | |
| 453 | (format *query-io* "~&Type \"y\" for yes or \"n\" for no. ") | |
| 454 | (when format-string | |
| 455 | (fresh-line *query-io*) | |
| 456 | (apply #'format *query-io* format-string args)) | |
| 457 | (finish-output *query-io*))))))) | |
| 449 | ((find char '(#\y #\Y #\space) :test #'char=) (return t)) | |
| 450 | ((find char '(#\n #\N) :test #'char=) (return nil)) | |
| 451 | (t | |
| 452 | (when *clear-input-before-query* (clear-input *query-io*)) | |
| 453 | (format *query-io* "~%Type \"y\" for yes or \"n\" for no. ") | |
| 454 | (when format-string | |
| 455 | (fresh-line *query-io*) | |
| 456 | (apply #'format *query-io* format-string args)) | |
| 457 | (finish-output *query-io*))))))) | |
| 458 | 458 | |
| 459 | 459 | ;;; ******** |
| 460 | 460 | ;;; MULTISET____________________________________________________________________ |
| 472 | 472 | ;;; a multiset itself is represented as a list of this pairs. |
| 473 | 473 | |
| 474 | 474 | (defstruct (multiset (:conc-name "MULTISET-") |
| 475 | (:constructor multiset-create (equal-fun elements)) | |
| 476 | (:copier nil)) | |
| 477 | (equal-fun #'eq :type function) ; predicate which determines the equality | |
| 478 | ; of the objects. | |
| 479 | (elements nil :type list)) ; list of pair (object . count). | |
| 475 | (:constructor multiset-create (equal-fun elements)) | |
| 476 | (:copier nil)) | |
| 477 | (equal-fun #'eq :type function) ; predicate which determines the equality | |
| 478 | ; of the objects. | |
| 479 | (elements nil :type list)) ; list of pair (object . count). | |
| 480 | 480 | |
| 481 | 481 | ;;; MULTISET-NEW |
| 482 | 482 | ;;; creates the new empty multiset- |
| 494 | 494 | (defmacro multiset-insert (ms e) |
| 495 | 495 | (once-only (ms) |
| 496 | 496 | `(let* ((elems (multiset-elements ,ms)) |
| 497 | (pair (assoc ,e elems :test (multiset-equal-fun ,ms)))) | |
| 497 | (pair (assoc ,e elems :test (multiset-equal-fun ,ms)))) | |
| 498 | 498 | (if pair |
| 499 | (incf (the fixnum (cdr pair))) | |
| 500 | (setf (multiset-elements ,ms) | |
| 501 | (push (cons e 1) elems)))))) | |
| 499 | (incf (the fixnum (cdr pair))) | |
| 500 | (setf (multiset-elements ,ms) | |
| 501 | (push (cons e 1) elems)))))) | |
| 502 | 502 | |
| 503 | 503 | ;;; LIST-TO-MULTISET list |
| 504 | 504 | ;;; returns a new multiset consisting of the elements in list. |
| 507 | 507 | ` (let ((ms (multiset-new ,equal-fun))) |
| 508 | 508 | (declare (type multiset ms)) |
| 509 | 509 | (dolist (e ,list) |
| 510 | (multiset-insert ms e)) | |
| 510 | (multiset-insert ms e)) | |
| 511 | 511 | ms)) |
| 512 | 512 | |
| 513 | 513 | ;;; MULTISET-TO-SET ms |
| 521 | 521 | (defmacro multiset-delete (ms e) |
| 522 | 522 | (once-only (ms) |
| 523 | 523 | `(let* ((elems (multiset-elements ,ms)) |
| 524 | (pair (assoc ,e elems :test (multiset-equal-fun ,ms)))) | |
| 524 | (pair (assoc ,e elems :test (multiset-equal-fun ,ms)))) | |
| 525 | 525 | (when pair |
| 526 | 526 | (when (zerop (decf (the fixnum (cdr pair)))) |
| 527 | (setf (multiset-elements ,ms) | |
| 528 | (delete e elems :test (multiset-equal-fun ,ms) :key #'car))))))) | |
| 527 | (setf (multiset-elements ,ms) | |
| 528 | (delete e elems :test (multiset-equal-fun ,ms) :key #'car))))))) | |
| 529 | 529 | |
| 530 | 530 | ;;; MULTISET-MERGE m1 m2 |
| 531 | 531 | ;;; inserts each elements of m2 into m1. leaves m2 unchanged. |
| 534 | 534 | (defmacro multiset-merge (m1 m2) |
| 535 | 535 | (once-only (m1) |
| 536 | 536 | `(let ((m1-elems (multiset-elements ,m1)) |
| 537 | (equal-fun (multiset-equal-fun ,m1))) | |
| 537 | (equal-fun (multiset-equal-fun ,m1))) | |
| 538 | 538 | (dolist (e2 (multiset-elements ,m2)) |
| 539 | (let ((pair (assoc (car e2) m1-elems :test equal-fun))) | |
| 540 | (if pair | |
| 541 | (incf (the fixnum (cdr m1-elems)) (the fixnum (cdr pair))) | |
| 542 | (push e2 m1-elems))))))) | |
| 539 | (let ((pair (assoc (car e2) m1-elems :test equal-fun))) | |
| 540 | (if pair | |
| 541 | (incf (the fixnum (cdr m1-elems)) (the fixnum (cdr pair))) | |
| 542 | (push e2 m1-elems))))))) | |
| 543 | 543 | |
| 544 | 544 | ;;; MULTISET-INTERSECTION m1 m2 |
| 545 | 545 | ;;; returns a new multiset with all elements that occur in both m1 and m2, |
| 549 | 549 | (defmacro multiset-intersectin (m1 m2) |
| 550 | 550 | (once-only (m1) |
| 551 | 551 | `(let ((m1-elems (multiset-elements ,m1)) |
| 552 | (equal-fun (multiset-equal-fun ,m1)) | |
| 553 | (new-elems nil)) | |
| 552 | (equal-fun (multiset-equal-fun ,m1)) | |
| 553 | (new-elems nil)) | |
| 554 | 554 | (dolist (e2 (multiset-elements ,m2)) |
| 555 | (let ((pair (assoc (car e2) m1-elems :test equal-fun))) | |
| 556 | (when pair | |
| 557 | (push (cons (car pair) (min (cdr pair) (cdr e2))) | |
| 558 | new-elems)))) | |
| 555 | (let ((pair (assoc (car e2) m1-elems :test equal-fun))) | |
| 556 | (when pair | |
| 557 | (push (cons (car pair) (min (cdr pair) (cdr e2))) | |
| 558 | new-elems)))) | |
| 559 | 559 | (multiset-create equal-fun new-elems)))) |
| 560 | 560 | |
| 561 | 561 | ;;; MULTISET-DIFF m1 m2 |
| 566 | 566 | (defmacro multiset-diff (m1 m2) |
| 567 | 567 | (once-only (m1) |
| 568 | 568 | `(let ((m1-elems (multiset-elements ,m1)) |
| 569 | (equal-fun (multiset-equal-fun ,m1)) | |
| 570 | (new-elems nil)) | |
| 569 | (equal-fun (multiset-equal-fun ,m1)) | |
| 570 | (new-elems nil)) | |
| 571 | 571 | (dolist (e2 (multiset-elements ,m2)) |
| 572 | (let ((pair (assoc (car e2) m1-elems :test equal-fun))) | |
| 573 | (if pair | |
| 574 | (let ((count (- (cdr pair) (cdr e2)))) | |
| 575 | (when (< 0 count) | |
| 576 | (push (cons (car pair) count) new-elems))) | |
| 577 | (push (cons (car par) (cdr pair)) new-elems)))) | |
| 572 | (let ((pair (assoc (car e2) m1-elems :test equal-fun))) | |
| 573 | (if pair | |
| 574 | (let ((count (- (cdr pair) (cdr e2)))) | |
| 575 | (when (< 0 count) | |
| 576 | (push (cons (car pair) count) new-elems))) | |
| 577 | (push (cons (car par) (cdr pair)) new-elems)))) | |
| 578 | 578 | (multiset-create equal-fun new-elems)))) |
| 579 | 579 | |
| 580 | 580 | ;;; MULTISET-COUNT m e |
| 584 | 584 | (once-only (m) |
| 585 | 585 | `(let ((pair (assoc ,e (multiset-elements ,m) :test (multiset-equal-fun ,m)))) |
| 586 | 586 | (if pair |
| 587 | (cdr pair) | |
| 588 | 0)))) | |
| 587 | (cdr pair) | |
| 588 | 0)))) | |
| 589 | 589 | |
| 590 | 590 | ;;; MULTISET-COPY m |
| 591 | 591 | ;;; returns a new multiset with the same contents and the same equality function as m. |
| 618 | 618 | ,@(let (code-result) |
| 619 | 619 | (dolist (pred (cdr predicates)) |
| 620 | 620 | (push `(cond |
| 621 | ((and (setq ,temp ,pred) | |
| 622 | ,result) | |
| 623 | (return-from ,block-name nil)) | |
| 624 | (,temp | |
| 625 | (setq ,result ,temp))) | |
| 621 | ((and (setq ,temp ,pred) | |
| 622 | ,result) | |
| 623 | (return-from ,block-name nil)) | |
| 624 | (,temp | |
| 625 | (setq ,result ,temp))) | |
| 626 | 626 | code-result)) |
| 627 | 627 | (nreverse code-result)) |
| 628 | 628 | ,result)))) |
| 639 | 639 | (push `(if (not ,pred) |
| 640 | 640 | (return-from ,block-name t)) |
| 641 | 641 | code-result)) |
| 642 | (nreverse code-result)) | |
| 642 | (nreverse code-result)) | |
| 643 | 643 | nil))) |
| 644 | 644 | |
| 645 | 645 | ;;; nor |
| 654 | 654 | (push `(if ,pred |
| 655 | 655 | (return-from ,block-name nil)) |
| 656 | 656 | code-result)) |
| 657 | (nreverse code-result)) | |
| 657 | (nreverse code-result)) | |
| 658 | 658 | t))) |
| 659 | 659 | |
| 660 | 660 | |
| 668 | 668 | (decode-universal-time universal-time 0) ; GMT time |
| 669 | 669 | (declare (type fixnum dow month)) |
| 670 | 670 | (format nil "~d ~a ~d ~a ~d:~2,'0d:~2,'0d GMT" |
| 671 | year | |
| 672 | (%svref '#(0 "Jan" "Feb" "Mar" "Apr" "May" | |
| 673 | "Jun" "Jul" "Aug" "Sep" "Oct" | |
| 674 | "Nov" "Dec") | |
| 675 | month) | |
| 676 | date | |
| 677 | (%svref '#("Mon" "Tue" "Wed" "Thu" "Fri" "Sat" "Sun") dow) | |
| 678 | hour min secs) | |
| 671 | year | |
| 672 | (%svref '#(0 "Jan" "Feb" "Mar" "Apr" "May" | |
| 673 | "Jun" "Jul" "Aug" "Sep" "Oct" | |
| 674 | "Nov" "Dec") | |
| 675 | month) | |
| 676 | date | |
| 677 | (%svref '#("Mon" "Tue" "Wed" "Thu" "Fri" "Sat" "Sun") dow) | |
| 678 | hour min secs) | |
| 679 | 679 | )) |
| 680 | 680 | |
| 681 | 681 | ;;; elapsed-time-in-seconds |
| 686 | 686 | |
| 687 | 687 | (defun elapsed-time-in-seconds (base now) |
| 688 | 688 | (declare (type integer base now) |
| 689 | (values single-float)) | |
| 689 | (values single-float)) | |
| 690 | 690 | (coerce (/ (- now base) |
| 691 | internal-time-units-per-second) | |
| 692 | 'single-float)) | |
| 691 | internal-time-units-per-second) | |
| 692 | 'single-float)) | |
| 693 | 693 | |
| 694 | 694 | (defun time-in-seconds (sum) |
| 695 | 695 | (declare (type integer sum) |
| 696 | (values single-float)) | |
| 696 | (values single-float)) | |
| 697 | 697 | (coerce (/ sum internal-time-units-per-second) 'single-float)) |
| 698 | 698 | |
| 699 | 699 | ;;; **** |
| 702 | 702 | |
| 703 | 703 | (defmacro every2len (fn l1 l2) |
| 704 | 704 | (let* ((lmbd (cadr fn)) |
| 705 | (args (cadr lmbd)) | |
| 706 | (bdy (cddr lmbd))) | |
| 705 | (args (cadr lmbd)) | |
| 706 | (bdy (cddr lmbd))) | |
| 707 | 707 | ` (let ((lst1 ,l1) (lst2 ,l2) ,@args) |
| 708 | (loop | |
| 709 | (when (null lst1) (return (null lst2))) | |
| 710 | (when (null lst2) (return (null lst1))) | |
| 711 | (setq ,(car args) (car lst1)) | |
| 712 | (setq ,(cadr args) (car lst2)) | |
| 713 | (unless (progn ,@bdy) (return nil)) | |
| 714 | (setq lst1 (cdr lst1)) | |
| 715 | (setq lst2 (cdr lst2)) | |
| 716 | ) | |
| 717 | ))) | |
| 708 | (loop | |
| 709 | (when (null lst1) (return (null lst2))) | |
| 710 | (when (null lst2) (return (null lst1))) | |
| 711 | (setq ,(car args) (car lst1)) | |
| 712 | (setq ,(cadr args) (car lst2)) | |
| 713 | (unless (progn ,@bdy) (return nil)) | |
| 714 | (setq lst1 (cdr lst1)) | |
| 715 | (setq lst2 (cdr lst2)) | |
| 716 | ) | |
| 717 | ))) | |
| 718 | 718 | |
| 719 | 719 | (defun list2array (list) |
| 720 | 720 | (declare (type list list) |
| 721 | #-GCL (values simple-vector) | |
| 722 | ) | |
| 721 | #-GCL (values simple-vector) | |
| 722 | ) | |
| 723 | 723 | #-GCL |
| 724 | 724 | (make-array (length list) :initial-contents list) |
| 725 | 725 | #+GCL |
| 731 | 731 | |
| 732 | 732 | (defun make-list-1-n (n) |
| 733 | 733 | (declare (type fixnum n) |
| 734 | (values list)) | |
| 734 | (values list)) | |
| 735 | 735 | (let ((result nil)) |
| 736 | 736 | (dotimes-fixnum (x n) |
| 737 | 737 | (push (+ x 1) result)) |
| 739 | 739 | |
| 740 | 740 | (defun make-list-1-n-0 (n) |
| 741 | 741 | (declare (type fixnum n) |
| 742 | (values list)) | |
| 742 | (values list)) | |
| 743 | 743 | (let ((result nil)) |
| 744 | 744 | (dotimes-fixnum (x n) |
| 745 | 745 | (push (+ x 1) result)) |
| 758 | 758 | (defmacro delete-entry-from-assoc-table (table key &optional (test '#'equal)) |
| 759 | 759 | ` (let ((entry (assoc ,key ,table :test ,test))) |
| 760 | 760 | (when entry |
| 761 | (setq ,table (delete entry ,table :test #'eq))))) | |
| 761 | (setq ,table (delete entry ,table :test #'eq))))) | |
| 762 | 762 | |
| 763 | 763 | (defmacro delete-object-from-assoc-table (table object &optional (test '#'eq)) |
| 764 | 764 | ` (let ((entry (rassoc ,object ,table :test ,test))) |
| 765 | 765 | (when entry |
| 766 | (setq ,table (delete entry ,table :test #'eq))))) | |
| 766 | (setq ,table (delete entry ,table :test #'eq))))) | |
| 767 | 767 | |
| 768 | 768 | (defmacro add-to-assoc-table (table key value &optional (test '#'equal)) |
| 769 | 769 | (once-only (table key value) |
| 770 | 770 | ` (let ((entry (get-entry-in-assoc-table ,table ,key ,test))) |
| 771 | (if entry | |
| 772 | (setf (cdr entry) ,value) | |
| 773 | (prog1 | |
| 774 | ,value | |
| 775 | (push (cons ,key ,value) ,table)))))) | |
| 771 | (if entry | |
| 772 | (setf (cdr entry) ,value) | |
| 773 | (prog1 | |
| 774 | ,value | |
| 775 | (push (cons ,key ,value) ,table)))))) | |
| 776 | 776 | |
| 777 | 777 | (defmacro object-is-in-assoc-table? (table object &optional (test '#'eq)) |
| 778 | 778 | `(rassoc ,object ,table :test ,test)) |
| 851 | 851 | 1<<20, 1<<21, 1<<22, 1<<23, 1<<24, 1<<25, 1<<26, 1<<27, 1<<28, 1<<29, |
| 852 | 852 | 1<<30, 1<<31, |
| 853 | 853 | };" |
| 854 | ) | |
| 854 | ) | |
| 855 | 855 | |
| 856 | 856 | #+gcl |
| 857 | 857 | (Clines "static object expt2 (a) object a; |
| 861 | 861 | return (make_fixnum(bit_vector[x])); |
| 862 | 862 | } else { FEerror(\"aho\");} |
| 863 | 863 | }" |
| 864 | ) | |
| 864 | ) | |
| 865 | 865 | |
| 866 | 866 | #+gcl |
| 867 | 867 | (defentry expt2 (object)(object expt2)) |
| 0 | 0 | ;;;-*- Mode:LISP; Package:CHAOS; Base:10; Syntax:Common-lisp -*- |
| 1 | 1 | ;;; |
| 2 | ;;; Copyright (c) 2000-2014, Toshimi Sawada. All rights reserved. | |
| 2 | ;;; Copyright (c) 2000-2015, Toshimi Sawada. All rights reserved. | |
| 3 | 3 | ;;; |
| 4 | 4 | ;;; Redistribution and use in source and binary forms, with or without |
| 5 | 5 | ;;; modification, are permitted provided that the following conditions |
| 27 | 27 | ;;; |
| 28 | 28 | ;;; (in-package :chaos) |
| 29 | 29 | #|============================================================================== |
| 30 | System: CHAOS | |
| 31 | Module: comlib | |
| 32 | File: message.lisp | |
| 30 | System: CHAOS | |
| 31 | Module: comlib | |
| 32 | File: message.lisp | |
| 33 | 33 | ==============================================================================|# |
| 34 | 34 | #-:chaos-debug |
| 35 | 35 | (declaim (optimize (speed 3) (safety 0) #-GCL (debug 0))) |
| 70 | 70 | ` (progn |
| 71 | 71 | (let ((*standard-output* *error-output*) |
| 72 | 72 | (*print-indent* 4)) |
| 73 | (output-msg :error ',msg-id "~&[Error]:" ,args) | |
| 73 | (output-msg :error ',msg-id "~%[Error]:" ,args) | |
| 74 | 74 | ,@body) |
| 75 | 75 | ,(if (and tag-p (eq tag 'to-top)) |
| 76 | 76 | `(chaos-to-top) |
| 0 | 0 | ;;;-*- Mode:LISP; Package:CHAOS; Base:10; Syntax:Common-lisp -*- |
| 1 | 1 | ;;; |
| 2 | ;;; Copyright (c) 2000-2014, Toshimi Sawada. All rights reserved. | |
| 2 | ;;; Copyright (c) 2000-2015, Toshimi Sawada. All rights reserved. | |
| 3 | 3 | ;;; |
| 4 | 4 | ;;; Redistribution and use in source and binary forms, with or without |
| 5 | 5 | ;;; modification, are permitted provided that the following conditions |
| 27 | 27 | ;;; |
| 28 | 28 | (in-package :chaos) |
| 29 | 29 | #|============================================================================== |
| 30 | System: CHAOS | |
| 31 | Module: comlib | |
| 32 | File: print-utils.lisp | |
| 30 | System: CHAOS | |
| 31 | Module: comlib | |
| 32 | File: print-utils.lisp | |
| 33 | 33 | =============================================================================|# |
| 34 | 34 | #-:chaos-debug |
| 35 | 35 | (declaim (optimize (speed 3) (safety 0) #-GCL (debug 0))) |
| 69 | 69 | (declare (values fixnum)) |
| 70 | 70 | (let ((val (lisp::charpos x))) |
| 71 | 71 | (if val val |
| 72 | 0))) | |
| 72 | 0))) | |
| 73 | 73 | |
| 74 | 74 | #+EXCL |
| 75 | 75 | (defun filecol (x) |
| 102 | 102 | |
| 103 | 103 | (defun file-column (strm) |
| 104 | 104 | (declare (inline filecol) |
| 105 | (values fixnum)) | |
| 105 | (values fixnum)) | |
| 106 | 106 | (filecol strm)) |
| 107 | 107 | |
| 108 | 108 | ;;; print-check |
| 114 | 114 | (declare (type fixnum indent fwd)) |
| 115 | 115 | (if (<= *print-line-limit* (+ (file-column stream) fwd)) |
| 116 | 116 | (progn |
| 117 | (terpri stream) | |
| 118 | (when (>= (1+ indent) *print-line-limit*) | |
| 119 | (setq indent 0) | |
| 120 | (setq .file-col. (* *print-indent* *print-indent-increment*))) | |
| 121 | (if (= 0 indent) | |
| 122 | (dotimes (i (* *print-indent* *print-indent-increment*)) | |
| 123 | (princ #\space stream)) | |
| 124 | (dotimes (i indent) | |
| 125 | (princ #\space stream))) | |
| 126 | t) | |
| 117 | (terpri stream) | |
| 118 | (when (>= (1+ indent) *print-line-limit*) | |
| 119 | (setq indent 0) | |
| 120 | (setq .file-col. (* *print-indent* *print-indent-increment*))) | |
| 121 | (if (= 0 indent) | |
| 122 | (dotimes (i (* *print-indent* *print-indent-increment*)) | |
| 123 | (princ #\space stream)) | |
| 124 | (dotimes (i indent) | |
| 125 | (princ #\space stream))) | |
| 126 | t) | |
| 127 | 127 | nil)) |
| 128 | 128 | ||# |
| 129 | 129 | |
| 131 | 131 | (declare (type fixnum indent fwd)) |
| 132 | 132 | (if (<= *print-line-limit* (+ (file-column stream) fwd)) |
| 133 | 133 | (progn |
| 134 | (print-next) | |
| 135 | (when (>= (1+ indent) *print-line-limit*) | |
| 136 | (setq .file-col. (* *print-indent* *print-indent-increment*))) | |
| 137 | #|| | |
| 138 | (dotimes (i indent) | |
| 139 | (princ #\space stream)) | |
| 140 | ||# | |
| 141 | t) | |
| 134 | (print-next) | |
| 135 | (when (>= (1+ indent) *print-line-limit*) | |
| 136 | (setq .file-col. (* *print-indent* *print-indent-increment*))) | |
| 137 | #|| | |
| 138 | (dotimes (i indent) | |
| 139 | (princ #\space stream)) | |
| 140 | ||# | |
| 141 | t) | |
| 142 | 142 | nil)) |
| 143 | 143 | |
| 144 | 144 | ;;; print-indent |
| 164 | 164 | (princ string stream) |
| 165 | 165 | (unless (equal fill-char " ") |
| 166 | 166 | (dotimes (x fill-col) |
| 167 | (declare (type fixnum x)) | |
| 168 | (princ fill-char stream)) | |
| 167 | (declare (type fixnum x)) | |
| 168 | (princ fill-char stream)) | |
| 169 | 169 | ))) |
| 170 | 170 | ||# |
| 171 | 171 | |
| 180 | 180 | (princ string stream) |
| 181 | 181 | (unless (equal fill-char " ") |
| 182 | 182 | (dotimes (x fill-col) |
| 183 | (declare (type fixnum x)) | |
| 184 | (princ fill-char stream)) | |
| 183 | (declare (type fixnum x)) | |
| 184 | (princ fill-char stream)) | |
| 185 | 185 | ))) |
| 186 | 186 | |
| 187 | 187 | ;;; print-to-right |
| 189 | 189 | ;;; |
| 190 | 190 | (defun print-to-right (string &optional (fill-char " ") (stream *standard-output*)) |
| 191 | 191 | (declare (type simple-string string) |
| 192 | (type (or character simple-string) fill-char) | |
| 193 | (type stream stream)) | |
| 192 | (type (or character simple-string) fill-char) | |
| 193 | (type stream stream)) | |
| 194 | 194 | (dotimes (x (- .terminal-width. 1 (filecol stream) |
| 195 | *print-indent* (length string))) | |
| 195 | *print-indent* (length string))) | |
| 196 | 196 | (declare (type fixnum x)) |
| 197 | 197 | (princ fill-char stream)) |
| 198 | 198 | (princ " " stream) |
| 203 | 203 | ;;; |
| 204 | 204 | (defun print-to-left (string &optional (fill-char nil) (stream *standard-output*)) |
| 205 | 205 | (declare (type simple-string string) |
| 206 | (type (or null character simple-string) fill-char) | |
| 207 | (type stream stream)) | |
| 206 | (type (or null character simple-string) fill-char) | |
| 207 | (type stream stream)) | |
| 208 | 208 | (let ((*print-line-limit* .terminal-width.)) |
| 209 | 209 | (princ string stream) |
| 210 | 210 | (princ " " stream) |
| 211 | 211 | (if fill-char |
| 212 | (dotimes (x (- *print-line-limit* 1 *print-indent* | |
| 213 | (filecol stream) (length string))) | |
| 214 | (declare (type fixnum x)) | |
| 215 | (princ fill-char stream))))) | |
| 212 | (dotimes (x (- *print-line-limit* 1 *print-indent* | |
| 213 | (filecol stream) (length string))) | |
| 214 | (declare (type fixnum x)) | |
| 215 | (princ fill-char stream))))) | |
| 216 | 216 | |
| 217 | 217 | ;;; print-next |
| 218 | 218 | ;;; print new-line iff the current column is not at the beggining of line |
| 220 | 220 | ;;; |
| 221 | 221 | (defun print-next (&optional (prefix nil) (n *print-indent*) (stream *standard-output*)) |
| 222 | 222 | (declare (type fixnum n) |
| 223 | (type stream stream)) | |
| 224 | (if (fresh-line stream) | |
| 225 | (print-indent #\space n stream)) | |
| 223 | (type stream stream)) | |
| 224 | #+SBCL | |
| 225 | (progn (terpri stream) (print-indent #\space n stream)) | |
| 226 | #-SBCL | |
| 227 | (when (fresh-line stream) | |
| 228 | (print-indent #\space n stream)) | |
| 226 | 229 | (when prefix (princ prefix stream))) |
| 227 | 230 | |
| 228 | 231 | (defun print-next-prefix (prefix-char &optional (prefix nil) (n *print-indent*) (stream *standard-output*)) |
| 229 | 232 | (declare (type fixnum n) |
| 230 | (type stream stream) | |
| 231 | (type character prefix-char)) | |
| 233 | (type stream stream) | |
| 234 | (type character prefix-char)) | |
| 232 | 235 | (when (fresh-line stream) |
| 233 | 236 | (print-indent prefix-char n stream)) |
| 234 | 237 | (when prefix (princ prefix stream))) |
| 238 | 241 | (defun print-simple (x &optional (stream *standard-output*)) |
| 239 | 242 | (declare (type stream stream)) |
| 240 | 243 | (cond ((atom x) (prin1 x stream)) |
| 241 | (t (let ((flag nil) (tail x)) | |
| 242 | (princ "(" stream) | |
| 243 | (loop (when (not (consp tail)) (return)) | |
| 244 | (if flag | |
| 245 | (princ " " stream) | |
| 246 | (setq flag t)) | |
| 247 | (print-simple (car tail) stream) | |
| 248 | (setq tail (cdr tail))) | |
| 249 | (when tail | |
| 250 | (princ " . " stream) | |
| 251 | (prin1 tail stream)) | |
| 252 | (princ ")" stream) | |
| 253 | )))) | |
| 244 | (t (let ((flag nil) (tail x)) | |
| 245 | (princ "(" stream) | |
| 246 | (loop (when (not (consp tail)) (return)) | |
| 247 | (if flag | |
| 248 | (princ " " stream) | |
| 249 | (setq flag t)) | |
| 250 | (print-simple (car tail) stream) | |
| 251 | (setq tail (cdr tail))) | |
| 252 | (when tail | |
| 253 | (princ " . " stream) | |
| 254 | (prin1 tail stream)) | |
| 255 | (princ ")" stream) | |
| 256 | )))) | |
| 254 | 257 | |
| 255 | 258 | ;;; print-simple-princ |
| 256 | 259 | ;;; |
| 258 | 261 | (declare (type stream stream)) |
| 259 | 262 | (let ((.file-col. .file-col.)) |
| 260 | 263 | (cond ((atom x) (princ x stream)) |
| 261 | (t (let ((flag nil) | |
| 262 | (tail x)) | |
| 263 | (princ "(" stream) | |
| 264 | (setq .file-col. (1+ (file-column stream))) | |
| 265 | (loop (when (not (consp tail)) (return)) | |
| 266 | (if flag | |
| 267 | (princ " " stream) | |
| 268 | (setq flag t)) | |
| 269 | (print-simple-princ (car tail) stream) | |
| 270 | (setq tail (cdr tail))) | |
| 271 | (when tail | |
| 272 | (princ " . " stream) | |
| 273 | (prin1 tail stream)) | |
| 274 | (princ ")" stream))) | |
| 275 | ))) | |
| 264 | (t (let ((flag nil) | |
| 265 | (tail x)) | |
| 266 | (princ "(" stream) | |
| 267 | (setq .file-col. (1+ (file-column stream))) | |
| 268 | (loop (when (not (consp tail)) (return)) | |
| 269 | (if flag | |
| 270 | (princ " " stream) | |
| 271 | (setq flag t)) | |
| 272 | (print-simple-princ (car tail) stream) | |
| 273 | (setq tail (cdr tail))) | |
| 274 | (when tail | |
| 275 | (princ " . " stream) | |
| 276 | (prin1 tail stream)) | |
| 277 | (princ ")" stream))) | |
| 278 | ))) | |
| 276 | 279 | |
| 277 | 280 | ;;; print-simple-princ-open |
| 278 | 281 | ;;; |
| 281 | 284 | (let ((.file-col. .file-col.)) |
| 282 | 285 | (print-check .file-col. 0 stream) |
| 283 | 286 | (cond ((atom x) (princ x stream)) |
| 284 | (t (let ((flag nil) | |
| 285 | (tail x)) | |
| 286 | (loop (when (not (consp tail)) (return)) | |
| 287 | (if flag | |
| 288 | (princ #\space stream) | |
| 289 | (setq flag t)) | |
| 290 | (print-simple-princ (car tail) stream) | |
| 291 | (setq tail (cdr tail)) | |
| 292 | ) | |
| 293 | (when tail | |
| 294 | (princ " ... " stream) | |
| 295 | (prin1 tail stream))))) | |
| 287 | (t (let ((flag nil) | |
| 288 | (tail x)) | |
| 289 | (loop (when (not (consp tail)) (return)) | |
| 290 | (if flag | |
| 291 | (princ #\space stream) | |
| 292 | (setq flag t)) | |
| 293 | (print-simple-princ (car tail) stream) | |
| 294 | (setq tail (cdr tail)) | |
| 295 | ) | |
| 296 | (when tail | |
| 297 | (princ " ... " stream) | |
| 298 | (prin1 tail stream))))) | |
| 296 | 299 | )) |
| 297 | 300 | |
| 298 | 301 | ;;; EOF |
| 0 | 0 | ;;;-*- Mode:Lisp; Syntax:Common-Lisp; Package:CHAOS -*- |
| 1 | 1 | ;;; |
| 2 | ;;; Copyright (c) 2000-2014, Toshimi Sawada. All rights reserved. | |
| 2 | ;;; Copyright (c) 2000-2015, Toshimi Sawada. All rights reserved. | |
| 3 | 3 | ;;; |
| 4 | 4 | ;;; Redistribution and use in source and binary forms, with or without |
| 5 | 5 | ;;; modification, are permitted provided that the following conditions |
| 27 | 27 | ;;; |
| 28 | 28 | (in-package :CHAOS) |
| 29 | 29 | #|============================================================================== |
| 30 | System: Chaos | |
| 31 | Module: comlib | |
| 32 | File: process.lisp | |
| 30 | System: Chaos | |
| 31 | Module: comlib | |
| 32 | File: process.lisp | |
| 33 | 33 | ==============================================================================|# |
| 34 | 34 | #-:chaos-debug |
| 35 | 35 | (declaim (optimize (speed 3) (safety 0) #-GCL (debug 0))) |
| 49 | 49 | |
| 50 | 50 | (Clines " |
| 51 | 51 | #undef PAGESIZE |
| 52 | #include <errno.h> /* errno global, error codes for UNIX IO */ | |
| 53 | #include <sys/types.h> /* Data types definitions */ | |
| 54 | #include <sys/socket.h> /* Socket definitions with out this forget it */ | |
| 55 | #include <netinet/in.h> /* Internet address definition AF_INET etc... */ | |
| 56 | #include <signal.h> /* UNIX Signal codes */ | |
| 57 | #include <sys/ioctl.h> /* IO control standard UNIx fair */ | |
| 52 | #include <errno.h> /* errno global, error codes for UNIX IO */ | |
| 53 | #include <sys/types.h> /* Data types definitions */ | |
| 54 | #include <sys/socket.h> /* Socket definitions with out this forget it */ | |
| 55 | #include <netinet/in.h> /* Internet address definition AF_INET etc... */ | |
| 56 | #include <signal.h> /* UNIX Signal codes */ | |
| 57 | #include <sys/ioctl.h> /* IO control standard UNIx fair */ | |
| 58 | 58 | #include <sys/file.h> |
| 59 | #include <fcntl.h> /* Function to set socket aync/interrupt */ | |
| 60 | #include <sys/time.h> /* Time for select time out */ | |
| 61 | #include <netdb.h> /* Data Base interface for network files */ | |
| 59 | #include <fcntl.h> /* Function to set socket aync/interrupt */ | |
| 60 | #include <sys/time.h> /* Time for select time out */ | |
| 61 | #include <netdb.h> /* Data Base interface for network files */ | |
| 62 | 62 | /* patch by ishisone@sra.co.jp */ |
| 63 | #include <sys/wait.h> /* Wait system call options */ | |
| 63 | #include <sys/wait.h> /* Wait system call options */ | |
| 64 | 64 | /* patch end */ |
| 65 | 65 | #include <stdio.h> |
| 66 | 66 | |
| 67 | 67 | static char *lisp_to_string(string) |
| 68 | 68 | object string; |
| 69 | 69 | { |
| 70 | int i, len; | |
| 71 | char *sself; | |
| 72 | char *cstr; | |
| 73 | ||
| 74 | len = string->st.st_fillp; | |
| 75 | ||
| 76 | cstr = (char *) malloc (len+1); | |
| 77 | sself = &(string->st.st_self[0]); | |
| 78 | for (i=0; i<len; i++) | |
| 79 | { | |
| 80 | cstr[i] = sself[i]; | |
| 81 | } | |
| 82 | cstr[i] = 0; | |
| 83 | return (cstr); | |
| 70 | int i, len; | |
| 71 | char *sself; | |
| 72 | char *cstr; | |
| 73 | ||
| 74 | len = string->st.st_fillp; | |
| 75 | ||
| 76 | cstr = (char *) malloc (len+1); | |
| 77 | sself = &(string->st.st_self[0]); | |
| 78 | for (i=0; i<len; i++) | |
| 79 | { | |
| 80 | cstr[i] = sself[i]; | |
| 81 | } | |
| 82 | cstr[i] = 0; | |
| 83 | return (cstr); | |
| 84 | 84 | } |
| 85 | 85 | |
| 86 | 86 | /* |
| 149 | 149 | if (fork() == 0) |
| 150 | 150 | { /* the child --- replace standard in and out with descriptors given */ |
| 151 | 151 | /* patch by ishisone@sra.co.jp */ |
| 152 | setsid(); /* in order to get rid of job control */ | |
| 153 | fclose(istream->sm.sm_fp); /* close parent-side file desc. */ | |
| 154 | fclose(ostream->sm.sm_fp); /* ditto */ | |
| 152 | setsid(); /* in order to get rid of job control */ | |
| 153 | fclose(istream->sm.sm_fp); /* close parent-side file desc. */ | |
| 154 | fclose(ostream->sm.sm_fp); /* ditto */ | |
| 155 | 155 | /* end patch */ |
| 156 | 156 | close(0); |
| 157 | 157 | dup(fdin); |
| 158 | 158 | close(1); |
| 159 | 159 | dup(fdout); |
| 160 | 160 | if (execvp(pname, argv) == -1) |
| 161 | { | |
| 162 | fprintf(stderr, \"\\n***** Error in process spawning *******\"); | |
| 163 | fflush(stderr); | |
| 164 | exit(1); | |
| 165 | } | |
| 161 | { | |
| 162 | fprintf(stderr, \"\\n***** Error in process spawning *******\"); | |
| 163 | fflush(stderr); | |
| 164 | exit(1); | |
| 165 | } | |
| 166 | 166 | } |
| 167 | 167 | /* patch by ishisone@sra.co.jp */ |
| 168 | 168 | else |
| 169 | 169 | { /* the parent */ |
| 170 | close(fdin); /* close child-side file descriptor */ | |
| 171 | close(fdout); /* ditto */ | |
| 170 | close(fdin); /* close child-side file descriptor */ | |
| 171 | close(fdout); /* ditto */ | |
| 172 | 172 | } |
| 173 | 173 | /* end patch */ |
| 174 | 174 | } |
| 216 | 216 | |
| 217 | 217 | stream = make_pipe(); |
| 218 | 218 | spawn_child(stream->sm.sm_object1, |
| 219 | stream->sm.sm_object0, | |
| 220 | filename, argv); | |
| 219 | stream->sm.sm_object0, | |
| 220 | filename, argv); | |
| 221 | 221 | return(stream); |
| 222 | 222 | |
| 223 | 223 | } |
| 239 | 239 | (defun run-process (program &optional args) |
| 240 | 240 | (let ((stream (run-child program args))) |
| 241 | 241 | (make-process :name program |
| 242 | :in-stream (si::fp-input-stream stream) | |
| 243 | :out-stream (si::fp-output-stream stream)))) | |
| 242 | :in-stream (si::fp-input-stream stream) | |
| 243 | :out-stream (si::fp-output-stream stream)))) | |
| 244 | 244 | |
| 245 | 245 | (defmacro with-write-to-process ((process) &body body) |
| 246 | 246 | ` (let ((*standard-output* (process-out-stream ,process))) |
| 0 | 0 | ;;;-*- Mode:LISP; Package:CHAOS; Base:10; Syntax:Common-lisp -*- |
| 1 | 1 | ;;; |
| 2 | ;;; Copyright (c) 2000-2014, Toshimi Sawada. All rights reserved. | |
| 2 | ;;; Copyright (c) 2000-2015, Toshimi Sawada. All rights reserved. | |
| 3 | 3 | ;;; |
| 4 | 4 | ;;; Redistribution and use in source and binary forms, with or without |
| 5 | 5 | ;;; modification, are permitted provided that the following conditions |
| 27 | 27 | ;;; |
| 28 | 28 | (in-package :chaos) |
| 29 | 29 | #|============================================================================== |
| 30 | System:Chaos | |
| 31 | Module:comlib | |
| 32 | File: reader.lisp | |
| 30 | System:Chaos | |
| 31 | Module:comlib | |
| 32 | File: reader.lisp | |
| 33 | 33 | ==============================================================================|# |
| 34 | 34 | #-:chaos-debug |
| 35 | 35 | (declaim (optimize (speed 3) (safety 0) #-GCL (debug 0))) |
| 36 | 36 | #+:chaos-debug |
| 37 | 37 | (declaim (optimize (speed 1) (safety 3) #-GCL (debug 3))) |
| 38 | 38 | |
| 39 | ;;; SCHEMA BASED Genral Reader. | |
| 39 | ;;; SCHEMA BASED Genral Reader. | |
| 40 | 40 | ;;; |
| 41 | 41 | ;;; BASED ON OBJ3 READER ROUTINES. |
| 42 | 42 | ;;; ;;;; Copyright 1988,1991 SRI International. |
| 95 | 95 | ;;; |
| 96 | 96 | (defun reader (name schms) |
| 97 | 97 | (declare (type symbol name) |
| 98 | (type list schms) | |
| 99 | (values t)) | |
| 98 | (type list schms) | |
| 99 | (values t)) | |
| 100 | 100 | (let ((*reader-schema-env* schms)) |
| 101 | 101 | (!lex-read-init) |
| 102 | 102 | (read-named name *reader-void* nil) |
| 114 | 114 | (princ "file: ") |
| 115 | 115 | (princ (namestring *chaos-input-source*))) |
| 116 | 116 | (when (and *reader-current-schema* |
| 117 | (general-read-is-simple-schema *reader-current-schema*)) | |
| 117 | (general-read-is-simple-schema *reader-current-schema*)) | |
| 118 | 118 | (print-next) |
| 119 | 119 | (princ "expecting: ") |
| 120 | 120 | (let ((*print-indent-contin* t)) |
| 121 | ;; (break) | |
| 122 | ;; (general-read-print-schema *reader-current-schema*) | |
| 123 | (general-read-display-schema *reader-current-schema*))) | |
| 121 | ;; (break) | |
| 122 | ;; (general-read-print-schema *reader-current-schema*) | |
| 123 | (general-read-display-schema *reader-current-schema* :short))) | |
| 124 | 124 | (when *reader-starting-position* |
| 125 | 125 | (print-next) |
| 126 | 126 | (princ "starting character position was: ") |
| 140 | 140 | (defun string-match (x y) |
| 141 | 141 | (declare (values (or null t))) |
| 142 | 142 | (cond ((stringp x) |
| 143 | (string= (the simple-string x) | |
| 144 | (if (stringp y) | |
| 145 | (the simple-string y) | |
| 146 | (the simple-string | |
| 147 | (string-downcase (string y)))))) | |
| 148 | ((characterp x) | |
| 149 | (eql (the character x) (the character y))) | |
| 150 | (t (eq x y)))) | |
| 143 | (string= (the simple-string x) | |
| 144 | (if (stringp y) | |
| 145 | (the simple-string y) | |
| 146 | (the simple-string | |
| 147 | (string-downcase (string y)))))) | |
| 148 | ((characterp x) | |
| 149 | (eql (the character x) (the character y))) | |
| 150 | (t (eq x y)))) | |
| 151 | 151 | |
| 152 | 152 | ;;; GENERAL-READ-STRING-MATCHES : token pattern -> Bool |
| 153 | 153 | ;;; used to match tokens against "patterns" which should be |
| 158 | 158 | (declare (values (or null t))) |
| 159 | 159 | (and (atom x) |
| 160 | 160 | (if (atom y) (string-match x y) |
| 161 | (or (and (eq ':pred (car y)) (funcall (cadr y) x)) | |
| 162 | (if (eq ':+ (car y)) | |
| 163 | (member x (cdr y) :test #'string-match) | |
| 164 | (member x y :test #'string-match)))))) | |
| 161 | (or (and (eq ':pred (car y)) (funcall (cadr y) x)) | |
| 162 | (if (eq ':+ (car y)) | |
| 163 | (member x (cdr y) :test #'string-match) | |
| 164 | (member x y :test #'string-match)))))) | |
| 165 | 165 | |
| 166 | 166 | ;;; GENERAL-READ-NUMBERP token -> Bool |
| 167 | 167 | ;;; is a token an integer? |
| 168 | 168 | ;;; |
| 169 | 169 | (defun general-read-numberp (str) |
| 170 | 170 | (declare (type simple-string str) |
| 171 | (values (or null t))) | |
| 171 | (values (or null t))) | |
| 172 | 172 | (let ((p 0) |
| 173 | (len (length str))) | |
| 173 | (len (length str))) | |
| 174 | 174 | (declare (type fixnum p len)) |
| 175 | 175 | (when (member (char str p) '(#\+ #\-)) |
| 176 | 176 | (incf p) |
| 177 | 177 | (when (= 1 len) (return-from general-read-numberp nil))) |
| 178 | 178 | (loop |
| 179 | (when (= len p) (return t)) | |
| 180 | (when (not (digit-char-p (char str p))) (return nil)) | |
| 179 | (when (= len p) (return t)) | |
| 180 | (when (not (digit-char-p (char str p))) (return nil)) | |
| 181 | 181 | (incf p) |
| 182 | 182 | ))) |
| 183 | 183 | |
| 189 | 189 | |
| 190 | 190 | (defun general-read (schema context &optional (allow-other nil)) |
| 191 | 191 | (declare (type list schema context) |
| 192 | (type (or null t) allow-other) | |
| 193 | (values t)) | |
| 192 | (type (or null t) allow-other) | |
| 193 | (values t)) | |
| 194 | 194 | ;; |
| 195 | 195 | (let ((*reader-current-schema* schema) |
| 196 | (*reader-current-context* context) | |
| 197 | (*reader-starting-position* | |
| 196 | (*reader-current-context* context) | |
| 197 | (*reader-starting-position* | |
| 198 | 198 | (if (at-top-level) nil (file-position *standard-input*))) |
| 199 | (result nil)) | |
| 199 | (result nil)) | |
| 200 | 200 | (setq result |
| 201 | 201 | (catch :aborting-read |
| 202 | (cond ((null schema) nil) | |
| 203 | (t (let ((elt (car schema)) | |
| 204 | (rest (cdr schema))) | |
| 205 | (let ((restcontext (if rest rest context))) | |
| 206 | (cond | |
| 207 | ((symbolp elt) | |
| 208 | (case elt | |
| 209 | (:unread (read-continue (unread-token) | |
| 210 | rest context)) | |
| 211 | (:optional (read-optional rest context)) | |
| 212 | (:if-present (read-if-present rest context)) | |
| 213 | (:one-of (read-one-of rest context)) | |
| 214 | (:one-of-default (read-one-of-default rest context)) | |
| 215 | (:many-of ;like one-of but with repetitions | |
| 216 | (read-many-of rest context)) | |
| 217 | (:seq-of (read-seq-of rest context)) | |
| 218 | (:symbol (read-continue (!read-sym) rest context)) | |
| 219 | (:symbols (read-continue (read-seq-of '(:symbol) | |
| 220 | restcontext) | |
| 221 | rest context)) | |
| 222 | (:int (let ((val (!read-sym))) | |
| 223 | (cond | |
| 224 | ((general-read-numberp val) | |
| 225 | (read-continue val rest context)) | |
| 226 | (t (with-output-chaos-error ('reader-error) | |
| 227 | (princ "was expecting an integer not ") | |
| 228 | (princ val) | |
| 229 | (print-next) | |
| 230 | (general-read-show-context) | |
| 231 | (clear-input) | |
| 232 | ))))) | |
| 233 | (:top-term (read-continue (read-term-at-top restcontext) | |
| 234 | rest context)) | |
| 235 | (:term (read-continue (read-term restcontext) | |
| 236 | rest context)) | |
| 237 | ;; (:term-to (read-continue (read-term-to restcontext) | |
| 238 | ;; rest context)) | |
| 239 | (:top-opname (read-continue (read-opname-at-top restcontext) | |
| 240 | rest context)) | |
| 241 | (:opname (read-continue (read-opname restcontext) | |
| 242 | rest context)) | |
| 243 | (:sort (read-continue (read-sort restcontext) | |
| 244 | rest context)) | |
| 245 | (:sorts (read-continue (read-sorts restcontext) | |
| 246 | rest context)) | |
| 247 | (:chars (read-continue (read-chars restcontext) | |
| 248 | rest context)) | |
| 249 | (:optattr (read-continue (read-opattr restcontext) | |
| 250 | rest context)) | |
| 251 | (:comment (read-continue (read-comment-line) rest context)) | |
| 252 | (:commentlong | |
| 253 | (read-continue (general-read-commentlong) rest context)) | |
| 254 | (:+ (read-any-one rest)) | |
| 255 | (:! ; use named description | |
| 256 | (read-named (car rest) context)) | |
| 257 | (:call (eval (car rest))) | |
| 258 | (:append | |
| 259 | (let* ((rr (cdr rest)) | |
| 260 | (rc (if rr rr context))) | |
| 261 | (read-continue-append | |
| 262 | (general-read (car rest) rc) rr context))) | |
| 263 | (:rdr | |
| 264 | (let ((cur (!set-single-reader (car rest)))) | |
| 265 | (prog1 (general-read (cdr rest) context) | |
| 266 | (!set-reader cur)))) | |
| 267 | (:modexp | |
| 268 | (read-continue | |
| 269 | (read-module-exp (car restcontext)) rest context)) | |
| 270 | (:super | |
| 271 | (read-continue | |
| 272 | (read-super-exp (car restcontext)) rest context)) | |
| 273 | (:chaos-item | |
| 274 | (!read-discard) | |
| 275 | (let ((val (lex-read))) | |
| 276 | (let ((a (if (null (cdr val)) (car val) val))) | |
| 277 | (read-continue a rest context)))) | |
| 278 | (:args | |
| 279 | (read-args rest context)) | |
| 280 | (otherwise | |
| 281 | (if allow-other | |
| 282 | ;; we read input as a seq-of term | |
| 283 | (general-read '(:seq-of :term) '(void)) | |
| 284 | (progn | |
| 285 | (!read-in) | |
| 286 | (cond | |
| 287 | ((string-match *reader-input* elt) | |
| 288 | (let ((inp *reader-input*)) | |
| 289 | (!read-discard) | |
| 290 | (read-continue inp rest context))) | |
| 291 | (t (with-output-chaos-error ('reader-error) | |
| 292 | (princ "was expecting the symbol ") | |
| 293 | (princ "`") | |
| 294 | (princ elt) | |
| 295 | (if (or (equal *reader-input* *lex-eof*) | |
| 296 | (equal *reader-input* control-d-string)) | |
| 297 | (format t "', premature end of input.") | |
| 298 | (format t "' not `~a'." *reader-input*)) | |
| 299 | (print-next) | |
| 300 | (general-read-show-context) | |
| 301 | (clear-input) | |
| 302 | )))))) | |
| 303 | )) | |
| 304 | ((member (car elt) '(:! :rdr)) | |
| 305 | (let ((val (general-read elt restcontext))) | |
| 306 | (cond ((eq *reader-void* val) | |
| 307 | (general-read rest context)) | |
| 308 | (t (append val | |
| 309 | (general-read rest context)))))) | |
| 310 | ((eq :upto (car elt)) | |
| 311 | (append (general-read (cddr elt) (list (cadr elt))) | |
| 312 | (general-read rest context))) | |
| 313 | (t | |
| 314 | (read-continue (general-read elt restcontext) rest context) | |
| 315 | )))))) | |
| 316 | )) | |
| 202 | (cond ((null schema) nil) | |
| 203 | (t (let ((elt (car schema)) | |
| 204 | (rest (cdr schema))) | |
| 205 | (let ((restcontext (if rest rest context))) | |
| 206 | (cond | |
| 207 | ((symbolp elt) | |
| 208 | (case elt | |
| 209 | (:unread (read-continue (unread-token) | |
| 210 | rest context)) | |
| 211 | (:optional (read-optional rest context)) | |
| 212 | (:if-present (read-if-present rest context)) | |
| 213 | (:one-of (read-one-of rest context)) | |
| 214 | (:one-of-default (read-one-of-default rest context)) | |
| 215 | (:many-of ;like one-of but with repetitions | |
| 216 | (read-many-of rest context)) | |
| 217 | (:seq-of (read-seq-of rest context)) | |
| 218 | (:symbol (read-continue (!read-sym) rest context)) | |
| 219 | (:symbols (read-continue (read-seq-of '(:symbol) | |
| 220 | restcontext) | |
| 221 | rest context)) | |
| 222 | (:int (let ((val (!read-sym))) | |
| 223 | (cond | |
| 224 | ((general-read-numberp val) | |
| 225 | (read-continue val rest context)) | |
| 226 | (t (with-output-chaos-error ('reader-error) | |
| 227 | (princ "was expecting an integer not ") | |
| 228 | (princ val) | |
| 229 | (print-next) | |
| 230 | (general-read-show-context) | |
| 231 | (clear-input) | |
| 232 | ))))) | |
| 233 | (:top-term (read-continue (read-term-at-top restcontext) | |
| 234 | rest context)) | |
| 235 | (:term (read-continue (read-term restcontext) | |
| 236 | rest context)) | |
| 237 | ;; (:term-to (read-continue (read-term-to restcontext) | |
| 238 | ;; rest context)) | |
| 239 | (:top-opname (read-continue (read-opname-at-top restcontext) | |
| 240 | rest context)) | |
| 241 | (:opname (read-continue (read-opname restcontext) | |
| 242 | rest context)) | |
| 243 | (:sort (read-continue (read-sort restcontext) | |
| 244 | rest context)) | |
| 245 | (:sorts (read-continue (read-sorts restcontext) | |
| 246 | rest context)) | |
| 247 | (:chars (read-continue (read-chars restcontext) | |
| 248 | rest context)) | |
| 249 | (:optattr (read-continue (read-opattr restcontext) | |
| 250 | rest context)) | |
| 251 | (:comment (read-continue (read-comment-line) rest context)) | |
| 252 | (:commentlong | |
| 253 | (read-continue (general-read-commentlong) rest context)) | |
| 254 | (:+ (read-any-one rest)) | |
| 255 | (:! ; use named description | |
| 256 | (read-named (car rest) context)) | |
| 257 | (:call (eval (car rest))) | |
| 258 | (:append | |
| 259 | (let* ((rr (cdr rest)) | |
| 260 | (rc (if rr rr context))) | |
| 261 | (read-continue-append | |
| 262 | (general-read (car rest) rc) rr context))) | |
| 263 | (:rdr | |
| 264 | (let ((cur (!set-single-reader (car rest)))) | |
| 265 | (prog1 (general-read (cdr rest) context) | |
| 266 | (!set-reader cur)))) | |
| 267 | (:modexp | |
| 268 | (read-continue | |
| 269 | (read-module-exp (car restcontext)) rest context)) | |
| 270 | (:super | |
| 271 | (read-continue | |
| 272 | (read-super-exp (car restcontext)) rest context)) | |
| 273 | (:chaos-item | |
| 274 | (!read-discard) | |
| 275 | (let ((val (lex-read))) | |
| 276 | (let ((a (if (null (cdr val)) (car val) val))) | |
| 277 | (read-continue a rest context)))) | |
| 278 | (:args | |
| 279 | (read-args rest context)) | |
| 280 | (otherwise | |
| 281 | (if allow-other | |
| 282 | ;; we read input as a seq-of term | |
| 283 | (general-read '(:seq-of :term) '(void)) | |
| 284 | (progn | |
| 285 | (!read-in) | |
| 286 | (cond | |
| 287 | ((string-match *reader-input* elt) | |
| 288 | (let ((inp *reader-input*)) | |
| 289 | (!read-discard) | |
| 290 | (read-continue inp rest context))) | |
| 291 | (t (with-output-chaos-error ('reader-error) | |
| 292 | (princ "was expecting the symbol ") | |
| 293 | (princ "`") | |
| 294 | (princ elt) | |
| 295 | (if (or (equal *reader-input* *lex-eof*) | |
| 296 | (equal *reader-input* control-d-string)) | |
| 297 | (format t "', premature end of input.") | |
| 298 | (format t "' not `~a'." *reader-input*)) | |
| 299 | (print-next) | |
| 300 | (general-read-show-context) | |
| 301 | (clear-input) | |
| 302 | )))))) | |
| 303 | )) | |
| 304 | ((member (car elt) '(:! :rdr)) | |
| 305 | (let ((val (general-read elt restcontext))) | |
| 306 | (cond ((eq *reader-void* val) | |
| 307 | (general-read rest context)) | |
| 308 | (t (append val | |
| 309 | (general-read rest context)))))) | |
| 310 | ((eq :upto (car elt)) | |
| 311 | (append (general-read (cddr elt) (list (cadr elt))) | |
| 312 | (general-read rest context))) | |
| 313 | (t | |
| 314 | (read-continue (general-read elt restcontext) rest context) | |
| 315 | )))))) | |
| 316 | )) | |
| 317 | 317 | (if (eq :aborting-read result) |
| 318 | (general-read-abort) | |
| 318 | (general-read-abort) | |
| 319 | 319 | result) |
| 320 | 320 | )) |
| 321 | 321 | |
| 326 | 326 | ;;; |
| 327 | 327 | (defun read-named (name context &optional allow-other) |
| 328 | 328 | (declare (type symbol name) |
| 329 | (type list context) | |
| 330 | (type (or null t) allow-other)) | |
| 329 | (type list context) | |
| 330 | (type (or null t) allow-other)) | |
| 331 | 331 | (let ((val (assoc name *reader-schema-env* :test #'eq))) |
| 332 | 332 | (cond (val (general-read (cadr val) context allow-other)) |
| 333 | (t (error "Undefined name in general reader ~a" name))))) | |
| 333 | (t (error "Undefined name in general reader ~a" name))))) | |
| 334 | 334 | |
| 335 | 335 | ;;; READ-OPTIONAL |
| 336 | 336 | ;;; |
| 339 | 339 | (when (at-eof-or-control-d) |
| 340 | 340 | (general-read-eof-error)) |
| 341 | 341 | (cond ((general-read-string-matches *reader-input* (car c)) |
| 342 | *reader-void*) | |
| 343 | (t (general-read s c))) | |
| 342 | *reader-void*) | |
| 343 | (t (general-read s c))) | |
| 344 | 344 | ) |
| 345 | 345 | |
| 346 | 346 | ;;; READ-IF-PRESENT |
| 347 | 347 | ;;; |
| 348 | 348 | (defun read-if-present (s c) |
| 349 | 349 | (declare (type list s c) |
| 350 | (values t)) | |
| 350 | (values t)) | |
| 351 | 351 | (!read-in) |
| 352 | 352 | (when (at-eof-or-control-d) |
| 353 | 353 | (general-read-eof-error)) |
| 354 | 354 | (cond ((general-read-string-matches *reader-input* (car s)) |
| 355 | (general-read s c)) | |
| 356 | (t *reader-void*))) | |
| 355 | (general-read s c)) | |
| 356 | (t *reader-void*))) | |
| 357 | 357 | |
| 358 | 358 | ;;; READ-ONE-OF |
| 359 | 359 | ;;; |
| 360 | 360 | (defun read-one-of (s c) |
| 361 | 361 | (declare (type list s c) |
| 362 | (values t)) | |
| 362 | (values t)) | |
| 363 | 363 | (let ((inp (!read-sym))) |
| 364 | 364 | (when (and c (at-eof-or-control-d)) |
| 365 | 365 | (general-read-eof-error)) |
| 366 | 366 | (let ((val (assoc inp s :test #'general-read-string-matches))) |
| 367 | 367 | (cond (val (cons inp (general-read (cdr val) c))) |
| 368 | ((and (consp inp) | |
| 369 | (eq (caar inp) '|String|)) | |
| 370 | (read-one-of s c)) | |
| 371 | ((and (eq *lex-eof* inp) | |
| 368 | ((and (consp inp) | |
| 369 | (eq (caar inp) '|String|)) | |
| 370 | (read-one-of s c)) | |
| 371 | ((and (eq *lex-eof* inp) | |
| 372 | 372 | (assoc 'eof s)) |
| 373 | (cons 'eof (general-read (cdr (assoc 'eof s)) c))) | |
| 374 | ((eq *lex-eof* inp) (general-read-eof-error)) | |
| 375 | (*allow-general-term-input* | |
| 376 | (unread-token) | |
| 377 | (read-term '(|.|))) | |
| 378 | (t (let ((top-level (assoc 'eof s))) | |
| 379 | (when (equal inp ".") | |
| 380 | (chaos-error 'reader-error)) | |
| 381 | (with-output-chaos-error ('reader-error) | |
| 382 | (princ "expecting one of followings:") | |
| 383 | (print-next) | |
| 384 | (let ((*print-indent-contin* t)) | |
| 385 | (general-read-print-schema (mapcar #'car s))) | |
| 386 | (print-next) | |
| 387 | (princ "* NOT: ") | |
| 388 | (princ inp) | |
| 389 | (general-read-show-context) | |
| 390 | (when top-level | |
| 391 | (setq *chaos-print-errors* nil)) | |
| 392 | (clear-input) | |
| 393 | ))) | |
| 394 | )))) | |
| 373 | (cons 'eof (general-read (cdr (assoc 'eof s)) c))) | |
| 374 | ((eq *lex-eof* inp) (general-read-eof-error)) | |
| 375 | (*allow-general-term-input* | |
| 376 | (unread-token) | |
| 377 | (read-term '(|.|))) | |
| 378 | (t (let ((top-level (assoc 'eof s))) | |
| 379 | (when (equal inp ".") | |
| 380 | (chaos-error 'reader-error)) | |
| 381 | (with-output-chaos-error ('reader-error) | |
| 382 | (princ "expecting one of followings:") | |
| 383 | (print-next) | |
| 384 | (let ((*print-indent-contin* t)) | |
| 385 | (general-read-print-schema (mapcar #'car s) :short)) | |
| 386 | (print-next) | |
| 387 | (princ "* NOT: ") | |
| 388 | (princ inp) | |
| 389 | (general-read-show-context) | |
| 390 | (when top-level | |
| 391 | (setq *chaos-print-errors* nil)) | |
| 392 | (clear-input) | |
| 393 | ))) | |
| 394 | )))) | |
| 395 | 395 | |
| 396 | 396 | |
| 397 | 397 | ;;; READ-ONE-OF-DEFAULT |
| 399 | 399 | ;;; |
| 400 | 400 | (defun read-one-of-default (s c) |
| 401 | 401 | (declare (type list s c) |
| 402 | (values t)) | |
| 402 | (values t)) | |
| 403 | 403 | (!read-in) |
| 404 | 404 | (let ((val (assoc *reader-input* (cdr s) |
| 405 | :test #'general-read-string-matches))) | |
| 405 | :test #'general-read-string-matches))) | |
| 406 | 406 | (cond (val (let ((inp *reader-input*)) |
| 407 | (!read-discard) | |
| 408 | (cons inp (general-read (cdr val) c)))) | |
| 409 | ((and (reader-is-at-eof) (assoc 'eof s)) | |
| 410 | (cons 'eof (general-read (cdr (assoc 'eof s)) c))) | |
| 411 | ((reader-is-at-eof) ; !!! | |
| 412 | (general-read-eof-error)) | |
| 413 | (t (general-read (car s) c))))) | |
| 407 | (!read-discard) | |
| 408 | (cons inp (general-read (cdr val) c)))) | |
| 409 | ((and (reader-is-at-eof) (assoc 'eof s)) | |
| 410 | (cons 'eof (general-read (cdr (assoc 'eof s)) c))) | |
| 411 | ((reader-is-at-eof) ; !!! | |
| 412 | (general-read-eof-error)) | |
| 413 | (t (general-read (car s) c))))) | |
| 414 | 414 | |
| 415 | 415 | ;;; READ-MANY-OF |
| 416 | 416 | ;;; |
| 417 | 417 | (defun read-many-of (s c) |
| 418 | 418 | (declare (type list s c) |
| 419 | (values t)) | |
| 419 | (values t)) | |
| 420 | 420 | (let ((res nil) (close (car c))) |
| 421 | 421 | (loop (!read-in) |
| 422 | (when (at-eof-or-control-d) | |
| 423 | (general-read-eof-error)) | |
| 424 | (when (general-read-string-matches *reader-input* close) | |
| 425 | (return (if (null res) | |
| 426 | *reader-void* | |
| 427 | (nreverse res)))) | |
| 428 | (if (and (consp *reader-input*) | |
| 429 | (eq (caar *reader-input*) '|String|)) | |
| 430 | (setq *reader-input* *reader-void*) | |
| 431 | (setq res (cons (read-one-of s c) res)))))) | |
| 422 | (when (at-eof-or-control-d) | |
| 423 | (general-read-eof-error)) | |
| 424 | (when (general-read-string-matches *reader-input* close) | |
| 425 | (return (if (null res) | |
| 426 | *reader-void* | |
| 427 | (nreverse res)))) | |
| 428 | (if (and (consp *reader-input*) | |
| 429 | (eq (caar *reader-input*) '|String|)) | |
| 430 | (setq *reader-input* *reader-void*) | |
| 431 | (setq res (cons (read-one-of s c) res)))))) | |
| 432 | 432 | |
| 433 | 433 | ;;; READ-SEQ-OF |
| 434 | 434 | ;;; |
| 435 | 435 | (defun read-seq-of (s c) |
| 436 | 436 | (declare (type list s c) |
| 437 | (values t)) | |
| 437 | (values t)) | |
| 438 | 438 | (cond ((equal '(:term) s) (read-seq-of-term c)) |
| 439 | ((equal '(:opname) s) (read-seq-of-opname c)) | |
| 440 | ((equal '(:top-term) s) (read-seq-of-term-at-top c)) | |
| 441 | ((equal '(:top-opname) s) (read-seq-of-opname-at-top c)) | |
| 442 | (t (let ((res nil) (close (car c))) | |
| 443 | (loop | |
| 444 | (!read-in) | |
| 445 | (when (at-eof-or-control-d) | |
| 446 | (general-read-eof-error)) | |
| 447 | (when (general-read-string-matches *reader-input* close) | |
| 448 | (return (if (null res) *reader-void* res))) | |
| 449 | (setq res (append res (general-read s c))) | |
| 450 | ))))) | |
| 439 | ((equal '(:opname) s) (read-seq-of-opname c)) | |
| 440 | ((equal '(:top-term) s) (read-seq-of-term-at-top c)) | |
| 441 | ((equal '(:top-opname) s) (read-seq-of-opname-at-top c)) | |
| 442 | (t (let ((res nil) (close (car c))) | |
| 443 | (loop | |
| 444 | (!read-in) | |
| 445 | (when (at-eof-or-control-d) | |
| 446 | (general-read-eof-error)) | |
| 447 | (when (general-read-string-matches *reader-input* close) | |
| 448 | (return (if (null res) *reader-void* res))) | |
| 449 | (setq res (append res (general-read s c))) | |
| 450 | ))))) | |
| 451 | 451 | |
| 452 | 452 | ;;; READ-ANY-ONE |
| 453 | 453 | ;;; |
| 454 | 454 | (defun read-any-one (s) |
| 455 | 455 | (declare (type list s) |
| 456 | (values t)) | |
| 456 | (values t)) | |
| 457 | 457 | (!read-in) |
| 458 | 458 | (cond ((member *reader-input* s :test #'string-match) |
| 459 | (!read-sym)) | |
| 460 | ((at-eof-or-control-d) (general-read-eof-error)) | |
| 461 | (t (with-output-chaos-error ('reader-error) | |
| 462 | (princ "expecting one of") | |
| 463 | (print-next) | |
| 464 | (let ((*print-indent-contin* t)) | |
| 465 | (general-read-print-schema s)) | |
| 466 | (print-next) | |
| 467 | (format t "NOT ") | |
| 468 | (princ *reader-input*) | |
| 469 | (general-read-show-context) | |
| 470 | (clear-input) | |
| 471 | )))) | |
| 459 | (!read-sym)) | |
| 460 | ((at-eof-or-control-d) (general-read-eof-error)) | |
| 461 | (t (with-output-chaos-error ('reader-error) | |
| 462 | (princ "expecting one of") | |
| 463 | (print-next) | |
| 464 | (let ((*print-indent-contin* t)) | |
| 465 | (general-read-print-schema s :short)) | |
| 466 | (print-next) | |
| 467 | (format t "NOT ") | |
| 468 | (princ *reader-input*) | |
| 469 | (general-read-show-context) | |
| 470 | (clear-input) | |
| 471 | )))) | |
| 472 | 472 | |
| 473 | 473 | ;;; READ-CONTINUE : {*standard-input*} value schema context -> |
| 474 | 474 | ;;; {*standard-input*} parse-tree |
| 477 | 477 | ;;; |
| 478 | 478 | (defun read-continue (v s c) |
| 479 | 479 | (declare (type t v) |
| 480 | (type list s c) | |
| 481 | (values t)) | |
| 480 | (type list s c) | |
| 481 | (values t)) | |
| 482 | 482 | (cond ((eq *reader-void* v) (general-read s c)) |
| 483 | ((equal v control-d-string) (general-read-eof-error)) | |
| 484 | (t (cons v (general-read s c))))) | |
| 483 | ((equal v control-d-string) (general-read-eof-error)) | |
| 484 | (t (cons v (general-read s c))))) | |
| 485 | 485 | |
| 486 | 486 | ;;; READ-CONTINUE-APPEND : {*standard-input*} value schema context -> |
| 487 | 487 | ;;; {*standard-input*} parse-tree |
| 490 | 490 | ;;; |
| 491 | 491 | (defun read-continue-append (v s c) |
| 492 | 492 | (declare (type t v) |
| 493 | (type list s c) | |
| 494 | (values t)) | |
| 493 | (type list s c) | |
| 494 | (values t)) | |
| 495 | 495 | (cond ((eq *reader-void* v) (general-read s c)) |
| 496 | ((equal v control-d-string) (general-read-eof-error)) | |
| 497 | (t (append v (general-read s c))))) | |
| 496 | ((equal v control-d-string) (general-read-eof-error)) | |
| 497 | (t (append v (general-read s c))))) | |
| 498 | 498 | |
| 499 | 499 | (defun general-read-show-context () |
| 500 | 500 | (declare (values t)) |
| 501 | 501 | (when (and *chaos-verbose* |
| 502 | *reader-current-context* | |
| 503 | (not (eq *reader-void* *reader-current-context*))) | |
| 502 | *reader-current-context* | |
| 503 | (not (eq *reader-void* *reader-current-context*))) | |
| 504 | 504 | (terpri) |
| 505 | 505 | (princ "-- Expecting context is: ") |
| 506 | 506 | (print-simple-princ-open *reader-current-context*) |
| 507 | 507 | (unless *chaos-input-source* (terpri))) |
| 508 | (when *chaos-input-source* ; nil means may be from terminal | |
| 508 | (when *chaos-input-source* ; nil means may be from terminal | |
| 509 | 509 | (terpri) |
| 510 | 510 | (princ "-- file: ") (princ (namestring *chaos-input-source*)) |
| 511 | 511 | (when (file-position *standard-input*) |
| 513 | 513 | (prin1 (file-position *standard-input*))) |
| 514 | 514 | (terpri) |
| 515 | 515 | (when (and *reader-current-schema* |
| 516 | (general-read-is-simple-schema *reader-current-schema*)) | |
| 516 | (general-read-is-simple-schema *reader-current-schema*)) | |
| 517 | 517 | (princ " expecting: ") |
| 518 | (general-read-print-schema-1 *reader-current-schema*) | |
| 518 | (general-read-print-schema-1 *reader-current-schema* :short) | |
| 519 | 519 | (terpri)) |
| 520 | 520 | (when (and *reader-starting-position* |
| 521 | (not (equal *reader-starting-position* | |
| 522 | (file-position *standard-input*)))) | |
| 521 | (not (equal *reader-starting-position* | |
| 522 | (file-position *standard-input*)))) | |
| 523 | 523 | (princ " starting character position was: ") |
| 524 | 524 | (prin1 *reader-starting-position*) |
| 525 | 525 | (terpri)) |
| 527 | 527 | (unless (eq *reader-void* *reader-input*) |
| 528 | 528 | (princ *reader-input*)) |
| 529 | 529 | (if (reader-is-at-eof) |
| 530 | (princ " ... at end of file") | |
| 531 | (dotimes (i 20) | |
| 532 | (print-check) | |
| 533 | (princ #\space) | |
| 534 | (let ((val (read-sym))) | |
| 535 | (when (at-eof) | |
| 536 | (princ " [end of file]") | |
| 537 | (return)) | |
| 538 | (princ val) | |
| 539 | (when (equal "eof" val) (return))))) | |
| 530 | (princ " ... at end of file") | |
| 531 | (dotimes (i 20) | |
| 532 | (print-check) | |
| 533 | (princ #\space) | |
| 534 | (let ((val (read-sym))) | |
| 535 | (when (at-eof) | |
| 536 | (princ " [end of file]") | |
| 537 | (return)) | |
| 538 | (princ val) | |
| 539 | (when (equal "eof" val) (return))))) | |
| 540 | 540 | (terpri))) |
| 541 | 541 | |
| 542 | 542 | #|| |
| 543 | 543 | (defun general-read-is-simple-schema (sch) |
| 544 | 544 | (declare (type t sch) |
| 545 | (values (or null t))) | |
| 545 | (values (or null t))) | |
| 546 | 546 | (or (atom sch) |
| 547 | 547 | (and (consp sch) |
| 548 | (every #'atom sch))) | |
| 548 | (every #'atom sch))) | |
| 549 | 549 | ) |
| 550 | 550 | ||# |
| 551 | 551 | |
| 556 | 556 | ;;; modify print to certain depth and length transliterating notations |
| 557 | 557 | ;;; |
| 558 | 558 | |
| 559 | (defun general-read-display-schema (sch) | |
| 559 | (defun general-read-display-schema (sch &optional (short nil)) | |
| 560 | 560 | (declare (type list sch) |
| 561 | (values t)) | |
| 562 | (if (> (length sch) 1) | |
| 561 | (values t)) | |
| 562 | (let ((limit (if short 10 most-positive-fixnum)) | |
| 563 | (count 0) | |
| 564 | (*print-level* (if short 2 nil))) | |
| 565 | (declare (type fixnum limit count)) | |
| 566 | (if (> (length sch) 1) | |
| 563 | 567 | (dolist (i (firstn sch 3)) |
| 564 | (print-check) | |
| 565 | (princ #\space) | |
| 566 | (prin1 i)) | |
| 568 | (when (>= count limit) (princ " ...") (return)) | |
| 569 | (incf count) | |
| 570 | (print-check) | |
| 571 | (princ #\space) | |
| 572 | (prin1 i)) | |
| 567 | 573 | (dolist (i sch) |
| 568 | 574 | (print-check) |
| 569 | 575 | (princ #\space) |
| 570 | (prin1 i)) | |
| 571 | )) | |
| 572 | ||
| 573 | (defun general-read-print-schema-1 (s) | |
| 576 | (prin1 i))))) | |
| 577 | ||
| 578 | (defun general-read-print-schema-1 (s &optional (short nil)) | |
| 574 | 579 | (declare (type t s) |
| 575 | (values t)) | |
| 580 | (values t)) | |
| 576 | 581 | (if (atom s) |
| 577 | 582 | (princ s) |
| 578 | 583 | (let ((flag nil)) |
| 579 | 584 | (declare (ignore flag)) |
| 580 | (general-read-print-schema (car s))))) | |
| 581 | ||
| 582 | (defun general-read-print-schema (s) | |
| 585 | (general-read-print-schema (car s) short)))) | |
| 586 | ||
| 587 | (defun general-read-print-schema (s &optional (short nil)) | |
| 583 | 588 | (declare (type t s) |
| 584 | (values t)) | |
| 585 | (if (atom s) | |
| 586 | (princ s) | |
| 589 | (values t)) | |
| 590 | (let ((limit (if short 10 most-positive-fixnum)) | |
| 591 | (count 0)) | |
| 592 | (declare (type fixnum limit count)) | |
| 593 | (if (atom s) | |
| 594 | (princ s) | |
| 587 | 595 | (let ((flag nil)) |
| 588 | (dolist (i s) | |
| 589 | (if (< *print-line-limit* (filecol *standard-output*)) | |
| 590 | (progn | |
| 591 | (print-next) | |
| 592 | (when *print-indent-contin* | |
| 593 | (princ " ") | |
| 594 | (setq flag t))) | |
| 595 | (if flag (princ " ") (setq flag t))) | |
| 596 | (if (atom i) | |
| 597 | (unless (eql control-d i) | |
| 598 | (prin1 i)) | |
| 599 | (if (eq ':+ (car i)) | |
| 600 | (dolist (e (cdr i)) | |
| 601 | (if (< *print-line-limit* (filecol *standard-output*)) | |
| 602 | (progn | |
| 603 | (print-next) | |
| 604 | (when *print-indent-contin* | |
| 605 | (princ " ") | |
| 606 | (setq flag t))) | |
| 607 | (if flag (princ " ") (setq flag t))) | |
| 608 | (prin1 e)) | |
| 609 | (prin1 i) | |
| 610 | )) | |
| 611 | )))) | |
| 596 | (dolist (i s) | |
| 597 | (when (>= count limit) (princ " ...") (return)) | |
| 598 | (incf count) | |
| 599 | (if (< *print-line-limit* (filecol *standard-output*)) | |
| 600 | (progn | |
| 601 | (print-next) | |
| 602 | (when *print-indent-contin* | |
| 603 | (princ " ") | |
| 604 | (setq flag t))) | |
| 605 | (if flag (princ " ") (setq flag t))) | |
| 606 | (if (atom i) | |
| 607 | (unless (eql control-d i) | |
| 608 | (prin1 i)) | |
| 609 | (if (eq ':+ (car i)) | |
| 610 | (dolist (e (cdr i)) | |
| 611 | (if (< *print-line-limit* (filecol *standard-output*)) | |
| 612 | (progn | |
| 613 | (print-next) | |
| 614 | (when *print-indent-contin* | |
| 615 | (princ " ") | |
| 616 | (setq flag t))) | |
| 617 | (if flag (princ " ") (setq flag t))) | |
| 618 | (prin1 e)) | |
| 619 | (prin1 i)))))))) | |
| 612 | 620 | |
| 613 | 621 | (defun read-comment-line () |
| 614 | 622 | (let ((ch (peek-char nil *standard-input* nil nil))) |
| 615 | 623 | (unless ch (return-from read-comment-line " ")) |
| 616 | 624 | (if (eq .reader-ch. 'return) |
| 617 | (return-from read-comment-line (string #\linefeed)) | |
| 618 | (if (member ch '(#\linefeed #\page #\return #\newline)) | |
| 619 | (progn (read-char) | |
| 620 | (return-from read-comment-line (string #\linefeed))) | |
| 621 | (read-line))))) | |
| 625 | (return-from read-comment-line (string #\linefeed)) | |
| 626 | (if (member ch '(#\linefeed #\page #\return #\newline)) | |
| 627 | (progn (read-char) | |
| 628 | (return-from read-comment-line (string #\linefeed))) | |
| 629 | (read-line))))) | |
| 622 | 630 | |
| 623 | 631 | ;;; an ignored comment (value is "") |
| 624 | 632 | ;;; has provision for long case: ** ( ) |
| 628 | 636 | (let (ch) |
| 629 | 637 | (unless (eql '\( .reader-ch.) |
| 630 | 638 | (loop |
| 631 | (setq ch (read-char *standard-input* nil *lex-eof*)) | |
| 632 | (unless (or (eql #\Space ch) | |
| 633 | (eql #\Tab ch)) | |
| 634 | (return))) | |
| 639 | (setq ch (read-char *standard-input* nil *lex-eof*)) | |
| 640 | (unless (or (eql #\Space ch) | |
| 641 | (eql #\Tab ch)) | |
| 642 | (return))) | |
| 635 | 643 | (setq .reader-ch. |
| 636 | (if (eq ch *lex-eof*) | |
| 644 | (if (eq ch *lex-eof*) | |
| 637 | 645 | *lex-eof* |
| 638 | (let ((val (reader-get-syntax ch))) | |
| 639 | (if val val ch))))) | |
| 646 | (let ((val (reader-get-syntax ch))) | |
| 647 | (if val val ch))))) | |
| 640 | 648 | (if (eq '\( .reader-ch.) |
| 641 | (lex-read) | |
| 642 | (unless (or (eql #\Newline ch) (eql #\Return ch)) (read-line)) | |
| 643 | )) | |
| 649 | (lex-read) | |
| 650 | (unless (or (eql #\Newline ch) (eql #\Return ch)) (read-line)) | |
| 651 | )) | |
| 644 | 652 | (setq .reader-ch. 'space) |
| 645 | 653 | "" |
| 646 | 654 | ) |
| 671 | 679 | (with-input-from-string (*standard-input* string) |
| 672 | 680 | (let ((cur (!set-term-delim-chars))) |
| 673 | 681 | (let ((res nil) |
| 674 | (inp nil) | |
| 675 | (inv nil)) | |
| 676 | (loop (setq inp (lex-read)) | |
| 677 | (when #+:CCL-3 (equal *lex-eof* inp) | |
| 682 | (inp nil) | |
| 683 | (inv nil)) | |
| 684 | (loop (setq inp (lex-read)) | |
| 685 | (when #+:CCL-3 (equal *lex-eof* inp) | |
| 678 | 686 | #-:CCL-3 (eq *lex-eof* inp) |
| 679 | (setq *reader-input* inv) | |
| 680 | (return)) | |
| 681 | (cond ((= 1 (length (the list inp))) (setq inv (car inp))) | |
| 682 | (t (setq inv *reader-void*))) | |
| 683 | (setq res (append res inp)) | |
| 684 | ) | |
| 685 | (!set-reader cur) | |
| 686 | (clear-input) | |
| 687 | (setq *reader-input* *reader-void*) | |
| 688 | res | |
| 689 | )))) | |
| 687 | (setq *reader-input* inv) | |
| 688 | (return)) | |
| 689 | (cond ((= 1 (length (the list inp))) (setq inv (car inp))) | |
| 690 | (t (setq inv *reader-void*))) | |
| 691 | (setq res (append res inp)) | |
| 692 | ) | |
| 693 | (!set-reader cur) | |
| 694 | (clear-input) | |
| 695 | (setq *reader-input* *reader-void*) | |
| 696 | res | |
| 697 | )))) | |
| 690 | 698 | |
| 691 | 699 | (defun read-seq-of-term-from-string (string) |
| 692 | 700 | (declare (type simple-string string) |
| 693 | (values list)) | |
| 701 | (values list)) | |
| 694 | 702 | (with-input-from-string (*standard-input* string) |
| 695 | 703 | (let ((cur (!set-term-delim-chars))) |
| 696 | 704 | (let ((res nil)) |
| 697 | (block exit | |
| 698 | ;; read in one token. | |
| 699 | (if (eq *reader-input* *reader-void*) | |
| 700 | (setq *reader-input* (lex-read)) | |
| 701 | (when (equal "(" *reader-input*) | |
| 702 | (setq *reader-input* (lex-read-rest-of-list)))) | |
| 703 | (when (reader-is-at-eof) (return-from exit)) | |
| 704 | (when (atom *reader-input*) | |
| 705 | (setq *reader-input* (list *reader-input*))) | |
| 706 | (loop (setq res (append res *reader-input*)) | |
| 707 | (setq *reader-input* (lex-read)) | |
| 708 | (when (reader-is-at-eof) (return-from exit))) | |
| 709 | ) | |
| 710 | ;; restore read table. | |
| 711 | (!set-reader cur) | |
| 712 | (clear-input) | |
| 713 | (setq *reader-input* *reader-void*) | |
| 714 | res | |
| 715 | )))) | |
| 705 | (block exit | |
| 706 | ;; read in one token. | |
| 707 | (if (eq *reader-input* *reader-void*) | |
| 708 | (setq *reader-input* (lex-read)) | |
| 709 | (when (equal "(" *reader-input*) | |
| 710 | (setq *reader-input* (lex-read-rest-of-list)))) | |
| 711 | (when (reader-is-at-eof) (return-from exit)) | |
| 712 | (when (atom *reader-input*) | |
| 713 | (setq *reader-input* (list *reader-input*))) | |
| 714 | (loop (setq res (append res *reader-input*)) | |
| 715 | (setq *reader-input* (lex-read)) | |
| 716 | (when (reader-is-at-eof) (return-from exit))) | |
| 717 | ) | |
| 718 | ;; restore read table. | |
| 719 | (!set-reader cur) | |
| 720 | (clear-input) | |
| 721 | (setq *reader-input* *reader-void*) | |
| 722 | res | |
| 723 | )))) | |
| 716 | 724 | |
| 717 | 725 | ;;; READ-TERM-AT-TOP |
| 718 | 726 | ;;; |
| 720 | 728 | (declare (ignore ignore)) |
| 721 | 729 | (let ((lines (read-lines))) |
| 722 | 730 | (if (eq lines *lex-eof*) |
| 723 | *lex-eof* | |
| 724 | (read-term-from-string lines)))) | |
| 731 | *lex-eof* | |
| 732 | (read-term-from-string lines)))) | |
| 725 | 733 | |
| 726 | 734 | (defun read-seq-of-term-at-top (&rest ignore) |
| 727 | 735 | (declare (ignore ignore)) |
| 728 | 736 | (let ((lines (read-lines))) |
| 729 | 737 | (if #+:MCL (equal lines *lex-eof*) |
| 730 | #-:MCL (eq lines *lex-eof*) | |
| 731 | *lex-eof* | |
| 732 | (read-seq-of-term-from-string lines)))) | |
| 738 | #-:MCL (eq lines *lex-eof*) | |
| 739 | *lex-eof* | |
| 740 | (read-seq-of-term-from-string lines)))) | |
| 733 | 741 | |
| 734 | 742 | ;;; READ-TERM |
| 735 | 743 | ;;; |
| 736 | 744 | (defun read-term (context) |
| 737 | 745 | (declare (type list context) |
| 738 | (values list)) | |
| 746 | (values list)) | |
| 739 | 747 | (let ((cur (!set-term-delim-chars))) |
| 740 | 748 | (let ((res nil) |
| 741 | inp | |
| 742 | inv) | |
| 749 | inp | |
| 750 | inv) | |
| 743 | 751 | (loop (setq inp (lex-read)) |
| 744 | (when #-:ccl-3(eq *lex-eof* inp) | |
| 745 | #+:ccl-3(equal *lex-eof* inp) | |
| 746 | (return-from read-term *lex-eof*)) | |
| 747 | (cond ((= 1 (length (the list inp))) | |
| 748 | (setq inv (car (the list inp)))) | |
| 749 | (t (setq inv *reader-void*))) | |
| 750 | (when (lex-string-match inv (car context)) | |
| 751 | (setq *reader-input* inv) | |
| 752 | (return)) | |
| 753 | (setq res (append res inp)) | |
| 754 | ) | |
| 752 | (when #-:ccl-3(eq *lex-eof* inp) | |
| 753 | #+:ccl-3(equal *lex-eof* inp) | |
| 754 | (return-from read-term *lex-eof*)) | |
| 755 | (cond ((= 1 (length (the list inp))) | |
| 756 | (setq inv (car (the list inp)))) | |
| 757 | (t (setq inv *reader-void*))) | |
| 758 | (when (lex-string-match inv (car context)) | |
| 759 | (setq *reader-input* inv) | |
| 760 | (return)) | |
| 761 | (setq res (append res inp)) | |
| 762 | ) | |
| 755 | 763 | (!set-reader cur) |
| 756 | 764 | res |
| 757 | 765 | ))) |
| 760 | 768 | ;;; |
| 761 | 769 | (defun read-seq-of-term (context) |
| 762 | 770 | (declare (type list context) |
| 763 | (values list)) | |
| 771 | (values list)) | |
| 764 | 772 | (let ((cur (!set-term-delim-chars))) |
| 765 | 773 | (let ((res nil)) |
| 766 | 774 | ;; read in one token. |
| 767 | 775 | (if (eq *reader-input* *reader-void*) |
| 768 | (setq *reader-input* (lex-read)) | |
| 769 | (when (equal "(" *reader-input*) | |
| 770 | (setq *reader-input* (lex-read-rest-of-list)))) | |
| 771 | (when (at-eof-or-control-d) ; was reader-is-at-eof | |
| 772 | (return-from read-seq-of-term *lex-eof*)) | |
| 776 | (setq *reader-input* (lex-read)) | |
| 777 | (when (equal "(" *reader-input*) | |
| 778 | (setq *reader-input* (lex-read-rest-of-list)))) | |
| 779 | (when (at-eof-or-control-d) ; was reader-is-at-eof | |
| 780 | (return-from read-seq-of-term *lex-eof*)) | |
| 773 | 781 | (when (atom *reader-input*) |
| 774 | (setq *reader-input* (list *reader-input*))) | |
| 782 | (setq *reader-input* (list *reader-input*))) | |
| 775 | 783 | (loop (when (and (null (cdr *reader-input*)) |
| 776 | (stringp (car *reader-input*)) | |
| 777 | (lex-string-match (car *reader-input*) (car context))) | |
| 778 | (setq *reader-input* (car *reader-input*)) | |
| 779 | (return)) | |
| 780 | (setq res (append res *reader-input*)) | |
| 781 | (setq *reader-input* (lex-read)) | |
| 782 | (when (at-eof-or-control-d) ; was reader-is-at-eof | |
| 783 | (return-from read-seq-of-term *lex-eof*)) | |
| 784 | ) | |
| 784 | (stringp (car *reader-input*)) | |
| 785 | (lex-string-match (car *reader-input*) (car context))) | |
| 786 | (setq *reader-input* (car *reader-input*)) | |
| 787 | (return)) | |
| 788 | (setq res (append res *reader-input*)) | |
| 789 | (setq *reader-input* (lex-read)) | |
| 790 | (when (at-eof-or-control-d) ; was reader-is-at-eof | |
| 791 | (return-from read-seq-of-term *lex-eof*)) | |
| 792 | ) | |
| 785 | 793 | ;; restore read table. |
| 786 | 794 | (!set-reader cur) |
| 787 | 795 | res |
| 793 | 801 | (declare (ignore context)) |
| 794 | 802 | (let ((*live-newline* t)) |
| 795 | 803 | (let ((res nil) |
| 796 | (inv nil) | |
| 797 | inp) | |
| 804 | (inv nil) | |
| 805 | inp) | |
| 798 | 806 | (loop (setq inp (lex-read)) |
| 799 | (when #-:ccl-3(eq *lex-eof* inp) | |
| 800 | #+:ccl-3(equal *lex-eof* inp) | |
| 801 | (return-from read-args *lex-eof*)) | |
| 802 | (cond ((= 1 (length (the list inp))) | |
| 803 | (setq inv (car (the list inp)))) | |
| 804 | (t (setq inv *reader-void*))) | |
| 805 | (when (and (consp inv) (eq (car inv) .String-token.)) | |
| 806 | (setq res (append res inp)) | |
| 807 | (setq *reader-input* *reader-void*) | |
| 808 | (return)) | |
| 809 | (when (lex-string-match inv 'return) | |
| 810 | (setq *reader-input* *reader-void*) | |
| 811 | (return)) | |
| 812 | (setq res (append res inp))) | |
| 807 | (when #-:ccl-3(eq *lex-eof* inp) | |
| 808 | #+:ccl-3(equal *lex-eof* inp) | |
| 809 | (return-from read-args *lex-eof*)) | |
| 810 | (cond ((= 1 (length (the list inp))) | |
| 811 | (setq inv (car (the list inp)))) | |
| 812 | (t (setq inv *reader-void*))) | |
| 813 | (when (and (consp inv) (eq (car inv) .String-token.)) | |
| 814 | (setq res (append res inp)) | |
| 815 | (setq *reader-input* *reader-void*) | |
| 816 | (return)) | |
| 817 | (when (lex-string-match inv 'return) | |
| 818 | (setq *reader-input* *reader-void*) | |
| 819 | (return)) | |
| 820 | (setq res (append res inp))) | |
| 813 | 821 | res))) |
| 814 | 822 | |
| 815 | 823 | ;;; READ-SEQ-OF-OPNAME |
| 820 | 828 | |
| 821 | 829 | (defun read-seq-of-opname (context) |
| 822 | 830 | (declare (type list context) |
| 823 | (values list)) | |
| 831 | (values list)) | |
| 824 | 832 | (let ((cur (!set-single-reader .op-name-delimiting-chars.))) |
| 825 | 833 | (let ((res nil)) |
| 826 | 834 | (if (eq *reader-input* *reader-void*) |
| 827 | (setq *reader-input* (lex-read)) | |
| 828 | (when (equal "(" *reader-input*) | |
| 829 | (setq *reader-input* (lex-read-rest-of-list)))) | |
| 830 | (when ; (reader-is-at-eof) | |
| 831 | (at-eof-or-control-d) | |
| 832 | (return-from read-seq-of-opname *lex-eof*)) | |
| 835 | (setq *reader-input* (lex-read)) | |
| 836 | (when (equal "(" *reader-input*) | |
| 837 | (setq *reader-input* (lex-read-rest-of-list)))) | |
| 838 | (when ; (reader-is-at-eof) | |
| 839 | (at-eof-or-control-d) | |
| 840 | (return-from read-seq-of-opname *lex-eof*)) | |
| 833 | 841 | (when (atom *reader-input*) |
| 834 | (setq *reader-input* (list *reader-input*))) | |
| 842 | (setq *reader-input* (list *reader-input*))) | |
| 835 | 843 | (loop (when (and (null (cdr *reader-input*)) |
| 836 | (stringp (car *reader-input*)) | |
| 837 | (lex-string-match (car *reader-input*) (car context))) | |
| 838 | (setq *reader-input* (car *reader-input*)) | |
| 839 | (return)) | |
| 840 | (setq res (append res *reader-input*)) | |
| 841 | (setq *reader-input* (lex-read)) | |
| 842 | (when (at-eof-or-control-d) ; (reader-is-at-eof) | |
| 843 | (return-from read-seq-of-opname *lex-eof*)) | |
| 844 | ) | |
| 844 | (stringp (car *reader-input*)) | |
| 845 | (lex-string-match (car *reader-input*) (car context))) | |
| 846 | (setq *reader-input* (car *reader-input*)) | |
| 847 | (return)) | |
| 848 | (setq res (append res *reader-input*)) | |
| 849 | (setq *reader-input* (lex-read)) | |
| 850 | (when (at-eof-or-control-d) ; (reader-is-at-eof) | |
| 851 | (return-from read-seq-of-opname *lex-eof*)) | |
| 852 | ) | |
| 845 | 853 | (!set-reader cur) |
| 846 | 854 | res |
| 847 | 855 | ))) |
| 850 | 858 | ;;; |
| 851 | 859 | (defun read-opname (context) |
| 852 | 860 | (declare (type list context) |
| 853 | (values list)) | |
| 861 | (values list)) | |
| 854 | 862 | (let ((cur (!set-single-reader .op-name-delimiting-chars.))) |
| 855 | 863 | (let ((res nil) |
| 856 | inp | |
| 857 | inv) | |
| 864 | inp | |
| 865 | inv) | |
| 858 | 866 | (loop (setq inp (lex-read)) |
| 859 | (when (eq *lex-eof* inp) | |
| 860 | (return-from read-opname *lex-eof*)) | |
| 861 | (cond ((= 1 (length (the list inp))) (setq inv (car inp))) | |
| 862 | (t (setq inv *reader-void*))) | |
| 863 | (when (lex-string-match inv (car context)) | |
| 864 | (setq *reader-input* inv) | |
| 865 | (return)) | |
| 866 | (setq res (append res inp)) | |
| 867 | ) | |
| 867 | (when (eq *lex-eof* inp) | |
| 868 | (return-from read-opname *lex-eof*)) | |
| 869 | (cond ((= 1 (length (the list inp))) (setq inv (car inp))) | |
| 870 | (t (setq inv *reader-void*))) | |
| 871 | (when (lex-string-match inv (car context)) | |
| 872 | (setq *reader-input* inv) | |
| 873 | (return)) | |
| 874 | (setq res (append res inp)) | |
| 875 | ) | |
| 868 | 876 | (!set-reader cur) |
| 869 | 877 | res |
| 870 | 878 | ))) |
| 873 | 881 | (declare (ignore ignore)) |
| 874 | 882 | (let ((line (read-lines))) |
| 875 | 883 | (if (eq line *lex-eof*) |
| 876 | *lex-eof* | |
| 877 | (read-opname-from-string line)))) | |
| 884 | *lex-eof* | |
| 885 | (read-opname-from-string line)))) | |
| 878 | 886 | |
| 879 | 887 | (defun read-seq-of-opname-at-top (&rest ignore) |
| 880 | 888 | (declare (ignore ignore)) |
| 881 | 889 | (let ((line (read-lines))) |
| 882 | 890 | (if (eq line *lex-eof*) |
| 883 | *lex-eof* | |
| 884 | (read-seq-of-opname-from-string line)))) | |
| 891 | *lex-eof* | |
| 892 | (read-seq-of-opname-from-string line)))) | |
| 885 | 893 | |
| 886 | 894 | (defun read-opname-from-string (string) |
| 887 | 895 | (declare (type simple-string string)) |
| 888 | 896 | (with-input-from-string (*standard-input* string) |
| 889 | 897 | (let ((cur (!set-single-reader .op-name-delimiting-chars.))) |
| 890 | 898 | (let ((res nil) |
| 891 | (inp nil) | |
| 892 | (inv nil)) | |
| 893 | (loop (setq inp (lex-read)) | |
| 894 | (when (eq *lex-eof* inp) | |
| 895 | (setq *reader-input* inv) | |
| 896 | (return)) | |
| 897 | (cond ((= 1 (length (the list inp))) (setq inv (car inp))) | |
| 898 | (t (setq inv *reader-void*))) | |
| 899 | (setq res (append res inp)) | |
| 900 | ) | |
| 901 | (!set-reader cur) | |
| 902 | (clear-input) | |
| 903 | (setq *reader-input* *reader-void*) | |
| 904 | res | |
| 905 | )))) | |
| 899 | (inp nil) | |
| 900 | (inv nil)) | |
| 901 | (loop (setq inp (lex-read)) | |
| 902 | (when (eq *lex-eof* inp) | |
| 903 | (setq *reader-input* inv) | |
| 904 | (return)) | |
| 905 | (cond ((= 1 (length (the list inp))) (setq inv (car inp))) | |
| 906 | (t (setq inv *reader-void*))) | |
| 907 | (setq res (append res inp)) | |
| 908 | ) | |
| 909 | (!set-reader cur) | |
| 910 | (clear-input) | |
| 911 | (setq *reader-input* *reader-void*) | |
| 912 | res | |
| 913 | )))) | |
| 906 | 914 | |
| 907 | 915 | (defun read-seq-of-opname-from-string (string) |
| 908 | 916 | (declare (type simple-string string) |
| 909 | (values list)) | |
| 917 | (values list)) | |
| 910 | 918 | (with-input-from-string (*standard-input* string) |
| 911 | 919 | (let ((cur (!set-single-reader .op-name-delimiting-chars.))) |
| 912 | 920 | (let ((res nil)) |
| 913 | (block exit | |
| 914 | ;; read in one token. | |
| 915 | (if (eq *reader-input* *reader-void*) | |
| 916 | (setq *reader-input* (lex-read)) | |
| 917 | (when (equal "(" *reader-input*) | |
| 918 | (setq *reader-input* (lex-read-rest-of-list)))) | |
| 919 | (when (reader-is-at-eof) (return-from exit)) | |
| 920 | (when (atom *reader-input*) | |
| 921 | (setq *reader-input* (list *reader-input*))) | |
| 922 | (loop (setq res (append res *reader-input*)) | |
| 923 | (setq *reader-input* (lex-read)) | |
| 924 | (when (reader-is-at-eof) (return-from exit))) | |
| 925 | ) | |
| 926 | ;; restore read table. | |
| 927 | (!set-reader cur) | |
| 928 | (clear-input) | |
| 929 | (setq *reader-input* *reader-void*) | |
| 930 | res | |
| 931 | )))) | |
| 921 | (block exit | |
| 922 | ;; read in one token. | |
| 923 | (if (eq *reader-input* *reader-void*) | |
| 924 | (setq *reader-input* (lex-read)) | |
| 925 | (when (equal "(" *reader-input*) | |
| 926 | (setq *reader-input* (lex-read-rest-of-list)))) | |
| 927 | (when (reader-is-at-eof) (return-from exit)) | |
| 928 | (when (atom *reader-input*) | |
| 929 | (setq *reader-input* (list *reader-input*))) | |
| 930 | (loop (setq res (append res *reader-input*)) | |
| 931 | (setq *reader-input* (lex-read)) | |
| 932 | (when (reader-is-at-eof) (return-from exit))) | |
| 933 | ) | |
| 934 | ;; restore read table. | |
| 935 | (!set-reader cur) | |
| 936 | (clear-input) | |
| 937 | (setq *reader-input* *reader-void*) | |
| 938 | res | |
| 939 | )))) | |
| 932 | 940 | |
| 933 | 941 | ;;; READ-SORT |
| 934 | 942 | ;;; |
| 936 | 944 | (declare (ignore c)) |
| 937 | 945 | (let ((old-syntax (reader-get-syntax #\!))) |
| 938 | 946 | (unwind-protect |
| 939 | (let ((inp nil)) | |
| 940 | (!set-syntax #\! nil) | |
| 941 | (setq inp (!read-sym)) | |
| 942 | (cond ((and (stringp inp) | |
| 943 | (eql #\. (char (the simple-string inp) | |
| 944 | (1- (length (the simple-string inp)))))) | |
| 945 | (loop (unless (eq 'space .reader-ch.) (return)) ;a bit ugly | |
| 946 | (setq .reader-ch. (reader-get-char *standard-input*))) | |
| 947 | (when (eq .reader-ch. *lex-eof*) | |
| 948 | (return-from read-sort *lex-eof*)) | |
| 949 | (if (equal '\( .reader-ch.) | |
| 950 | (let ((rest (lex-read))) | |
| 951 | (if (eq rest *lex-eof*) | |
| 952 | *lex-eof* | |
| 953 | (list* inp (lex-read)))) | |
| 954 | inp)) | |
| 955 | (t inp) | |
| 956 | )) | |
| 947 | (let ((inp nil)) | |
| 948 | (!set-syntax #\! nil) | |
| 949 | (setq inp (!read-sym)) | |
| 950 | (cond ((and (stringp inp) | |
| 951 | (eql #\. (char (the simple-string inp) | |
| 952 | (1- (length (the simple-string inp)))))) | |
| 953 | (loop (unless (eq 'space .reader-ch.) (return)) ;a bit ugly | |
| 954 | (setq .reader-ch. (reader-get-char *standard-input*))) | |
| 955 | (when (eq .reader-ch. *lex-eof*) | |
| 956 | (return-from read-sort *lex-eof*)) | |
| 957 | (if (equal '\( .reader-ch.) | |
| 958 | (let ((rest (lex-read))) | |
| 959 | (if (eq rest *lex-eof*) | |
| 960 | *lex-eof* | |
| 961 | (list* inp (lex-read)))) | |
| 962 | inp)) | |
| 963 | (t inp) | |
| 964 | )) | |
| 957 | 965 | (!set-syntax #\! old-syntax)))) |
| 958 | 966 | |
| 959 | 967 | ;;; READ-SORTS |
| 960 | 968 | ;;; |
| 961 | 969 | (defun read-sorts (context) |
| 962 | 970 | (let ((res nil) |
| 963 | (old-syntax (reader-get-syntax #\!))) | |
| 971 | (old-syntax (reader-get-syntax #\!))) | |
| 964 | 972 | (unwind-protect |
| 965 | (progn (!set-syntax #\! nil) | |
| 966 | (loop (!read-in) | |
| 967 | (when (at-eof-or-control-d) | |
| 968 | (return-from read-sorts *lex-eof*)) | |
| 969 | (when (lex-string-match *reader-input* (car context)) | |
| 970 | (return (nreverse res))) | |
| 971 | (push (read-sort context) res))) | |
| 973 | (progn (!set-syntax #\! nil) | |
| 974 | (loop (!read-in) | |
| 975 | (when (at-eof-or-control-d) | |
| 976 | (return-from read-sorts *lex-eof*)) | |
| 977 | (when (lex-string-match *reader-input* (car context)) | |
| 978 | (return (nreverse res))) | |
| 979 | (push (read-sort context) res))) | |
| 972 | 980 | (!set-syntax #\! old-syntax)))) |
| 973 | 981 | |
| 974 | 982 | ;;; READ-CHARS |
| 977 | 985 | (let ((res nil)) |
| 978 | 986 | (loop (!read-in) |
| 979 | 987 | (when (at-eof-or-control-d) |
| 980 | (return-from read-chars *lex-eof*)) | |
| 988 | (return-from read-chars *lex-eof*)) | |
| 981 | 989 | (when (lex-string-match *reader-input* (car context)) |
| 982 | (return-from read-chars (nreverse res))) | |
| 990 | (return-from read-chars (nreverse res))) | |
| 983 | 991 | (let ((c (!read-sym))) |
| 984 | ;;(format t "~%- read-chars: sym=~s, res=~s" c res) | |
| 985 | (if (consp c) | |
| 986 | (push (car c) res) | |
| 987 | (push c res)))))) | |
| 992 | ;;(format t "~%- read-chars: sym=~s, res=~s" c res) | |
| 993 | (if (consp c) | |
| 994 | (push (car c) res) | |
| 995 | (push c res)))))) | |
| 988 | 996 | |
| 989 | 997 | ;;; SPECIAL READERS NOT Spported by Chaos General Reader |
| 990 | 998 | ;;; |
| 991 | 999 | |
| 992 | 1000 | (defun read-opattr (c) |
| 993 | 1001 | (declare (type list c) |
| 994 | (values list)) | |
| 1002 | (values list)) | |
| 995 | 1003 | (!read-in) |
| 996 | 1004 | (when (at-eof-or-control-d) (return-from read-opattr *lex-eof*)) |
| 997 | 1005 | (if (lex-string-match *reader-input* #\[) |
| 999 | 1007 | () |
| 1000 | 1008 | ;; |
| 1001 | 1009 | (progn |
| 1002 | (reader-suppress-ch c) | |
| 1003 | nil))) | |
| 1010 | (reader-suppress-ch c) | |
| 1011 | nil))) | |
| 1004 | 1012 | |
| 1005 | 1013 | ;;; |
| 1006 | 1014 | (defun read-super-exp (c) |
| 1007 | 1015 | (declare (type list c) |
| 1008 | (values list)) | |
| 1016 | (values list)) | |
| 1009 | 1017 | (let ((cur (!set-single-reader '(#\( #\))))) |
| 1010 | 1018 | (prog1 (read-superexp c) |
| 1011 | 1019 | (!set-reader cur)))) |
| 1012 | 1020 | |
| 1013 | 1021 | (defun read-superexp (c) |
| 1014 | 1022 | (declare (type list c) |
| 1015 | (values list)) | |
| 1023 | (values list)) | |
| 1016 | 1024 | (let ((res nil)) |
| 1017 | 1025 | (loop (!read-in) |
| 1018 | (when (at-eof-or-control-d) (general-read-eof-error)) | |
| 1019 | (when (general-read-string-matches *reader-input* c) | |
| 1020 | (return res)) | |
| 1021 | (setq res (nconc res (read-superexpr-delimited)))) | |
| 1026 | (when (at-eof-or-control-d) (general-read-eof-error)) | |
| 1027 | (when (general-read-string-matches *reader-input* c) | |
| 1028 | (return res)) | |
| 1029 | (setq res (nconc res (read-superexpr-delimited)))) | |
| 1022 | 1030 | res)) |
| 1023 | 1031 | |
| 1024 | 1032 | (defun read-superexpr-delimited () |
| 1026 | 1034 | (!read-in) |
| 1027 | 1035 | (when (at-eof-or-control-d) (general-read-eof-error)) |
| 1028 | 1036 | (let ((pr (assoc *reader-input* '(("(" ")")) |
| 1029 | :test #'general-read-string-matches))) | |
| 1037 | :test #'general-read-string-matches))) | |
| 1030 | 1038 | (cond ((null pr) |
| 1031 | (prog1 (cons *reader-input* nil) | |
| 1032 | (!read-discard))) | |
| 1033 | (t (let ((sym *reader-input*)) | |
| 1034 | (!read-discard) | |
| 1035 | (let ((lst (read-superexp (cdr pr)))) | |
| 1036 | (prog1 (cons sym (append lst (cons *reader-input* nil))) | |
| 1037 | (!read-discard))))) | |
| 1038 | ))) | |
| 1039 | (prog1 (cons *reader-input* nil) | |
| 1040 | (!read-discard))) | |
| 1041 | (t (let ((sym *reader-input*)) | |
| 1042 | (!read-discard) | |
| 1043 | (let ((lst (read-superexp (cdr pr)))) | |
| 1044 | (prog1 (cons sym (append lst (cons *reader-input* nil))) | |
| 1045 | (!read-discard))))) | |
| 1046 | ))) | |
| 1039 | 1047 | ;;; |
| 1040 | 1048 | ;;; Module Expression Reader |
| 1041 | 1049 | ;;; |
| 1063 | 1071 | ;;; |
| 1064 | 1072 | (defun scan-parenthesized-unit (tokens) |
| 1065 | 1073 | (declare (type list tokens) |
| 1066 | (values (or symbol list) list)) | |
| 1074 | (values (or symbol list) list)) | |
| 1067 | 1075 | (if (equal "(" (car tokens)) |
| 1068 | 1076 | (let ((count 1) |
| 1069 | (lst (cdr tokens)) | |
| 1070 | (res nil) | |
| 1071 | tok) | |
| 1072 | (declare (type fixnum count)) | |
| 1073 | (loop (when (null lst) (return (values 'unbalanced tokens))) | |
| 1074 | (setf tok (car lst) | |
| 1075 | lst (cdr lst)) | |
| 1076 | (when (and (= 1 count) (equal ")" tok)) | |
| 1077 | (return (values (nreverse res) lst))) | |
| 1078 | (setf res (cons tok res)) | |
| 1079 | (if (equal "(" tok) | |
| 1080 | (incf count) | |
| 1081 | (if (equal ")" tok) | |
| 1082 | (decf count))) | |
| 1083 | )) | |
| 1077 | (lst (cdr tokens)) | |
| 1078 | (res nil) | |
| 1079 | tok) | |
| 1080 | (declare (type fixnum count)) | |
| 1081 | (loop (when (null lst) (return (values 'unbalanced tokens))) | |
| 1082 | (setf tok (car lst) | |
| 1083 | lst (cdr lst)) | |
| 1084 | (when (and (= 1 count) (equal ")" tok)) | |
| 1085 | (return (values (nreverse res) lst))) | |
| 1086 | (setf res (cons tok res)) | |
| 1087 | (if (equal "(" tok) | |
| 1088 | (incf count) | |
| 1089 | (if (equal ")" tok) | |
| 1090 | (decf count))) | |
| 1091 | )) | |
| 1084 | 1092 | (values (list (car tokens)) (cdr tokens)))) |
| 1085 | 1093 | |
| 1086 | 1094 | (defun group-paren-units (tokens) |
| 1087 | 1095 | (declare (type list tokens) |
| 1088 | (values list)) | |
| 1096 | (values list)) | |
| 1089 | 1097 | (let ((res nil) |
| 1090 | (lst tokens) | |
| 1091 | unit) | |
| 1098 | (lst tokens) | |
| 1099 | unit) | |
| 1092 | 1100 | (loop (multiple-value-setq (unit lst) |
| 1093 | (scan-parenthesized-unit lst)) | |
| 1094 | (when (eq 'unbalanced unit) | |
| 1095 | (return tokens)) | |
| 1096 | (setq res (cons unit res)) | |
| 1097 | (when (null lst) | |
| 1098 | (return (nreverse res))) | |
| 1099 | ))) | |
| 1101 | (scan-parenthesized-unit lst)) | |
| 1102 | (when (eq 'unbalanced unit) | |
| 1103 | (return tokens)) | |
| 1104 | (setq res (cons unit res)) | |
| 1105 | (when (null lst) | |
| 1106 | (return (nreverse res))) | |
| 1107 | ))) | |
| 1100 | 1108 | |
| 1101 | 1109 | (defun check-enclosing-parens (tokens) |
| 1102 | 1110 | (declare (type t tokens) |
| 1103 | (values (or null t))) | |
| 1111 | (values (or null t))) | |
| 1104 | 1112 | (and (consp tokens) |
| 1105 | 1113 | (equal "(" (car tokens)) |
| 1106 | 1114 | (multiple-value-bind (par rst) |
| 1107 | (scan-parenthesized-unit tokens) | |
| 1115 | (scan-parenthesized-unit tokens) | |
| 1108 | 1116 | (declare (ignore par)) |
| 1109 | (null rst)))) | |
| 1117 | (null rst)))) | |
| 1110 | 1118 | |
| 1111 | 1119 | ;;; READ-MODULE-EXP |
| 1112 | 1120 | |
| 1121 | 1129 | (let ((cur (!set-single-reader '("_")))) |
| 1122 | 1130 | (let ((res nil)) |
| 1123 | 1131 | (loop (!read-in) |
| 1124 | (when (at-eof-or-control-d) (general-read-eof-error)) | |
| 1125 | (when (general-read-string-matches *reader-input* c) | |
| 1126 | (return res)) | |
| 1127 | (setq res (nconc res (read-modexp-delimited)))) | |
| 1132 | (when (at-eof-or-control-d) (general-read-eof-error)) | |
| 1133 | (when (general-read-string-matches *reader-input* c) | |
| 1134 | (return res)) | |
| 1135 | (setq res (nconc res (read-modexp-delimited)))) | |
| 1128 | 1136 | (!set-reader cur) |
| 1129 | 1137 | res |
| 1130 | 1138 | ))) |
| 1136 | 1144 | (!read-in) |
| 1137 | 1145 | ;; (when (at-eof-or-control-d) (general-read-eof-error)) |
| 1138 | 1146 | (let ((pr (assoc *reader-input* |
| 1139 | '(("view" "}") ("[" "]") ("(" ")") ) | |
| 1140 | :test #'general-read-string-matches))) | |
| 1147 | '(("view" "}") ("[" "]") ("(" ")") ) | |
| 1148 | :test #'general-read-string-matches))) | |
| 1141 | 1149 | ;; (format t "~&*reader-input* ~s" *reader-input*) |
| 1142 | 1150 | (cond ((null pr) |
| 1143 | (prog1 (cons *reader-input* nil) | |
| 1144 | (!read-discard))) | |
| 1145 | (t (let ((sym *reader-input*)) | |
| 1146 | (!read-discard) | |
| 1147 | (let ((lst (read-modexp (cdr pr)))) | |
| 1148 | (prog1 (cons sym (append lst (cons *reader-input* nil))) | |
| 1149 | (!read-discard))))) | |
| 1150 | ))) | |
| 1151 | (prog1 (cons *reader-input* nil) | |
| 1152 | (!read-discard))) | |
| 1153 | (t (let ((sym *reader-input*)) | |
| 1154 | (!read-discard) | |
| 1155 | (let ((lst (read-modexp (cdr pr)))) | |
| 1156 | (prog1 (cons sym (append lst (cons *reader-input* nil))) | |
| 1157 | (!read-discard))))) | |
| 1158 | ))) | |
| 1151 | 1159 | |
| 1152 | 1160 | ;;; READ-MODEXP-FROM-STRING |
| 1153 | 1161 | |
| 1154 | 1162 | (defun read-modexp-from-string (string) |
| 1155 | 1163 | (declare (type simple-string string) |
| 1156 | (values list)) | |
| 1164 | (values list)) | |
| 1157 | 1165 | (let ((*live-newline* nil)) |
| 1158 | 1166 | (with-input-from-string (*standard-input* string) |
| 1159 | 1167 | (let ((cur (!set-single-reader '(#\[ #\] #\_ #\{ #\}))) |
| 1160 | (res nil)) | |
| 1161 | (loop (!read-in) | |
| 1162 | (when (at-eof-or-control-d) (return)) | |
| 1163 | (setq res (nconc res (read-modexp-delimited)))) | |
| 1164 | (!set-reader cur) | |
| 1165 | (clear-input) | |
| 1166 | (setq *reader-input* *reader-void*) | |
| 1167 | res)))) | |
| 1168 | (res nil)) | |
| 1169 | (loop (!read-in) | |
| 1170 | (when (at-eof-or-control-d) (return)) | |
| 1171 | (setq res (nconc res (read-modexp-delimited)))) | |
| 1172 | (!set-reader cur) | |
| 1173 | (clear-input) | |
| 1174 | (setq *reader-input* *reader-void*) | |
| 1175 | res)))) | |
| 1168 | 1176 | |
| 1169 | 1177 | #|| |
| 1170 | 1178 | (defun module-print-top-level-choices () |
| 1171 | 1179 | (let ((flag nil)) |
| 1172 | 1180 | (dolist (i '( |
| 1173 | "module" "mod" "view" "reduce" "red" | |
| 1174 | "make" "test" "input" "in" "-->" | |
| 1175 | "**>" "--" "**" "parse" "match" "ev" "lisp" | |
| 1176 | "show" "sh" "set" "do" "select" "open" "close" "eof" | |
| 1177 | "let" "choose" | |
| 1178 | "quit" "q" "start" "apply" "cd" "ls" "pwd" )) | |
| 1181 | "module" "mod" "view" "reduce" "red" | |
| 1182 | "make" "test" "input" "in" "-->" | |
| 1183 | "**>" "--" "**" "parse" "match" "ev" "lisp" | |
| 1184 | "show" "sh" "set" "do" "select" "open" "close" "eof" | |
| 1185 | "let" "choose" | |
| 1186 | "quit" "q" "start" "apply" "cd" "ls" "pwd" )) | |
| 1179 | 1187 | (if (< *print-line-limit* (filecol *standard-output*)) |
| 1180 | (progn | |
| 1181 | (terpri) | |
| 1182 | (when *print-indent-contin* | |
| 1183 | (princ " ") | |
| 1184 | (setq flag t))) | |
| 1185 | (if flag (princ " ") (setq flag t))) | |
| 1188 | (progn | |
| 1189 | (terpri) | |
| 1190 | (when *print-indent-contin* | |
| 1191 | (princ " ") | |
| 1192 | (setq flag t))) | |
| 1193 | (if flag (princ " ") (setq flag t))) | |
| 1186 | 1194 | (princ i)))) |
| 1187 | 1195 | ||# |
| 1188 | 1196 | |
| 1193 | 1201 | |
| 1194 | 1202 | (defun wait-until-non-white (stream) |
| 1195 | 1203 | (declare (type stream) |
| 1196 | (values t)) | |
| 1204 | (values t)) | |
| 1197 | 1205 | (if (at-top-level) |
| 1198 | 1206 | (loop (when (not (or (eq 'space .reader-ch.) (eq 'return .reader-ch.))) |
| 1199 | (setf *sub-prompt* t) (return)) | |
| 1200 | (if (eq 'return .reader-ch.) | |
| 1201 | (progn | |
| 1202 | (when *sub-prompt* | |
| 1203 | (princ "> ") | |
| 1204 | (force-output)) | |
| 1205 | (reader-get-char stream) | |
| 1206 | (when (eq #\? .reader-ch.) | |
| 1207 | (let ((*chaos-verbose* t)) | |
| 1208 | (general-read-show-context) | |
| 1209 | (clear-input) | |
| 1210 | (force-output)) | |
| 1211 | (setf .reader-ch. 'space))) | |
| 1212 | (reader-get-char stream))) | |
| 1207 | (setf *sub-prompt* t) (return)) | |
| 1208 | (if (eq 'return .reader-ch.) | |
| 1209 | (progn | |
| 1210 | (when *sub-prompt* | |
| 1211 | (princ "> ") | |
| 1212 | (force-output)) | |
| 1213 | (reader-get-char stream) | |
| 1214 | (when (eq #\? .reader-ch.) | |
| 1215 | (let ((*chaos-verbose* t)) | |
| 1216 | (general-read-show-context) | |
| 1217 | (clear-input) | |
| 1218 | (force-output)) | |
| 1219 | (setf .reader-ch. 'space))) | |
| 1220 | (reader-get-char stream))) | |
| 1213 | 1221 | (loop (when (not (or (eq 'space .reader-ch.) (eq 'return .reader-ch.))) |
| 1214 | (return)) | |
| 1215 | (reader-get-char stream)))) | |
| 1222 | (return)) | |
| 1223 | (reader-get-char stream)))) | |
| 1216 | 1224 | ;;; EOF |
| 0 | 0 | ;;;-*- Mode:Lisp; Syntax:Common-Lisp; Package:CHAOS -*- |
| 1 | 1 | ;;; |
| 2 | ;;; Copyright (c) 2000-2014, Toshimi Sawada. All rights reserved. | |
| 2 | ;;; Copyright (c) 2000-2015, Toshimi Sawada. All rights reserved. | |
| 3 | 3 | ;;; |
| 4 | 4 | ;;; Redistribution and use in source and binary forms, with or without |
| 5 | 5 | ;;; modification, are permitted provided that the following conditions |
| 27 | 27 | ;;; |
| 28 | 28 | (in-package :CHAOS) |
| 29 | 29 | #|============================================================================== |
| 30 | System: Chaos | |
| 31 | Module: comlib | |
| 32 | File: string.lisp | |
| 30 | System: Chaos | |
| 31 | Module: comlib | |
| 32 | File: string.lisp | |
| 33 | 33 | ==============================================================================|# |
| 34 | 34 | #-:chaos-debug |
| 35 | 35 | (declaim (optimize (speed 3) (safety 0) #-GCL (debug 0))) |
| 49 | 49 | ;;; |
| 50 | 50 | (defun string-search-car (character-bag string &aux (delimiter nil)) |
| 51 | 51 | (declare (type simple-string string) |
| 52 | (type list character-bag) | |
| 53 | (values simple-string (or null character))) | |
| 52 | (type list character-bag) | |
| 53 | (values simple-string (or null character))) | |
| 54 | 54 | ;; |
| 55 | 55 | (let ((delimiter-position (position-if #'(lambda (character) |
| 56 | (declare (type character character)) | |
| 57 | (when (find character | |
| 58 | character-bag) | |
| 59 | (setq delimiter character))) | |
| 60 | string))) | |
| 56 | (declare (type character character)) | |
| 57 | (when (find character | |
| 58 | character-bag) | |
| 59 | (setq delimiter character))) | |
| 60 | string))) | |
| 61 | 61 | (values (subseq string 0 delimiter-position) |
| 62 | delimiter))) | |
| 62 | delimiter))) | |
| 63 | 63 | |
| 64 | 64 | ;;; string-search-cdr |
| 65 | 65 | ;;; Returns the part of the string after the first of the delimiters in |
| 68 | 68 | |
| 69 | 69 | (defun string-search-cdr (character-bag string &aux (delimiter nil)) |
| 70 | 70 | (declare (type simple-string string) |
| 71 | (type list character-bag) | |
| 72 | (values (or null simple-string) | |
| 73 | (or null character))) | |
| 71 | (type list character-bag) | |
| 72 | (values (or null simple-string) | |
| 73 | (or null character))) | |
| 74 | 74 | (let ((delimiter-position (position-if #'(lambda (character) |
| 75 | (when (find character | |
| 76 | character-bag) | |
| 77 | (setq delimiter character))) | |
| 78 | string))) | |
| 75 | (when (find character | |
| 76 | character-bag) | |
| 77 | (setq delimiter character))) | |
| 78 | string))) | |
| 79 | 79 | (declare (type (or null fixnum) delimiter-position)) |
| 80 | 80 | (if delimiter-position |
| 81 | (values (subseq string (1+ (the (integer 0 1024) delimiter-position))) | |
| 82 | delimiter) | |
| 83 | ;; Maybe this should be "" instead of NIL? | |
| 84 | (values nil delimiter)))) | |
| 81 | (values (subseq string (1+ (the (integer 0 1024) delimiter-position))) | |
| 82 | delimiter) | |
| 83 | ;; Maybe this should be "" instead of NIL? | |
| 84 | (values nil delimiter)))) | |
| 85 | 85 | |
| 86 | 86 | ;;; parse-with-delimiter : String -> List[String] |
| 87 | 87 | ;;; Breaks LINE into a list of strings, using DELIM as a breaking point. |
| 88 | 88 | |
| 89 | 89 | (defun parse-with-delimiter (line &optional (delim #\newline)) |
| 90 | 90 | (declare (type simple-string line) |
| 91 | (values list)) | |
| 91 | (values list)) | |
| 92 | 92 | ;; what about #\return instead of #\newline? |
| 93 | 93 | (let ((pos (position delim line))) |
| 94 | 94 | (declare (type (or null fixnum) pos)) |
| 100 | 100 | |
| 101 | 101 | (defun parse-with-delimiter2 (line &optional (delim #\newline)) |
| 102 | 102 | (declare (type simple-string line) |
| 103 | (values list)) | |
| 103 | (values list)) | |
| 104 | 104 | ;; what about #\return instead of #\newline? |
| 105 | 105 | (let ((pos (position delim line))) |
| 106 | 106 | (declare (type (or null fixnum) pos)) |
| 107 | 107 | (cond (pos |
| 108 | 108 | (cons (subseq line 0 pos) |
| 109 | (cons (string delim) | |
| 110 | (parse-with-delimiter2 (subseq line (1+ pos)) delim)))) | |
| 109 | (cons (string delim) | |
| 110 | (parse-with-delimiter2 (subseq line (1+ pos)) delim)))) | |
| 111 | 111 | (t |
| 112 | 112 | (list line))))) |
| 113 | 113 | |
| 116 | 116 | |
| 117 | 117 | (defun parse-with-delimiters (line &optional (delimiters '(#\newline))) |
| 118 | 118 | (declare (type simple-string line) |
| 119 | (type list delimiters) | |
| 120 | (values list)) | |
| 119 | (type list delimiters) | |
| 120 | (values list)) | |
| 121 | 121 | ;; what about #\return instead of #\newline? |
| 122 | 122 | (let ((pos (position-if #'(lambda (character) (find character delimiters)) |
| 123 | line))) | |
| 123 | line))) | |
| 124 | 124 | (declare (type (or null fixnum) pos)) |
| 125 | 125 | (cond (pos |
| 126 | 126 | (cons (subseq line 0 pos) |
| 136 | 136 | |
| 137 | 137 | (defun parallel-substitute (alist string) |
| 138 | 138 | (declare (type simple-string string) |
| 139 | (values simple-string)) | |
| 139 | (values simple-string)) | |
| 140 | 140 | ;; This function should be generalized to arbitrary sequences and |
| 141 | 141 | ;; have an arglist (alist sequence &key from-end (test #'eql) test-not |
| 142 | 142 | ;; (start 0) (count most-positive-fixnum) end key). |
| 143 | 143 | (if alist |
| 144 | 144 | (let* ((length (length string)) |
| 145 | (result (make-string length))) | |
| 146 | (declare (simple-string result)) | |
| 147 | (dotimes-fixnum (i length) | |
| 148 | (let ((old-char (schar string i))) | |
| 149 | (setf (schar result i) | |
| 150 | (or (second (assoc old-char alist :test #'char=)) | |
| 151 | old-char)))) | |
| 152 | result) | |
| 145 | (result (make-string length))) | |
| 146 | (declare (simple-string result)) | |
| 147 | (dotimes-fixnum (i length) | |
| 148 | (let ((old-char (schar string i))) | |
| 149 | (setf (schar result i) | |
| 150 | (or (second (assoc old-char alist :test #'char=)) | |
| 151 | old-char)))) | |
| 152 | result) | |
| 153 | 153 | string)) |
| 154 | 154 | |
| 155 | 155 | ;;; parse-with-string-delimiter |
| 160 | 160 | |
| 161 | 161 | (defun parse-with-string-delimiter (delim string &key (start 0) end) |
| 162 | 162 | (declare (type simple-string string) |
| 163 | (type fixnum start) | |
| 164 | (type (or null fixnum) end) | |
| 165 | (type (or simple-string character) delim) | |
| 166 | (values (or null simple-string) (or null fixnum) symbol)) | |
| 163 | (type fixnum start) | |
| 164 | (type (or null fixnum) end) | |
| 165 | (type (or simple-string character) delim) | |
| 166 | (values (or null simple-string) (or null fixnum) symbol)) | |
| 167 | 167 | ;; Conceivably, if DELIM is a string consisting of a single character, |
| 168 | 168 | ;; we could do this more efficiently using POSITION instead of SEARCH. |
| 169 | 169 | ;; However, any good implementation of SEARCH should optimize for that |
| 170 | 170 | ;; case, so nothing to worry about. |
| 171 | 171 | (setq end (or end (length string))) |
| 172 | 172 | (let ((delim-pos (search delim string :start2 start :end2 end)) |
| 173 | (dlength (length delim))) | |
| 173 | (dlength (length delim))) | |
| 174 | 174 | (declare (type fixnum dlength)) |
| 175 | (cond ((null delim-pos) | |
| 176 | ;; No delimiter was found. Return the rest of the string, | |
| 177 | ;; the end of the string, and :delim-not-found. | |
| 178 | (values (subseq string start end) end :delim-not-found)) | |
| 179 | ((= delim-pos start) | |
| 180 | ;; The field was empty, so return nil and skip over the delimiter. | |
| 181 | (values nil (+ start dlength) nil)) | |
| 182 | ;; The following clause is subsumed by the last cond clause, | |
| 183 | ;; and hence should probably be eliminated. | |
| 184 | (t | |
| 185 | ;; The delimiter is in the middle of the string. Return the | |
| 186 | ;; field and skip over the delimiter. | |
| 187 | (values (subseq string start delim-pos) | |
| 188 | (+ delim-pos dlength) | |
| 189 | nil))))) | |
| 175 | (cond ((null delim-pos) | |
| 176 | ;; No delimiter was found. Return the rest of the string, | |
| 177 | ;; the end of the string, and :delim-not-found. | |
| 178 | (values (subseq string start end) end :delim-not-found)) | |
| 179 | ((= delim-pos start) | |
| 180 | ;; The field was empty, so return nil and skip over the delimiter. | |
| 181 | (values nil (+ start dlength) nil)) | |
| 182 | ;; The following clause is subsumed by the last cond clause, | |
| 183 | ;; and hence should probably be eliminated. | |
| 184 | (t | |
| 185 | ;; The delimiter is in the middle of the string. Return the | |
| 186 | ;; field and skip over the delimiter. | |
| 187 | (values (subseq string start delim-pos) | |
| 188 | (+ delim-pos dlength) | |
| 189 | nil))))) | |
| 190 | 190 | |
| 191 | 191 | ;;; parse-with-string-delimiter* |
| 192 | 192 | ;;; Breaks STRING into a list of strings, each of which was separated |
| 196 | 196 | ;;; not terminated by DELIM. Also returns the final position in the string. |
| 197 | 197 | |
| 198 | 198 | (defun parse-with-string-delimiter* (delim string &key (start 0) end |
| 199 | include-last) | |
| 200 | (declare (type simple-string string) | |
| 201 | (type fixnum start)) | |
| 199 | include-last) | |
| 200 | (declare (type simple-string string) | |
| 201 | (type fixnum start)) | |
| 202 | 202 | (setq end (or end (length string))) |
| 203 | 203 | (let (result) |
| 204 | 204 | (loop |
| 205 | 205 | (if (< start (the fixnum end)) |
| 206 | (multiple-value-bind (component new-start delim-not-found) | |
| 207 | (parse-with-string-delimiter delim string :start start :end end) | |
| 208 | (when delim-not-found | |
| 209 | (when include-last | |
| 210 | (setq start new-start) | |
| 211 | (push component result)) | |
| 212 | (return)) | |
| 213 | (setq start new-start) | |
| 214 | (push component result)) | |
| 215 | (return))) | |
| 206 | (multiple-value-bind (component new-start delim-not-found) | |
| 207 | (parse-with-string-delimiter delim string :start start :end end) | |
| 208 | (when delim-not-found | |
| 209 | (when include-last | |
| 210 | (setq start new-start) | |
| 211 | (push component result)) | |
| 212 | (return)) | |
| 213 | (setq start new-start) | |
| 214 | (push component result)) | |
| 215 | (return))) | |
| 216 | 216 | (values (nreverse result) |
| 217 | start))) | |
| 217 | start))) | |
| 218 | 218 | |
| 219 | 219 | ;;; split-string |
| 220 | 220 | ;;; Splits the string into substrings at spaces. |
| 221 | 221 | ;;; |
| 222 | 222 | (defun split-string (string &key (item #\space) (test #'char=)) |
| 223 | 223 | (declare (type simple-string string) |
| 224 | (type character item) | |
| 225 | (type function test) | |
| 226 | (values list)) | |
| 224 | (type character item) | |
| 225 | (type function test) | |
| 226 | (values list)) | |
| 227 | 227 | (let ((len (length string)) |
| 228 | (index 0) | |
| 229 | (result nil)) | |
| 228 | (index 0) | |
| 229 | (result nil)) | |
| 230 | 230 | (declare (type fixnum index len)) |
| 231 | 231 | (dotimes (i len (progn (unless (= index len) |
| 232 | (push (subseq string index) result)) | |
| 233 | (reverse result))) | |
| 232 | (push (subseq string index) result)) | |
| 233 | (reverse result))) | |
| 234 | 234 | (declare (type fixnum i)) |
| 235 | 235 | (when (funcall test (char string i) item) |
| 236 | (unless (= index i);; two spaces in a row | |
| 237 | (push (subseq string index i) result)) | |
| 238 | (setf index (1+ i)))))) | |
| 236 | (unless (= index i);; two spaces in a row | |
| 237 | (push (subseq string index i) result)) | |
| 238 | (setf index (1+ i)))))) | |
| 239 | 239 | |
| 240 | 240 | ;;; extract-strings |
| 241 | 241 | ;;; Breaks STRING into a list of strings, using DELIMITERS as a |
| 242 | 242 | ;;; breaking point. |
| 243 | 243 | |
| 244 | 244 | (defun extract-strings (string &optional (delimiters '(#\newline #\space |
| 245 | #\return #\tab))) | |
| 246 | (declare (type simple-string string) | |
| 247 | (type list delimiters) | |
| 248 | (values list)) | |
| 245 | #\return #\tab))) | |
| 246 | (declare (type simple-string string) | |
| 247 | (type list delimiters) | |
| 248 | (values list)) | |
| 249 | 249 | (let* ((begin (position-if-not #'(lambda (character) |
| 250 | (find character delimiters)) | |
| 251 | string)) | |
| 252 | (end (when begin | |
| 253 | (position-if #'(lambda (character) | |
| 254 | (find character delimiters)) | |
| 255 | string :start begin)))) | |
| 250 | (find character delimiters)) | |
| 251 | string)) | |
| 252 | (end (when begin | |
| 253 | (position-if #'(lambda (character) | |
| 254 | (find character delimiters)) | |
| 255 | string :start begin)))) | |
| 256 | 256 | (cond ((and begin end) |
| 257 | 257 | (cons (subseq string begin end) |
| 258 | 258 | (extract-strings (subseq string (1+ end)) delimiters))) |
| 259 | (begin | |
| 260 | (list (subseq string begin))) | |
| 259 | (begin | |
| 260 | (list (subseq string begin))) | |
| 261 | 261 | (t |
| 262 | 262 | nil)))) |
| 263 | 263 | |
| 264 | 264 | ;;; format-justified-string |
| 265 | 265 | ;;; |
| 266 | 266 | (defun format-justified-string (prompt contents &optional (width 80) |
| 267 | (stream *standard-output*)) | |
| 267 | (stream *standard-output*)) | |
| 268 | 268 | (declare (type simple-string prompt contents) |
| 269 | (type fixnum width) | |
| 270 | (type stream stream)) | |
| 269 | (type fixnum width) | |
| 270 | (type stream stream)) | |
| 271 | 271 | (let ((prompt-length (+ 2 (the fixnum (length prompt))))) |
| 272 | 272 | (declare (type fixnum prompt-length)) |
| 273 | 273 | (cond ((< (+ prompt-length (the fixnum (length contents))) width) |
| 274 | (format stream "~%~A- ~A" prompt contents)) | |
| 275 | (t | |
| 276 | (format stream "~%~A-" prompt) | |
| 277 | (do* ((cursor prompt-length) | |
| 278 | (contents (split-string contents) (cdr contents)) | |
| 279 | (content (car contents) (car contents)) | |
| 280 | (content-length (1+ (the fixnum (length content))) | |
| 281 | (1+ (the fixnum (length content))))) | |
| 282 | ((null contents)) | |
| 283 | (declare (type fixnum content-length)) | |
| 284 | (cond ((< (+ cursor content-length) width) | |
| 285 | (incf cursor content-length) | |
| 286 | (format stream " ~A" content)) | |
| 287 | (t | |
| 288 | (setf cursor (+ prompt-length content-length)) | |
| 289 | (format stream "~%~A ~A" prompt content))))))) | |
| 274 | (format stream "~%~A- ~A" prompt contents)) | |
| 275 | (t | |
| 276 | (format stream "~%~A-" prompt) | |
| 277 | (do* ((cursor prompt-length) | |
| 278 | (contents (split-string contents) (cdr contents)) | |
| 279 | (content (car contents) (car contents)) | |
| 280 | (content-length (1+ (the fixnum (length content))) | |
| 281 | (1+ (the fixnum (length content))))) | |
| 282 | ((null contents)) | |
| 283 | (declare (type fixnum content-length)) | |
| 284 | (cond ((< (+ cursor content-length) width) | |
| 285 | (incf cursor content-length) | |
| 286 | (format stream " ~A" content)) | |
| 287 | (t | |
| 288 | (setf cursor (+ prompt-length content-length)) | |
| 289 | (format stream "~%~A ~A" prompt content))))))) | |
| 290 | 290 | (finish-output stream)) |
| 291 | 291 | |
| 292 | 292 | ;;; number-to-string |
| 293 | 293 | ;;; |
| 294 | 294 | (defun number-to-string (number &optional (base 10)) |
| 295 | 295 | (declare (type fixnum number) |
| 296 | (type fixnum base)) | |
| 296 | (type fixnum base)) | |
| 297 | 297 | (cond ((zerop number) "0") |
| 298 | ((eql number 1) "1") | |
| 299 | (t | |
| 300 | (do* ((len (1+ (truncate (log number base)))) | |
| 301 | (res (make-string len)) | |
| 302 | (i (1- len) (1- i)) | |
| 303 | (q number) ; quotient | |
| 304 | (r 0)) ; residue | |
| 305 | ((zerop q) ; nothing left | |
| 306 | res) | |
| 307 | (declare (simple-string res) | |
| 308 | (fixnum len i r)) | |
| 309 | (multiple-value-setq (q r) (truncate q base)) | |
| 310 | (setf (schar res i) | |
| 311 | (schar "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ" r)))))) | |
| 298 | ((eql number 1) "1") | |
| 299 | (t | |
| 300 | (do* ((len (1+ (truncate (log number base)))) | |
| 301 | (res (make-string len)) | |
| 302 | (i (1- len) (1- i)) | |
| 303 | (q number) ; quotient | |
| 304 | (r 0)) ; residue | |
| 305 | ((zerop q) ; nothing left | |
| 306 | res) | |
| 307 | (declare (simple-string res) | |
| 308 | (fixnum len i r)) | |
| 309 | (multiple-value-setq (q r) (truncate q base)) | |
| 310 | (setf (schar res i) | |
| 311 | (schar "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ" r)))))) | |
| 312 | 312 | |
| 313 | 313 | ;;; null-string |
| 314 | 314 | ;;; Returns T if STRING is the null string \"\" between START and END. |
| 327 | 327 | ;;; of returning EOF-VALUE. |
| 328 | 328 | |
| 329 | 329 | ;; (declaim (function read-delimited-string (list stream atom t) |
| 330 | ;; (values string t character))) | |
| 330 | ;; (values string t character))) | |
| 331 | 331 | |
| 332 | 332 | (defun read-delimited-string (delimiters &optional (stream *standard-input*) |
| 333 | (eof-error-p t) eof-value) | |
| 333 | (eof-error-p t) eof-value) | |
| 334 | 334 | (declare (type list delimiters) |
| 335 | (type stream stream)) | |
| 335 | (type stream stream)) | |
| 336 | 336 | (let (char-list) |
| 337 | 337 | ;; (declare (dynamic-extent char-list)) |
| 338 | 338 | (do ((peeked-char (peek-char nil stream eof-error-p :eof) |
| 339 | (peek-char nil stream eof-error-p :eof))) | |
| 340 | ((or (member peeked-char delimiters) (eq peeked-char :eof)) | |
| 341 | (values (coerce (nreverse char-list) 'string) | |
| 342 | (if (eq peeked-char :eof) eof-value) peeked-char)) | |
| 339 | (peek-char nil stream eof-error-p :eof))) | |
| 340 | ((or (member peeked-char delimiters) (eq peeked-char :eof)) | |
| 341 | (values (coerce (nreverse char-list) 'string) | |
| 342 | (if (eq peeked-char :eof) eof-value) peeked-char)) | |
| 343 | 343 | (push (read-char stream t) |
| 344 | ;; it should be good, else peek-char would have gotten the error. | |
| 345 | ;; so go for it. | |
| 346 | char-list)))) | |
| 344 | ;; it should be good, else peek-char would have gotten the error. | |
| 345 | ;; so go for it. | |
| 346 | char-list)))) | |
| 347 | 347 | |
| 348 | 348 | ;;; numeric-char-p |
| 349 | 349 | ;;; |
| 350 | 350 | (defmacro numeric-char-p (char) |
| 351 | 351 | `(let ((cc (char-code ,char))) |
| 352 | 352 | (and (>= cc (char-code #\0)) |
| 353 | (<= cc (char-code #\9))))) | |
| 353 | (<= cc (char-code #\9))))) | |
| 354 | 354 | |
| 355 | 355 | ;;; EOF |
| 0 | 0 | ;;;-*- Mode:LISP; Package:CHAOS; Base:10; Syntax:Common-lisp -*- |
| 1 | 1 | ;;; |
| 2 | ;;; Copyright (c) 2000-2014, Toshimi Sawada. All rights reserved. | |
| 2 | ;;; Copyright (c) 2000-2015, Toshimi Sawada. All rights reserved. | |
| 3 | 3 | ;;; |
| 4 | 4 | ;;; Redistribution and use in source and binary forms, with or without |
| 5 | 5 | ;;; modification, are permitted provided that the following conditions |
| 72 | 72 | |
| 73 | 73 | (defun augm-tree-int-node? (x) |
| 74 | 74 | (declare (type list x) |
| 75 | (values (or null t))) | |
| 75 | (values (or null t))) | |
| 76 | 76 | (null (car x))) |
| 77 | 77 | |
| 78 | 78 | (defun augm-tree-pad? (x) |
| 1739 | 1739 | |
| 1740 | 1740 | |
| 1741 | 1741 | |
| 1742 | VMINOR=.3 | |
| 1742 | VMINOR=.4rc1 | |
| 1743 | 1743 | VMEMO=PigNose0.99 |
| 1744 | 1744 | PATCHLEVEL= |
| 1745 | 1745 | |
| 2648 | 2648 | |
| 2649 | 2649 | |
| 2650 | 2650 | |
| 2651 | ac_config_files="$ac_config_files Makefile make-cafeobj.lisp version.lisp xbin/cafeobj.in doc/refman/Makefile doc/manual/Makefile doc/RefCard/Makefile doc/PigNose/Makefile" | |
| 2651 | ac_config_files="$ac_config_files Makefile make-cafeobj.lisp version.lisp xbin/cafeobj.in doc/refman/Makefile doc/manual/Makefile doc/RefCard/Makefile doc/PigNose/Makefile doc/citp-manual/Makefile" | |
| 2652 | 2652 | |
| 2653 | 2653 | cat >confcache <<\_ACEOF |
| 2654 | 2654 | # This file is a shell script that caches the results of configure |
| 3366 | 3366 | "doc/manual/Makefile") CONFIG_FILES="$CONFIG_FILES doc/manual/Makefile" ;; |
| 3367 | 3367 | "doc/RefCard/Makefile") CONFIG_FILES="$CONFIG_FILES doc/RefCard/Makefile" ;; |
| 3368 | 3368 | "doc/PigNose/Makefile") CONFIG_FILES="$CONFIG_FILES doc/PigNose/Makefile" ;; |
| 3369 | "doc/citp-manual/Makefile") CONFIG_FILES="$CONFIG_FILES doc/citp-manual/Makefile" ;; | |
| 3369 | 3370 | |
| 3370 | 3371 | *) as_fn_error $? "invalid argument: \`$ac_config_target'" "$LINENO" 5;; |
| 3371 | 3372 | esac |
| 0 | 0 | dnl configure.ac for Chaos(CafeOBJ) |
| 1 | 1 | dnl apply autoconf to this file for producing a configure script. |
| 2 | 2 | dnl |
| 3 | dnl Copyright (c) 2000-2014, Toshimi Sawada. All rights reserved. | |
| 4 | dnl Copyright (c) 2014 Norbert Preining. All rights reserved. | |
| 3 | dnl Copyright (c) 2000-2015, Toshimi Sawada. All rights reserved. | |
| 4 | dnl Copyright (c) 2014-2015, Norbert Preining. All rights reserved. | |
| 5 | 5 | dnl |
| 6 | 6 | dnl Redistribution and use in source and binary forms, with or without |
| 7 | 7 | dnl modification, are permitted provided that the following conditions |
| 31 | 31 | AC_INIT([CafeOBJ],[1.5], [], [cafeobj], [http://www.cafeobj.org/]) |
| 32 | 32 | AC_CONFIG_SRCDIR([make-cafeobj.lisp.in]) |
| 33 | 33 | AC_PREREQ(2.6) |
| 34 | VMINOR=.3 | |
| 34 | VMINOR=.4rc1 | |
| 35 | 35 | VMEMO=PigNose0.99 |
| 36 | 36 | PATCHLEVEL= |
| 37 | 37 | AC_SUBST(VMINOR) |
| 356 | 356 | doc/manual/Makefile |
| 357 | 357 | doc/RefCard/Makefile |
| 358 | 358 | doc/PigNose/Makefile |
| 359 | doc/citp-manual/Makefile | |
| 359 | 360 | ]) |
| 360 | 361 | AC_OUTPUT() |
| 0 | 0 | ;;; -*- Mode: LISP; Syntax: Common-Lisp -*- |
| 1 | 1 | ;;; |
| 2 | ;;; Copyright (c) 2000-2014, Toshimi Sawada. All rights reserved. | |
| 2 | ;;; Copyright (c) 2000-2015, Toshimi Sawada. All rights reserved. | |
| 3 | 3 | ;;; |
| 4 | 4 | ;;; Redistribution and use in source and binary forms, with or without |
| 5 | 5 | ;;; modification, are permitted provided that the following conditions |
| 31 | 31 | ) |
| 32 | 32 | (defun make-app (path) |
| 33 | 33 | (generate-application "CafeOBJ" |
| 34 | #-:mswindows | |
| 35 | "dumps/acl-standalone/" | |
| 36 | #+:mswindows | |
| 37 | "dist/cafeobj-1.5/" | |
| 38 | '("pignose.fasl" | |
| 39 | :emacs | |
| 40 | :eli | |
| 41 | :sock | |
| 42 | :process | |
| 43 | :acldns | |
| 44 | :collate | |
| 45 | :euc | |
| 46 | :ffcompat | |
| 47 | :list2 | |
| 48 | :fileutil | |
| 49 | :foreign | |
| 50 | :trace | |
| 51 | :hmac | |
| 52 | :locale | |
| 53 | :regexp2 | |
| 54 | #-:mswindows :sigio | |
| 55 | :ssl | |
| 56 | :streama | |
| 57 | :streamm | |
| 58 | :streamc | |
| 59 | :streamp) | |
| 60 | :application-type :exe | |
| 61 | :print-startup-message nil | |
| 62 | :allow-existing-directory t | |
| 63 | :copy-shared-libraries t | |
| 64 | :read-init-files nil | |
| 65 | :restart-app-function 'chaos::cafeobj-top-level | |
| 66 | ;; :restart-init-function 'chaos::chaos-init-fun | |
| 67 | :runtime :standard | |
| 68 | :suppress-allegro-cl-banner t | |
| 69 | :runtime-bundle t | |
| 70 | :include-compiler nil | |
| 71 | ;; :record-source-file-info nil | |
| 72 | ;; :record-xref-info nil | |
| 73 | ;; :load-source-file-info nil | |
| 74 | ;; :load-xref-info nil | |
| 75 | ;; :load-local-names-info nil | |
| 76 | :autoload-warning t | |
| 77 | :discard-local-name-info t | |
| 78 | :discard-source-file-info t | |
| 79 | ;; :discard-xref-into t | |
| 80 | :discard-arglists t | |
| 81 | :application-administration | |
| 82 | '(#+:mswindows | |
| 83 | (:batch-file "cafeobj.bat") | |
| 84 | ) | |
| 85 | )) | |
| 34 | #-:mswindows | |
| 35 | "dumps/acl-standalone/" | |
| 36 | #+:mswindows | |
| 37 | "dist/cafeobj-1.5/" | |
| 38 | '("pignose.fasl" | |
| 39 | :emacs | |
| 40 | :eli | |
| 41 | :sock | |
| 42 | :process | |
| 43 | :acldns | |
| 44 | :collate | |
| 45 | :euc | |
| 46 | :ffcompat | |
| 47 | :list2 | |
| 48 | :fileutil | |
| 49 | :foreign | |
| 50 | :trace | |
| 51 | :hmac | |
| 52 | :locale | |
| 53 | :regexp2 | |
| 54 | #-:mswindows :sigio | |
| 55 | :ssl | |
| 56 | :streama | |
| 57 | :streamm | |
| 58 | :streamc | |
| 59 | :streamp) | |
| 60 | :application-type :exe | |
| 61 | :print-startup-message nil | |
| 62 | :allow-existing-directory t | |
| 63 | :copy-shared-libraries t | |
| 64 | :read-init-files nil | |
| 65 | :restart-app-function 'chaos::cafeobj-top-level | |
| 66 | ;; :restart-init-function 'chaos::chaos-init-fun | |
| 67 | :runtime :standard | |
| 68 | :suppress-allegro-cl-banner t | |
| 69 | :runtime-bundle t | |
| 70 | :include-compiler nil | |
| 71 | ;; :record-source-file-info nil | |
| 72 | ;; :record-xref-info nil | |
| 73 | ;; :load-source-file-info nil | |
| 74 | ;; :load-xref-info nil | |
| 75 | ;; :load-local-names-info nil | |
| 76 | :autoload-warning t | |
| 77 | :discard-local-name-info t | |
| 78 | :discard-source-file-info t | |
| 79 | ;; :discard-xref-into t | |
| 80 | :discard-arglists t | |
| 81 | :application-administration | |
| 82 | '(#+:mswindows | |
| 83 | (:batch-file "cafeobj.bat") | |
| 84 | ) | |
| 85 | )) | |
| 86 | 86 | |
| 87 | 87 | (eval-when (eval load) |
| 88 | 88 | (make-app nil)) |
| 0 | (load "sysdef.asd") | |
| 1 | (load "cl-ppcre/cl-ppcre.asd") | |
| 2 | (asdf:oos 'asdf:load-op :cl-ppcre) | |
| 3 | (asdf:oos 'asdf:load-op 'chaosx) | |
| 4 | (in-package :chaos) | |
| 5 | (set-cafeobj-libpath "/usr/local/share/cafeobj-1.5")⏎ |
| 0 | 0 | ;;; |
| 1 | ;;; Copyright (c) 2000-2014, Toshimi Sawada. All rights reserved. | |
| 1 | ;;; Copyright (c) 2000-2015, Toshimi Sawada. All rights reserved. | |
| 2 | 2 | ;;; |
| 3 | 3 | ;;; Redistribution and use in source and binary forms, with or without |
| 4 | 4 | ;;; modification, are permitted provided that the following conditions |
| 24 | 24 | ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS |
| 25 | 25 | ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. |
| 26 | 26 | ;;; |
| 27 | ;;; defsystem | |
| 28 | ;;:ld sysdef | |
| 29 | ;; (mk:compile-system :chaosx) --or -- | |
| 30 | (require :asdf) | |
| 31 | (load "cl-ppcre/cl-ppcre.asd") | |
| 32 | (asdf:oos 'asdf:load-op :cl-ppcre) | |
| 33 | (load "sysdef.cl") | |
| 34 | (excl:compile-system :chaosx :recompile t) | |
| 35 | (in-package :chaos) | |
| 36 | (set-cafeobj-libpath "/usr/local/cafeobj-1.4") | |
| 37 | (cafeobj) | |
| 27 | ||
| 28 | ;;; HOW TO compile the system by hand. | |
| 29 | ||
| 30 | ; way 1 : use asdf, can be used in all supported Lisp platforms. | |
| 31 | ;(require :asdf) | |
| 32 | ;(load "cl-ppcre/cl-ppcre.asd") | |
| 33 | ;(asdf:oos 'asdf:load-op :cl-ppcre) | |
| 34 | ||
| 35 | ; way 2 : if you are using Allgegro, you can also do this way | |
| 36 | ;(load "sysdef.cl") | |
| 37 | ;(excl:compile-system :chaosx :recompile t) | |
| 38 | ||
| 39 | ;;; Starting CafeOBJ interpreter. | |
| 40 | ||
| 41 | ; after comilation, the following invokes CafeOBJ intepreter | |
| 42 | ;(in-package :chaos) | |
| 43 | ; NOTE: specify the path to your installed CafeOBJ library | |
| 44 | ;(set-cafeobj-libpath "/usr/local/share/cafeobj-1.5") | |
| 45 | ;(cafeobj) | |
| 0 | ||
| 1 | citp.pdf: citp.tex | |
| 2 | xelatex citp | |
| 3 | xelatex citp | |
| 4 | xelatex citp | |
| 5 | ||
| 6 | clean: | |
| 7 | rm -f *.aux citp.log citp.toc citp.out | |
| 8 | ||
| 9 | distclean: | |
| 10 |
Binary diff not shown
| 0 | @article{Futatsugi:2012:PPS:2397725.2397950, | |
| 1 | author = {Futatsugi, Kokichi and Gin, Daniel and Ogata, Kazuhiro}, | |
| 2 | title = {Principles of proof scores in CafeOBJ}, | |
| 3 | journal = {Theor. Comput. Sci.}, | |
| 4 | issue_date = {December, 2012}, | |
| 5 | volume = {464}, | |
| 6 | month = dec, | |
| 7 | year = {2012}, | |
| 8 | issn = {0304-3975}, | |
| 9 | pages = {90--112}, | |
| 10 | numpages = {23}, | |
| 11 | url = {http://dx.doi.org/10.1016/j.tcs.2012.07.041}, | |
| 12 | doi = {10.1016/j.tcs.2012.07.041}, | |
| 13 | acmid = {2397950}, | |
| 14 | publisher = {Elsevier Science Publishers Ltd.}, | |
| 15 | address = {Essex, UK}, | |
| 16 | keywords = {Algebraic specifications, CafeOBJ, Proof scores, Term rewriting, Theorem proving}, | |
| 17 | } | |
| 18 |
| 0 | \begin{thebibliography}{1} | |
| 1 | ||
| 2 | \bibitem{Futatsugi:2012:PPS:2397725.2397950} | |
| 3 | Kokichi Futatsugi, Daniel Gin, and Kazuhiro Ogata. | |
| 4 | \newblock Principles of proof scores in cafeobj. | |
| 5 | \newblock {\em Theor. Comput. Sci.}, 464:90--112, December 2012. | |
| 6 | ||
| 7 | \end{thebibliography} |
Binary diff not shown
| 0 | % !TEX TS-program = xelatex | |
| 1 | % !TEX encoding = UTF-8 | |
| 2 | % 2015F1: CITP for CafeOBJ | |
| 3 | % toshi.swd@gmail.com | |
| 4 | % | |
| 5 | \documentclass[a4paper,oneside,10pt,here]{memoir} | |
| 6 | \usepackage[hscale=0.76,vscale=0.76]{geometry} | |
| 7 | \setlength{\parindent}{0.0cm} | |
| 8 | \setlength{\parskip}{1.4ex} | |
| 9 | \usepackage{graphicx} | |
| 10 | \usepackage{proof} | |
| 11 | \usepackage{fancyvrb} | |
| 12 | \usepackage{amssymb} | |
| 13 | \usepackage{bussproofs} | |
| 14 | %%% Japanese | |
| 15 | \usepackage{fontspec} | |
| 16 | \usepackage{indentfirst} | |
| 17 | \setmainfont[Mapping=tex-text]{M+ 2p regular} | |
| 18 | \setsansfont[Mapping=tex-text]{M+ 2c regular} | |
| 19 | \setmonofont[Mapping=tex-text]{M+ 2m medium} | |
| 20 | % \setmainfont[Ligatures=TeX]{Meiryo} | |
| 21 | % \setsansfont[Ligatures=TeX]{Hiragino Kaku Gothic ProN W3} | |
| 22 | % \setmonofont[Ligatures=TeX]{Osaka-Mono} | |
| 23 | \XeTeXlinebreaklocale "ja_JP" | |
| 24 | \XeTeXlinebreakskip=0em plus 0.1em minus 0.01em | |
| 25 | \XeTeXlinebreakpenalty=0 | |
| 26 | \renewcommand{\baselinestretch}{1.4} | |
| 27 | \settowidth{\parindent}{あ} | |
| 28 | %%%% | |
| 29 | \usepackage{dcolumn,hhline,colortbl} | |
| 30 | \usepackage[table]{xcolor} | |
| 31 | %%%%% 色付表 | |
| 32 | \newcolumntype{G}{% | |
| 33 | >{\columncolor[gray]{0.9}}c} | |
| 34 | \newcolumntype{O}{% | |
| 35 | >{\columncolor{orange}}c} | |
| 36 | \newcolumntype{M}{% | |
| 37 | >{\columncolor{green}}c} | |
| 38 | \newcolumntype{Y}{% | |
| 39 | >{\columncolor{yellow}}c} | |
| 40 | \newcolumntype{C}{% | |
| 41 | >{\columncolor{cyan}}c} | |
| 42 | %%%% hyperref | |
| 43 | %\usepackage[dvipdfm,colorlinks=true,linkcolor=blue]{hyperref} | |
| 44 | \usepackage[colorlinks=true,linkcolor=blue]{hyperref} | |
| 45 | ||
| 46 | \usepackage{tikz} | |
| 47 | \usetikzlibrary{arrows} | |
| 48 | ||
| 49 | %%%%%%%%%%syntax | |
| 50 | \makeatletter | |
| 51 | % terminal - used for terminal symbols, argument is characters appear in sf. | |
| 52 | \def\sym#1{\textsf{#1}\null} | |
| 53 | % nonterm - used for non terminal symbols, argument is characters typed with | |
| 54 | % italic face. | |
| 55 | \def\nonterm#1{\textit{#1}\null} | |
| 56 | %%%%% | |
| 57 | % syntax ... endsyntax | |
| 58 | \def\xstrut{\relax\ifmmode\copy\strutbox\else\unhcopy\strutbox\fi} | |
| 59 | \def\syntax{\syntaxoutnonbox\halign\bgroup | |
| 60 | \xstrut$\@lign##$\hfil &\hfil$\@lign{}##{}$\hfil | |
| 61 | &$\@lign##$\hfil &\qquad\@lign-- ##\hfil\cr} | |
| 62 | \def\endsyntax{\crcr\egroup$$ | |
| 63 | \global\@ignoretrue | |
| 64 | } | |
| 65 | \def\syntaxoutnonbox{\xleavevmode$$ | |
| 66 | \parskip=0pt\lineskip=0pt | |
| 67 | \def\\{\crcr}% Must have \def and not \let for nested alignments. | |
| 68 | \everycr={\noalign{\penalty10000}} | |
| 69 | \tabskip=0pt} | |
| 70 | \def\xleavevmode{\ifvmode\if@inlabel\indent\else\if@noskipsec\indent\else | |
| 71 | \if@nobreak\global\@nobreakfalse\everypar={}\fi | |
| 72 | {\parskip=0pt\noindent}\fi\fi\fi} | |
| 73 | \def\@but{\noalign{\nointerlineskip}} | |
| 74 | \def\alt{{\;|\;}} | |
| 75 | \def\seqof#1{\mbox{\textbf{\{}}\;{#1}\;\mbox{\textbf{\}}}} | |
| 76 | \def\optn#1{\textbf{[}\;{#1}\;\textbf{]}} | |
| 77 | \def\synindent{\;\;\;} | |
| 78 | %%%% | |
| 79 | \def\SP{\mathit{SP}} | |
| 80 | \def\PR{\mathtt{PR}} | |
| 81 | \def\Sig{\mathbb{S}\mathit{ig}} | |
| 82 | \def\tr{\mathtt{true}} | |
| 83 | \def\fs{\mathtt{false}} | |
| 84 | \makeatother | |
| 85 | %%% | |
| 86 | %%%% numbering | |
| 87 | %%% ToC down to susubsections | |
| 88 | \settocdepth{subsubsection} | |
| 89 | %%% Numbering down to sections | |
| 90 | \setsecnumdepth{subsection} | |
| 91 | %%% 名前定義を適当に | |
| 92 | \def\figurename{{図}} | |
| 93 | \def\tablename{表} | |
| 94 | \def\contentsname{目次} | |
| 95 | \def\listfigurename{図目次} | |
| 96 | \def\listtablename{表目次} | |
| 97 | \def\refname{参考文献} | |
| 98 | \def\bibname{参考文献} | |
| 99 | \def\indexname{索引} | |
| 100 | \def\appendixname{付録} | |
| 101 | %%%%%%%%%% Verbatim | |
| 102 | \DefineVerbatimEnvironment% | |
| 103 | {simplev}{Verbatim} | |
| 104 | {fontsize=\small} | |
| 105 | \DefineVerbatimEnvironment% | |
| 106 | {examplev}{Verbatim} | |
| 107 | {frame=leftline,fontsize=\small} | |
| 108 | %%%%%%%%%% | |
| 109 | \definecolor{shadecolor}{gray}{0.9} | |
| 110 | \newenvironment{vvtm}% | |
| 111 | {\parskip=0pt\lineskip=0pt\begin{center}\begin{minipage}{0.8\textwidth}\begin{snugshade}}% | |
| 112 | {\end{snugshade}\end{minipage}\end{center}} | |
| 113 | %%% | |
| 114 | \usepackage{float} | |
| 115 | \begin{document} | |
| 116 | \headstyles{default} | |
| 117 | \tightlists | |
| 118 | %\midsloppy | |
| 119 | \sloppy | |
| 120 | \raggedbottom | |
| 121 | \chapterstyle{ell} | |
| 122 | %%%%%%%% | |
| 123 | \frontmatter | |
| 124 | \pagestyle{empty} | |
| 125 | % 表紙 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% | |
| 126 | \title{CITP for CafeOBJ \\ | |
| 127 | ver. 1.0} | |
| 128 | \vfill | |
| 129 | \author{澤田 寿実\\ | |
| 130 | (株) 考作舎\\ | |
| 131 | tswd@kosakusha.com} | |
| 132 | \date{2015/10/1} | |
| 133 | \maketitle | |
| 134 | \vfill | |
| 135 | \begin{center} | |
| 136 | \includegraphics[scale=0.2]{kosakusha2_gray.pdf} | |
| 137 | \end{center} | |
| 138 | \vfill | |
| 139 | \thispagestyle{empty} | |
| 140 | \newpage | |
| 141 | %%%%%% | |
| 142 | \mainmatter | |
| 143 | \pagestyle{plain} | |
| 144 | \pagenumbering{arabic} | |
| 145 | % 構成 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% | |
| 146 | \tableofcontents | |
| 147 | \EnableBpAbbreviations | |
| 148 | \newpage | |
| 149 | \chapter{用語}\label{sec:terms} | |
| 150 | 本書は証明論について基礎的な知識を持つ CafeOBJ ユーザーを対象とした， | |
| 151 | CITP for CafeOBJ と呼ばれる証明譜支援システムの利用ガイドである． | |
| 152 | 本書で記述する CITP for CafeOBJ の機能は version 1.5.4 以降の | |
| 153 | CafeOBJ システムで利用可能である\footnote{最新版の CafeOBJ システムは http://cafeobj.org/download/ からダウンロード可能である)}． | |
| 154 | ||
| 155 | 表\ref{table:terms}に以下で使用するいくつかの用語の定義を示す． | |
| 156 | \begin{table} | |
| 157 | \caption{用語の定義} | |
| 158 | \label{table:terms} | |
| 159 | \begin{center} | |
| 160 | \begin{tabular}[htb]{|l|p{0.6\textwidth}|}\hline | |
| 161 | 用語 & 定義 \\\hline\hline | |
| 162 | 文(sentence) & 自由変数を含まない(条件付き)等式($t = t' if C$) あるいは、(条件付き)遷移規則 ($t \Rightarrow t'$)． | |
| 163 | CafeOBJ の等式宣言や遷移規則宣言のフォームで表記する． \\\hline | |
| 164 | 文脈(context) & 証明を実施するモジュール．CafeOBJ で提供されているコマンドには， | |
| 165 | ある特定のモジュールを対象としたコマンドが多数存在する． | |
| 166 | CITP for CafeOBJ で提供されるコマンドも多くがそうであり， | |
| 167 | それらのコマンドを使う際に，一々対象とするモジュールを指定するのは煩わしいために% | |
| 168 | 導入されたのが\textbf{文脈}という概念である． | |
| 169 | 文脈は ``select'' や ``open'' コマンドによって設定され， | |
| 170 | モジュールをパラメータとして持つコマンドの適用先を暗黙的に指定した--つまりパラメータを省略した際に適用先として% | |
| 171 | 採用されるモジュール--となる． | |
| 172 | \\\hline | |
| 173 | ゴール(goal) & 四つ組 $<M,G,C,H>$． 文脈($M$)とそこで証明したい文の集合($G$)， | |
| 174 | 証明に際して使用した戦略(tactic)により導入された定数(constants)の集合($C$)と | |
| 175 | 仮定(hypothesis)$H$(文の集合)．単に証明対象とする文(の集合)をゴールと呼ぶことがある．\\\hline | |
| 176 | 戦略(tactic) & 証明で用いる演繹規則およびそれらを組み合わせたものを戦略(tactic)と呼ぶ．\\\hline | |
| 177 | 基底項(ground term) & 変数を含まない項. \\\hline | |
| 178 | \end{tabular} | |
| 179 | \end{center} | |
| 180 | \end{table} | |
| 181 | ||
| 182 | ||
| 183 | \chapter{CITP for CafeOBJ のコマンド}\label{chap:new-commands} | |
| 184 | 本章では CITP for CafeOBJ で提供されるコマンドの挙動について述べる． | |
| 185 | 厳密な動作の理解のためには参考文献を参照されたい． | |
| 186 | \section{証明の開始(ゴールの設定)} \label{sec:start-proof} | |
| 187 | ある特定のモジュール $M$ を文脈として，その中で証明したい文の集合 $G$ がすべて成立することを% | |
| 188 | 演繹規則(戦略)を順次適用することによって証明することが本システムの目標である． | |
| 189 | ||
| 190 | \begin{itemize} | |
| 191 | \item 証明を開始するには，証明を行う文脈を設定し，次いで証明したい文の集合を宣言する．\\ | |
| 192 | 文脈の設定は，既存の CafeOBJ コマンド \verb|select <ModuleExpression> .| あるいは \verb|open <ModuleExpression> .| | |
| 193 | によって行う． | |
| 194 | \item 証明を実施する文脈の設定後，下に示す \verb|:goal| コマンドによって証明したい文の集合を指定する．\\ | |
| 195 | \begin{vvtm} | |
| 196 | \begin{simplev} | |
| 197 | goal コマンド ::= :goal { <sentence> . ... <sentence> . } | |
| 198 | \end{simplev} | |
| 199 | \end{vvtm} | |
| 200 | \end{itemize} | |
| 201 | \verb|sentence| は，CafeOBJ の(条件付き)等式あるいは(条件付き)遷移規則のいずれかで表記する． | |
| 202 | ||
| 203 | ||
| 204 | \subsubsection{文脈とゴールの設定例} | |
| 205 | %\begin{vvtm} | |
| 206 | \begin{examplev} | |
| 207 | select CLOUD . | |
| 208 | :goal { | |
| 209 | ceq [inv1 :nonexec]: true = false if statusp(S:Sys,I:Client) = updated /\ | |
| 210 | statusc(S:Sys)= idlec . | |
| 211 | ceq [inv2 :nonexec]: true = false if statusp(S:Sys,I:Client) = gotval /\ | |
| 212 | statusc(S:Sys)= idlec . | |
| 213 | ceq [inv3 :nonexec]: true = false if statusp(S:Sys,J:Client) = updated /\ | |
| 214 | statusp(S:Sys,I:Client) = gotval . | |
| 215 | ceq [inv4 :nonexec]: true = false if (I:Client ~ J:Client) = false /\ | |
| 216 | statusp(S:Sys,J:Client) = gotval /\ | |
| 217 | statusp(S:Sys,I:Client) = gotval . | |
| 218 | ceq [inv5 :nonexec]: true = false if (I:Client ~ J:Client) = false /\ | |
| 219 | statusp(S:Sys,J:Client)= updated /\ statusp(S:Sys,I:Client)= updated .} | |
| 220 | \end{examplev} | |
| 221 | %\end{vvtm} | |
| 222 | ||
| 223 | \section{証明木の構造}\label{sec:proof-struct} | |
| 224 | ここでは他のコマンドを説明する前に，CITP for CafeOBJ の構成する | |
| 225 | 証明木(proof tree)の構造について説明する． | |
| 226 | ||
| 227 | 証明木は全体としてゴールをノードとする有向の木構造(directed tree structure)を持ち， | |
| 228 | 各枝(branch)はゴールに対して適用した戦略をラベル(label)が付加されている． | |
| 229 | あるゴール$G$に対してある戦略$T$を適用すると， | |
| 230 | 一般的に複数のゴール$G_1, G_2, \ldots, G_n$ が生成されるが， | |
| 231 | これら $G_i$ をもとのゴールの子ゴールと呼ぶ． | |
| 232 | $G$ から各 $G_i (i = 1 \cdots n)$ への枝は，全て適用した戦略$T$によるラベル $T$を持つ． | |
| 233 | ||
| 234 | 以下この一般的な証明木の構造をより具体的に述べる． | |
| 235 | 以下では，ゴールと証明木のノードを区別せずに用いる． | |
| 236 | ||
| 237 | \begin{itemize} | |
| 238 | \item :goal コマンドによって設定されたゴールを初期ゴールとする． | |
| 239 | \item あるノード(ゴール)に対して戦略 $T$ の適用によって新たなゴールが生成された場合， | |
| 240 | それらをそのノードの子ノードとする．これら子ノードへの枝はラベル $T$ を持つ． | |
| 241 | \item 各ゴールには次のように名前が付加される: | |
| 242 | \begin{itemize} | |
| 243 | \item 初期ゴールには root という名前が付けられる． | |
| 244 | \item root 直下のゴールには自然数 $1, 2, \ldots ,n$ と名前が付けられる． | |
| 245 | \item 以下，あるゴールの名称が N であったとすると，そのゴールには | |
| 246 | N-1, N-2, $\ldots$ N-m のように名前が付けられる． | |
| 247 | \end{itemize} | |
| 248 | \end{itemize} | |
| 249 | \begin{figure}[hbt] | |
| 250 | \centering | |
| 251 | %\includegraphics[scale=1.0]{proof-tree.pdf} | |
| 252 | \input proof-tree.tikz | |
| 253 | \caption{証明木} | |
| 254 | \label{fig:proof-tree} | |
| 255 | \end{figure} | |
| 256 | ||
| 257 | このような構造を持つ証明木において，\textbf{ゴールが証明される}とは以下の事を言う: | |
| 258 | \begin{itemize} | |
| 259 | \item あるゴールの子ゴールが全て証明されたとき，そのゴールも証明される | |
| 260 | \item ここで\textbf{証明される}とは以下の事を言う | |
| 261 | \begin{enumerate} | |
| 262 | \item 文が充足(satisfied)された場合，あるいは | |
| 263 | \item 矛盾(contradiction)が発見される: すなわち | |
| 264 | \begin{itemize} | |
| 265 | \item その文脈において true = false が演繹可能(deducible)となる | |
| 266 | \item 遷移的な関係で矛盾が生ずる．例えば $X < Y < Z$ の時に | |
| 267 | $Z \le Y$ が演繹できる． | |
| 268 | \end{itemize} | |
| 269 | \end{enumerate} | |
| 270 | これらのいずれかが成立した時，そのゴールに含まれる当該文はゴールから | |
| 271 | 取り去られる (dischage されると言う)． | |
| 272 | ゴールから証明対象の文がすべてなくなった時，そのゴールは証明されたと言う． | |
| 273 | \end{itemize} | |
| 274 | ||
| 275 | \section{戦略の適用}\label{sec:apply} | |
| 276 | ||
| 277 | \begin{itemize} | |
| 278 | \item 初期ゴールが設定された後では，:apply コマンドによって，指定の戦略をゴールに適用できるようになる． | |
| 279 | ゴールが設定されていない場合，:apply コマンドの適用はエラーとして扱われる． | |
| 280 | \item 構文 | |
| 281 | \begin{vvtm} | |
| 282 | \begin{simplev} | |
| 283 | apply コマンド ::= :apply [ to <GoalName> : ] (<Tactic> ... <Tactic> ) | |
| 284 | <GoalName> ::= ゴールに付与された名前 | |
| 285 | <Tactic> ::= SI | CA | TC | IP | RD | <DefinedTactic> | |
| 286 | \end{simplev} | |
| 287 | \end{vvtm} | |
| 288 | ||
| 289 | \item \verb|<Tactic>| の指定で，大文字と小文字の区別はしない． | |
| 290 | \item \verb|to <GoalName>| が省略された場合は，現在のデフォルトゴール(後述)に対して適用される． | |
| 291 | \item \verb|<DefinedTactic>| は\ref{sec:def-command}章で説明する \verb|:def| コマンドによって定義された戦略の名前である． | |
| 292 | \end{itemize} | |
| 293 | ||
| 294 | \subsection{戦略}\label{sec:predefined-tactics} | |
| 295 | CITP for CafeOBJ で提供される戦略を表~\ref{tab:tactics} に示す． | |
| 296 | 各戦略の具体的な挙動については，\ref{sec:tactic-behaviour}章で説明する． | |
| 297 | ||
| 298 | \begin{table} | |
| 299 | \label{tab:tactics} | |
| 300 | \caption{戦略一覧} | |
| 301 | \begin{center} | |
| 302 | \begin{tabular}[htbp]{|l|l|}\hline | |
| 303 | 戦略名 & 演繹規則 \\\hline\hline | |
| 304 | SI & Simultaneous Induction (同時帰納法) \\\hline | |
| 305 | CA & Case Analysis (場合分け)\\\hline | |
| 306 | TC & Theorem of Constants \\\hline | |
| 307 | IP & Implication (含意)\\\hline | |
| 308 | RD & Reduction (簡約化) \\\hline | |
| 309 | \end{tabular} | |
| 310 | \end{center} | |
| 311 | \end{table} | |
| 312 | ||
| 313 | \subsection{戦略の適用順序}\label{sec:order-of-tatic-application} | |
| 314 | ||
| 315 | \begin{figure}[htbp] | |
| 316 | \begin{center} | |
| 317 | \includegraphics[scale=0.4]{apply-order.pdf} | |
| 318 | \end{center} | |
| 319 | \caption{戦略の適用順序} | |
| 320 | \label{fig:apply-tactic} | |
| 321 | \end{figure} | |
| 322 | 図~\ref{fig:apply-tactic} に，あるゴール $n$ に対して一連の戦略 $T_1 T_2 \ldots T_n$ を | |
| 323 | 適用した際に，これらの戦略がどのように適用されるかを示す． | |
| 324 | 一般にある戦略 $T_i$ をゴール $N$ に適用した場合，戦略によって複数のゴールが生成される． | |
| 325 | :apply コマンドに一連の戦略 $T_1 T_2 \ldots T_n$ が指定され，ゴール $N$ に適用されたとする． | |
| 326 | このとき最初の戦略 $T_1$ によって複数の小ゴール $N_1 \ldots N_m$ が生成されたとした時， | |
| 327 | 次の戦略 $T_2$ はこれらの小ゴール全てに対して適用される．以下同様である． | |
| 328 | ||
| 329 | \subsection{自動戦略} \label{sec:tactic-auto} | |
| 330 | 経験則から一般的に有効(うまく証明ができることが多い)と考える事のできる一連の戦略を予め用意し， | |
| 331 | これを簡便に使用できると便利である． | |
| 332 | このためにコマンド :auto が用意されている． | |
| 333 | ||
| 334 | \begin{itemize} | |
| 335 | \item 構文: | |
| 336 | \begin{vvtm} | |
| 337 | \begin{simplev} | |
| 338 | auto コマンド ::= :auto | |
| 339 | \end{simplev} | |
| 340 | \end{vvtm} | |
| 341 | \item \verb|:auto| は \verb|:apply (SI CA TC IP RD) | と等価である． | |
| 342 | \end{itemize} | |
| 343 | ||
| 344 | \section{ターゲット・ゴール}\label{sec:default-goal} | |
| 345 | :apply コマンドは戦略を適用するゴールの引数を省略することができる(\ref{sec:apply})． | |
| 346 | この時，指定した戦略の適用対象となるゴールを\textbf{ターゲット・ゴール}と呼ぶ． | |
| 347 | システムはこれを次の規則によって決定する． | |
| 348 | \begin{itemize} | |
| 349 | \item 初期のゴールが \verb|:goal| コマンドによって設定された直後は | |
| 350 | \verb|root| がターゲット・ゴールである． | |
| 351 | \item ある戦略をゴールに適用した後は，証明木の構造上最も左の | |
| 352 | 末端ノードがターゲット・ゴールとなる． | |
| 353 | \end{itemize} | |
| 354 | ||
| 355 | ターゲット・ゴールは :apply コマンドの暗黙的な対象となるゴールだけでなく， | |
| 356 | ゴールを引数に持つコマンドで，それが省略された際に% | |
| 357 | 適用対象とするゴールとして扱われる． | |
| 358 | ||
| 359 | \subsection{ターゲット・ゴールの指定} | |
| 360 | ターゲット・ゴールは，\verb|:select| コマンドによって設定することが可能である． | |
| 361 | \begin{itemize} | |
| 362 | \item 構文: | |
| 363 | \begin{vvtm} | |
| 364 | \begin{simplev} | |
| 365 | :select コマンド ::= :select <GoalName> | |
| 366 | \end{simplev} | |
| 367 | \end{vvtm} | |
| 368 | \end{itemize} | |
| 369 | \verb|:select| コマンドで指定されたゴールが子ゴールを持っていた場合， | |
| 370 | それらの子ゴールは証明木から削除される． | |
| 371 | \begin{figure}[hbt] | |
| 372 | \centering | |
| 373 | \input selected.tikz | |
| 374 | \caption{:select} | |
| 375 | \label{fig:selected-proof-tree} | |
| 376 | \end{figure} | |
| 377 | 図\ref{fig:selected-proof-tree} はゴール1-1がターゲット・ゴールとなっている状態で | |
| 378 | \verb|:select| コマンドでゴール2を指定した結果ゴール2がターゲット・ゴールとなり | |
| 379 | それまでゴール2の子ゴールだった既存のゴール2-1と2-2が削除された様子を示したものである． | |
| 380 | ||
| 381 | \section{各戦略の挙動}\label{sec:tactic-behaviour} | |
| 382 | 本章では先に述べた各戦略の挙動について述べる． | |
| 383 | ||
| 384 | \subsection{SI: Simultaneous Induction}\label{sec:SI} | |
| 385 | ||
| 386 | \begin{prooftree} | |
| 387 | \AXC{$\{\SP\vdash^{sp} (\forall Y)\theta(\varepsilon)\;|\; \theta : X \rightarrow T_{\Sigma^{c}}, Y : \mathtt{finite}\}$} | |
| 388 | \LeftLabel{[conAbst]} | |
| 389 | \UIC{$\SP\vdash^{sp} (\forall X)\varepsilon$} | |
| 390 | \end{prooftree} | |
| 391 | ここで $\Sigma = \Sig(\SP)$，$\Sigma^{c}\subset\Sigma$ は構成子からなる部分シグニチャである． | |
| 392 | また $\theta : X\rightarrow T_{\Sigma^{c}}(Y)$ は $\Sig(\SP)$-置換である． | |
| 393 | 上の規則はもし $\varepsilon$ が $X$ に含まれる変数の全ての可能な% | |
| 394 | instantiationについて成り立つなら $(\forall X)\varepsilon$ が成り立つことを意味する． | |
| 395 | ||
| 396 | [conAbst] は実用的な観点からは使用するのが難しい． | |
| 397 | 何故ならルールのインスタンスが無限にあり得るからである． | |
| 398 | その代わりに下の帰納的演繹によってこれを模倣する事が出来る． | |
| 399 | ||
| 400 | \begin{prooftree} | |
| 401 | \AXC{$\SP' =_{def} \PR(\SP,\{\{x\}_{s}\}) \cup \{(\forall\{\})\varepsilon\}$} | |
| 402 | \noLine | |
| 403 | \UIC{$\SP' \vdash (\forall Z^{f})\varepsilon[x\leftarrow f(z_1,\ldots,z_{i-1},x,z_{i+1},\ldots z_n)]\;\; f\in F^{c}_{*s}\}$} | |
| 404 | \LeftLabel{[Ind]} | |
| 405 | \UIC{$\SP\vdash^{sp}(\forall\{\{x\}_{s}\})\varepsilon$} | |
| 406 | \end{prooftree} | |
| 407 | \begin{itemize} | |
| 408 | \item [Ind]は構成子ベースの帰納的演繹を定式化したものである． | |
| 409 | \end{itemize} | |
| 410 | ||
| 411 | \begin{itemize} | |
| 412 | \item 戦略 SI は上の Ind を複数の帰納変数に対して同時に適用可能なよう拡張したものである． | |
| 413 | 指定した帰納変数(induction variables)に対して以下を行う． | |
| 414 | \begin{itemize} | |
| 415 | \item ベースケース | |
| 416 | \item 帰納法の仮定+ステップケース | |
| 417 | \end{itemize} | |
| 418 | それぞれに対応した新たなゴールを生成する | |
| 419 | \item induction variables は \verb|:ind on| コマンドによって指定する． | |
| 420 | \begin{vvtm} | |
| 421 | \begin{simplev} | |
| 422 | :ind コマンド ::= :ind on ( <変数> ... ) | |
| 423 | \end{simplev} | |
| 424 | \end{vvtm} | |
| 425 | \verb|<変数>| は on-the-fly の変数宣言形式で指定する． | |
| 426 | \item \verb|:ind| コマンドで指定した変数に対応するソートが，構成子を | |
| 427 | 持たないソートであった場合はエラーとする． | |
| 428 | \item 帰納法の仮定や，証明対象とするステップケースの文では， | |
| 429 | 帰納法による定数が必要となるが，それらは次のようにして生成する． | |
| 430 | \begin{itemize} | |
| 431 | \item \verb|帰納変数名#ソート名| という名前のオペレータを導入 | |
| 432 | \item このオペレータを用いて(定数)項を生成する | |
| 433 | \end{itemize} | |
| 434 | 例えば，帰納変数として \verb|I:Foo| が指定された場合， | |
| 435 | 導入される定数名は \verb|I#<ソート名>| となる． | |
| 436 | <ソート名> は文脈に応じて適切なソートが選択される． | |
| 437 | \end{itemize} | |
| 438 | ||
| 439 | \subsection{TC: Theorem of Constants}\label{sec:TC} | |
| 440 | \begin{prooftree} | |
| 441 | \AXC{$\PR(\SP,Y)\vdash^{sp} (\forall\{\})\varepsilon$} | |
| 442 | \LeftLabel{[TC]} | |
| 443 | \UIC{$\SP\vdash^{sp}(\forall Y)\varepsilon$} | |
| 444 | \end{prooftree} | |
| 445 | ||
| 446 | この演繹規則は全称的に束縛された変数に関する推論を行う際に， | |
| 447 | 定数を代わって使用しても良いとするものであり， | |
| 448 | 従来よりCafeOBJの書き換えエンジンを利用した証明で通常利用されている技法である． | |
| 449 | ||
| 450 | CITP CafeOBJ ではこの演繹規則に対応するものを戦略として提供する． | |
| 451 | [TC]によって新たに導入する定数名は，既存の定数名と衝突が無いように考慮し， | |
| 452 | 規則的に命名される． | |
| 453 | ||
| 454 | \begin{itemize} | |
| 455 | \item 適用先のゴールに複数の証明対象の文が含まれている場合は， | |
| 456 | それ毎に別々の小ゴールを作成し，分配する． | |
| 457 | \item 以下各ゴールに対して以下を実施する． | |
| 458 | \begin{itemize} | |
| 459 | \item 証明対象の文に含まれる変数を対応するソートの定数で置き換える | |
| 460 | \end{itemize} | |
| 461 | \item 定数は次のように新たなオペレータを導入することによって作成する | |
| 462 | \begin{itemize} | |
| 463 | \item \verb|変数名@ソート名| という名前のオペレータを導入 | |
| 464 | \item このオペレータを用いて(定数)項を生成する | |
| 465 | \end{itemize} | |
| 466 | 例えば，変数 X がソート Foo の変数であった場合，導入されるオペレータは | |
| 467 | \begin{verbatim} | |
| 468 | op X@Foo : -> Foo . | |
| 469 | \end{verbatim} | |
| 470 | のように宣言されたのと等価である． | |
| 471 | %%% spoiler \item 上記を実施した後，生成したゴールに対して暗黙的戦略 CT および ST を適用する． | |
| 472 | \end{itemize} | |
| 473 | ||
| 474 | \subsection{IP: Implication}\label{sec:IP} | |
| 475 | \begin{prooftree} | |
| 476 | \AXC{$(\Sigma,E\cup\{(\forall\{\})t_1=t'_1,\ldots,(\forall\{\})t_n=t'_n)\vdash^{sp}(\forall\{\}t=t')$} | |
| 477 | \LeftLabel{[IP]} | |
| 478 | \UIC{$(\Sigma,E)\vdash^{sp}(\forall\{\}) t = t'\; \mathtt{if}\; \{t_1=t'_1,\ldots,t_n=t'_n\}$} | |
| 479 | \end{prooftree} | |
| 480 | ||
| 481 | 条件付き等式で条件部が基底項の場合，それらを新たな公理として導入し， | |
| 482 | 条件部を取り去ったゴールを新たなゴールとしても良い事を [IP] は示している． | |
| 483 | ||
| 484 | [IP] についても CITP for CafeOBJ の提供する演繹規則として提供する． | |
| 485 | 条件部が複数の atom の連結 ($\wedge$ で結ばれた複数の条件)の場合は， | |
| 486 | それらを別々の複数の公理として導入する． | |
| 487 | ||
| 488 | \begin{itemize} | |
| 489 | \item 適用先のゴールに複数の証明対象の文が含まれている場合は， | |
| 490 | それ毎に別々の小ゴールを作成し，分配する． | |
| 491 | \item 以下，各ゴールに対して以下を実施する． | |
| 492 | \item 証明対象の文が \verb|ceq T = T' if C| または | |
| 493 | \verb|ctrans T => T' if C| の形，かつ | |
| 494 | \item C が基底項の場合に以下を行う | |
| 495 | \begin{itemize} | |
| 496 | \item \verb|C| を公理として追加 | |
| 497 | \item 元の証明対象から条件部を削除したものを新たな証明対象の文とする | |
| 498 | \item \verb|C| が複数の条件が \verb|c1 /\ c2 ... /\ cn| のように，\verb|/\| で | |
| 499 | 結合された形の場合は分離し，個々の \verb|c1| $\ldots$ \verb|cn| を | |
| 500 | 公理として導入する． | |
| 501 | \end{itemize} | |
| 502 | %%% spoiler \item 以上を実施した後，生成されたゴールに対して暗黙の戦略 CT および ST を適用する． | |
| 503 | \end{itemize} | |
| 504 | ||
| 505 | \subsection{CA: Case Analysis}\label{sec:CA} | |
| 506 | ||
| 507 | \begin{prooftree} | |
| 508 | \AXC{$\{\PR(\SP,Y) \cup \{ u = t\}\vdash^{sp} e\;|\; t\in T_{\Sigma^{c}}(Y)_{S_{c}}, Y:\mathtt{finite}\}$} | |
| 509 | \LeftLabel{[split]} | |
| 510 | \UIC{$\SP\vdash^{sp} e$} | |
| 511 | \end{prooftree} | |
| 512 | ||
| 513 | \begin{prooftree} | |
| 514 | \AXC{$\SP\cup\{u = \mathtt{true}\}\vdash^{sp} e$} | |
| 515 | \AXC{$\SP\cup\{u = \mathtt{false}\}\vdash^{sp} e$} | |
| 516 | \LeftLabel{[splitBool]} | |
| 517 | \BIC{$\SP\vdash^{sp} e$} | |
| 518 | \end{prooftree} | |
| 519 | ||
| 520 | これらは網羅的な場合分けの必要性について定式化したものである． | |
| 521 | これについては証明の文脈となっている仕様や% | |
| 522 | 証明の対象としている項により異なり，% | |
| 523 | 一般的な生成スキームを与える事は困難である． | |
| 524 | ||
| 525 | そのため，場合分けを実施する上での各ケースを利用者が公理によって明示的に指示し， | |
| 526 | システムがそれをベースに必要な場合分けを実施するものとする． | |
| 527 | この仕様は Maude の CITP システムに習ったものである． | |
| 528 | ||
| 529 | CA は次のように動作する: | |
| 530 | \begin{enumerate} | |
| 531 | \item 証明対象の文から基底項 $G_1, \ldots, G_n$ を取り出す． | |
| 532 | \item 文脈となっているモジュールから，ラベルとして先頭が ``CA'' で始まる | |
| 533 | 公理の集合 $Ac$ を求める． | |
| 534 | \item 各 $G_i (1\le i \le n)$ について，その真部分項が $Ac$ に含まれる公理の | |
| 535 | どの左辺とも照合しない基底項の集合 $Gs$ を得る． | |
| 536 | \item 各 $g_j \in Gs$ について，各 $(\mathtt{l\; =\; r\; if\; C}) \in Ac$ との間で | |
| 537 | 以下を計算する． | |
| 538 | \begin{enumerate} | |
| 539 | \item 基底項 $g_j$ に関するケースの集合 $C_j$ を空集合にセットする． | |
| 540 | \item $\sigma(g_j) = \mathtt{l}$ となる置換 $\sigma$ が存在したら， | |
| 541 | $\sigma(C)_j$ を $Cs_j$ に追加する． | |
| 542 | \end{enumerate} | |
| 543 | 各 $Cs_j$ は基底項 $g_j$ に関するケースの集合となっているので， | |
| 544 | これらの全ての組み合わせ $CS_1 \times S_2 \times \cdots\S_m$ を計算し， | |
| 545 | 全ての可能なケースの組み合わせを求める． | |
| 546 | \item 上で得られた各組み合わせごとに，新たな子ゴールを生成し， | |
| 547 | そのゴールへケースを公理として追加する． | |
| 548 | \end{enumerate} | |
| 549 | 冗長なケースの生成があり得るための，それらを検査して取り除く事は | |
| 550 | 実装に際して最適化の意味で実施するものとする． | |
| 551 | ||
| 552 | \begin{itemize} | |
| 553 | \item 上で述べた CA 処理を実施するする前に，適用対象のゴールに複数の | |
| 554 | 証明対象の文が含まれていたら，それらを個々の小ゴールに分配し， | |
| 555 | その後，上の CA 処理を実施する． | |
| 556 | %%%% spoiler | |
| 557 | % \item CA で生成された各ゴールに追加された公理については， | |
| 558 | % 暗黙的戦略 LE による整数の順序関係に関する矛盾の有無を検査し， | |
| 559 | % 矛盾が発見されたら直ちにそのゴールを discharge する． | |
| 560 | \end{itemize} | |
| 561 | ||
| 562 | \subsection{RD: Reduction}\label{sec:RD} | |
| 563 | ||
| 564 | 戦略 RD は，以下を実施する： | |
| 565 | \begin{enumerate} | |
| 566 | \item ゴール内で true = false が演繹可能かどうかを調べる． | |
| 567 | \begin{prooftree} | |
| 568 | \AXC{$\SP \vdash \tr \Rightarrow \fs$} | |
| 569 | \LeftLabel{[CT]} | |
| 570 | \UIC{$\SP \vdash \rho$} | |
| 571 | \end{prooftree} | |
| 572 | これが可能な場合，矛盾なのでゴールに含まれるすべての証明対象としている文を discharge する． | |
| 573 | \item ゴールに含まれる証明対象の文すべてについて以下を行う． | |
| 574 | ここで，証明対象の文を \texttt{ l = r if C} とする. | |
| 575 | \begin{enumerate} | |
| 576 | \item l，r あるいは C のどれかが基底項でなければなにもしない． | |
| 577 | これらのすべてが基底項の場合にのみ以下を実施する． | |
| 578 | \item 条件部 \texttt{C} の既約形(normal form)を求める． | |
| 579 | 結果が \texttt{true} ならば次へ進む(条件部が存在しない場合は \texttt{true} とみなされる）． | |
| 580 | 結果が \texttt{true} でなければ文はまだ成立しないとみなす． | |
| 581 | \item 文の左辺 \texttt{l} の規約形を求める． | |
| 582 | \item 文の右辺 \texttt{r} の規約形を求める． | |
| 583 | \item 左右両辺の既約形が「等しい」かどうかを調べる． | |
| 584 | ここで，等しいとは以下のことを言う： | |
| 585 | \begin{itemize} | |
| 586 | \item 項の形が同じ． | |
| 587 | \item 項のトップオペレータがセオリー属性(associative, commutative など)を持っていた場合， | |
| 588 | その意味で等しい． | |
| 589 | \end{itemize} | |
| 590 | \item 等しければ成立するとし，その文を discharge する．等しく無ければ成立しない，とする． | |
| 591 | \end{enumerate} | |
| 592 | \item ゴールに含まれるすべての文が discharge された場合，そのゴールは証明されたものとする． | |
| 593 | \end{enumerate} | |
| 594 | ||
| 595 | 他の戦略は証明できるかどうかを直接調べないが，戦略 RD はゴールが証明できるかどうかを上のようにして調べる． | |
| 596 | ||
| 597 | \section{:spoiler : 暗黙的 RD 適用の制御} \label{sec:spoiler-flag} | |
| 598 | ||
| 599 | \ref{sec:tactic-behaviour} でシステムに組み込みの各戦略の動作を述べた． | |
| 600 | RD 以外の戦略はその戦略に応じた新たな仮定を導入したりするなどするが， | |
| 601 | その結果ゴールに含まれる文が成立するかどうかは調べない． | |
| 602 | システムは \verb|:spoiler| という名称のフラグを持っており， | |
| 603 | これを on に設定することにより，戦略適用後の状態でゴールが証明可能かを% | |
| 604 | 調べるよう指示することができる． | |
| 605 | ただし戦略 SI はこの対象外であり， | |
| 606 | このフラグが on の場合でも\ref{sec:SI}で述べた以上の処理は行わない． | |
| 607 | ||
| 608 | このフラグの設定は \verb|:spoiler| コマンドによって行う． | |
| 609 | \begin{vvtm} | |
| 610 | \begin{simplev} | |
| 611 | :spoiler コマンド ::= :spoiler { on | off } | |
| 612 | \end{simplev} | |
| 613 | \end{vvtm} | |
| 614 | ||
| 615 | フラグの初期値は off である． | |
| 616 | ||
| 617 | このフラグが on の場合の各戦略(SIおよびRDを除く)の挙動は，% | |
| 618 | \ref{sec:tactic-behaviour} で説明した処理を実施後に戦略 RD を実施するのと等価である． | |
| 619 | ||
| 620 | \subsubsection{:auto の動作}\label{sec:auto-and-spoiler} | |
| 621 | \texttt{:auto} コマンドによる戦略適用の場合は， | |
| 622 | :spoiler フラグが on の状態で実行される． | |
| 623 | :auto コマンドの実行が終了後はフラグは元の状態となる． | |
| 624 | ||
| 625 | \section{補助的戦略}\label{sec:suppliment} | |
| 626 | ここでは演繹規則として位置付けられるものではないが， | |
| 627 | 証明過程で有用と考えられる補助的な戦略について説明する． | |
| 628 | ||
| 629 | \subsection{NF:証明対象文の既約形}\label{sec:normal-form} | |
| 630 | ||
| 631 | \begin{itemize} | |
| 632 | \item ある戦略を適用した後にゴールに含まれる証明対象の文に | |
| 633 | 含まれる基底項(ground term)を全て既約形(normal form)にする． | |
| 634 | \end{itemize} | |
| 635 | NF は \verb|:apply| コマンドの引数として与えることができる． | |
| 636 | ||
| 637 | % \subsubsection{LE: 順序関係で互いに矛盾する公理の存在有無を調べる}\label{sec:LE} | |
| 638 | ||
| 639 | % \begin{itemize} | |
| 640 | % \item 現在は組込の INT モジュールで定義されている，整数の大小関係 | |
| 641 | % \verb|<| と \verb|<=| についてのみ検査が実施される． | |
| 642 | % \item LE は，CA のケースわけによって生成された公理(仮定)を検査対象とする． | |
| 643 | % \end{itemize} | |
| 644 | ||
| 645 | % \begin{prooftree} | |
| 646 | % \AXC{} | |
| 647 | % \LeftLabel{[LE]} | |
| 648 | % \UIC{$\SP \vdash \rho$} | |
| 649 | % \end{prooftree} | |
| 650 | ||
| 651 | \section{その他のコマンド}\label{sec:other-commands} | |
| 652 | ||
| 653 | \subsection{:init コマンド} | |
| 654 | ||
| 655 | \begin{itemize} | |
| 656 | \item \verb|:init| コマンドは証明の途中で lemma の導入と初期化を行うためのコマンドである． | |
| 657 | \item 構文 | |
| 658 | \begin{vvtm} | |
| 659 | \begin{simplev} | |
| 660 | :init コマンド ::= :init "["<label>"]" by <Substitution> | |
| 661 | | :init "(" <axiom> ")" by <Substitution> | |
| 662 | Substitution ::= "{" <Variable> <- <Term> ; ... <Variable> <- <Term> ; "}" | |
| 663 | \end{simplev} | |
| 664 | \end{vvtm} | |
| 665 | \item これを実行することによって，\verb|<label>| で指定されたラベルを持つ公理， | |
| 666 | あるいは "(" と ")" で囲まれた公理に含まれる変数を \verb|Substitution| で | |
| 667 | 示された変数置換によって初期化した公理を，ターゲット・ゴールの公理として追加する． | |
| 668 | \item 追加する公理は，後で見た時に :init コマンドによって導入された事が分かるよう | |
| 669 | \texttt[INIT] というラベルを付加する． | |
| 670 | \end{itemize} | |
| 671 | ||
| 672 | \subsubsection{:init コマンドの例} | |
| 673 | ||
| 674 | 文脈となっているモジュールに，次のような公理があったとする． | |
| 675 | \begin{examplev} | |
| 676 | ceq[inv3 :nonexec]: true = false if statusp(S:Sys,J:Client) = updated /\ | |
| 677 | statusp(S:Sys,I:Client) = gotval . | |
| 678 | \end{examplev} | |
| 679 | これに対して下のような :init コマンドを適用できる． | |
| 680 | \begin{examplev} | |
| 681 | :init [inv3] by {S:Sys <- S#Sys ; J:Client <- I@Client ; I:Client <- S#Client ;} | |
| 682 | \end{examplev} | |
| 683 | これを実行することによって，新たな公理 | |
| 684 | \begin{examplev} | |
| 685 | ceq [INIT]: true = false if statusp(S#Sys, I@Client) = updated /\ | |
| 686 | statusp(S#Sys, S#Client) = gotval . | |
| 687 | \end{examplev} | |
| 688 | が，追加される． | |
| 689 | ||
| 690 | \subsection{:roll back コマンド} | |
| 691 | ||
| 692 | \begin{itemize} | |
| 693 | \item :roll back は，現在のターゲット・ゴールに対して適用された，直前の戦略を | |
| 694 | キャンセルする． | |
| 695 | \item 構文 | |
| 696 | \begin{vvtm} | |
| 697 | \begin{simplev} | |
| 698 | :roll back コマンド ::= :roll back | |
| 699 | \end{simplev} | |
| 700 | \end{vvtm} | |
| 701 | \item このコマンドの実行により，ターゲット・ゴールは証明木から削除される． | |
| 702 | \end{itemize} | |
| 703 | ||
| 704 | \subsection{:cp コマンド} | |
| 705 | ||
| 706 | \begin{itemize} | |
| 707 | \item :cp コマンドは指定した2つの文のクリティカルペアを求め， | |
| 708 | 利用者に提示する． | |
| 709 | \item 利用者はそれに対して，次節で述べる :equation コマンド等を用いて， | |
| 710 | それを公理としてターゲット・ゴールへ追加する事ができる． | |
| 711 | \item 構文 | |
| 712 | \begin{vvtm} | |
| 713 | \begin{simplev} | |
| 714 | :cpコマンド ::= :cp <Sentence> >< <Sentence> | |
| 715 | <Sentence> ::= "["<Label>"]" | "(" <axiom> . ")" | |
| 716 | \end{simplev} | |
| 717 | \end{vvtm} | |
| 718 | \item \verb|<Sentence>| は，文脈モジュールで宣言されている公理のラベルを | |
| 719 | \verb|<Label>| で指定するか，あるいは CafeOBJ の公理宣言フォームを | |
| 720 | "("と")"で囲んで記載する． | |
| 721 | \end{itemize} | |
| 722 | ||
| 723 | \subsubsection{:cp コマンドの使用例} | |
| 724 | この例は，直接文を CafeOBJ の公理の宣言記法で記述しクリティカル・ペアを | |
| 725 | 求めている例である． | |
| 726 | \begin{vvtm} | |
| 727 | \begin{simplev} | |
| 728 | :cp (ceq top(sq(S@Sys)) = I@Pid if pc(S@Sys,I@Pid) = cs .) | |
| 729 | >< | |
| 730 | (ceq top(sq(S@Sys)) = J@Pid if pc(S@Sys,J@Pid) = cs .) | |
| 731 | \end{simplev} | |
| 732 | \end{vvtm} | |
| 733 | ||
| 734 | \subsection{:equation/:rule コマンド} | |
| 735 | ||
| 736 | \begin{itemize} | |
| 737 | \item これらのコマンドは :cp コマンドで得られたシステムからのクリティカル・ペアの | |
| 738 | 提示に対する，利用者の回答として使用される． | |
| 739 | \item 構文 | |
| 740 | \begin{vvtm} | |
| 741 | \begin{simplev} | |
| 742 | :cp回答 ::= :euqation | :rule | |
| 743 | \end{simplev} | |
| 744 | \end{vvtm} | |
| 745 | \item \verb|:equation| はクリティカル・ペアを等式としてターゲット・ゴールへ追加する． | |
| 746 | \item \verb|:rule| はクリティカル・ペアを遷移規則としてターゲット・ゴールへ追加する． | |
| 747 | \end{itemize} | |
| 748 | ||
| 749 | \subsubsection{:equation コマンドの使用例} | |
| 750 | 下は :cp コマンドによるクリティカル・ペアを等式としてターゲット・ゴールへ追加する例である． | |
| 751 | \begin{examplev} | |
| 752 | QLOCK(X) > :cp (eq I@Pid = S#Pid .) >< (eq S#Pid ~ I@Pid = false .) | |
| 753 | [cp] : | |
| 754 | (1) (true):Bool | |
| 755 | => (false):Bool | |
| 756 | QLOCK(X)> :equation | |
| 757 | [cp] added cp equation to goal "4-1-1-1": | |
| 758 | eq [CP]: true = false | |
| 759 | [ip]=> | |
| 760 | :goal { ** 4-1-1-1 ----------------------------------------- | |
| 761 | -- context module: QLOCK | |
| 762 | -- induction variable | |
| 763 | S:Sys | |
| 764 | -- introduced constant | |
| 765 | op I@Pid : -> Pid { prec: 0 } | |
| 766 | -- constants for induction | |
| 767 | op S#Sys : -> Sys { prec: 0 } | |
| 768 | op S#Pid : -> Pid { prec: 0 } | |
| 769 | -- introduced axioms | |
| 770 | ceq [SI :noexec]: top(sq(S#Sys)) = I:Pid if pc(S#Sys, I:Pid) = cs . | |
| 771 | ceq [INIT]: top(sq(S#Sys)) = I@Pid if pc(S#Sys, I@Pid) = cs . | |
| 772 | eq [CA]: pc(S#Sys, S#Pid) = cs . | |
| 773 | eq [CA]: S#Pid ~ I@Pid = false . | |
| 774 | ceq [INIT]: top(sq(S#Sys)) = I@Pid if pc(S#Sys, I@Pid) = cs . | |
| 775 | eq [IP]: pc(S#Sys, I@Pid) = cs . | |
| 776 | eq [CP]: true = false . | |
| 777 | -- axiom to be proved | |
| 778 | eq [TC :noexec]: top(get(sq(S#Sys))) = I@Pid . | |
| 779 | } | |
| 780 | \end{examplev} | |
| 781 | 追加される公理は，:cp コマンドの結果追加された事が後で判別できるよう， | |
| 782 | ラベルに CP が付けられる． | |
| 783 | ||
| 784 | \subsection{:backward equation/rule コマンド} | |
| 785 | 先の節で述べた :equation および rule コマンドと同様だが， | |
| 786 | 提示されたクリティカル・ペアの右辺と左辺を入れ替えた公理として | |
| 787 | ターゲット・ゴールへ導入する． | |
| 788 | ||
| 789 | \subsection{:ctf コマンド}\label{sec:ctf} | |
| 790 | \texttt{:ctf} コマンドは，指定した等式や遷移規則規則の成立・不成立， | |
| 791 | あるいは指定した項が定数構成子に等しいか否かによる場合分けを行う． | |
| 792 | ||
| 793 | \subsubsection{等式／遷移規則による場合分け} | |
| 794 | \texttt{:ctf} コマンドの下に示す構文はある等式あるいは遷移規則が成立する場合と成立しない場合の2ケースで， | |
| 795 | 現在のターゲット・ゴールを2つのサブゴールに分割する． | |
| 796 | \begin{itemize} | |
| 797 | \item 構文1：等式あるいは遷移規則の成立／不成立による場合分け | |
| 798 | \begin{vvtm} | |
| 799 | \begin{simplev} | |
| 800 | true/falseによる場合分け ::= :ctf "{" { <Equation> . | <Transition> . } "}" | |
| 801 | \end{simplev} | |
| 802 | \end{vvtm} | |
| 803 | \end{itemize} | |
| 804 | ||
| 805 | \begin{figure}[hbt] | |
| 806 | \centering | |
| 807 | % \includegraphics[scale=0.6]{ctf.pdf} | |
| 808 | \input ctf.tikz | |
| 809 | \caption{:ctf の動作 -- 等式／遷移規則の成立・不成立による場合分け} | |
| 810 | \label{fig:ctf} | |
| 811 | \end{figure} | |
| 812 | 図\ref{fig:ctf} はゴール g がターゲット・ゴールの状態で | |
| 813 | \begin{simplev} | |
| 814 | :ctf {eq l = r . } | |
| 815 | \end{simplev} | |
| 816 | とした時の場合分けの様子を示したものである． | |
| 817 | ゴール g に \texttt{eq l = r .} を仮定として追加した g-1 (true の場合)と， | |
| 818 | \texttt{eq (l = r) = false .} を追加した g-2 (false の場合)を作成し， | |
| 819 | ゴール g の子ゴールとする． | |
| 820 | % その後，g-1 と g-2 のそれぞれに対して戦略 RD を適用する． | |
| 821 | ||
| 822 | \subsubsection{定数構成子による場合分け} | |
| 823 | \texttt{:ctf} コマンドは構成子として定数項のみを持つソートの項を指定し， | |
| 824 | その定数項による場合分けを行うこともできる．その場合の構文は下のとおりである． | |
| 825 | \begin{itemize} | |
| 826 | \item 構文2：定数構成子による場合分け | |
| 827 | \begin{vvtm} | |
| 828 | \begin{simplev} | |
| 829 | 定数構成子による場合分け ::= :ctf "[" <項> . "]" | |
| 830 | \end{simplev} | |
| 831 | \end{vvtm} | |
| 832 | \end{itemize} | |
| 833 | 図\ref{fig:ctf2} はゴール g がターゲット・ゴールの状態で | |
| 834 | \texttt{:ctf [ t . ]} として指定した項 \texttt{t} が | |
| 835 | 組み込みのソート\texttt{Bool} の項である場合の例を示したものである． | |
| 836 | \texttt{t} が \texttt{true} の場合と \texttt{false} の場合に場合分けされている． | |
| 837 | \begin{figure}[hbt] | |
| 838 | \centering | |
| 839 | \input ctf2.tikz | |
| 840 | \caption{:ctf の動作 -- 定数構成子による場合分け} | |
| 841 | \label{fig:ctf2} | |
| 842 | \end{figure} | |
| 843 | ||
| 844 | ||
| 845 | \subsubsection{:spoiler on の場合の挙動} | |
| 846 | :spoiler フラグが on の場合，このようなサブゴールに分割後，それぞれのサブゴールで暗黙的に | |
| 847 | 戦略 \texttt{RD} (\ref{sec:RD}) を実行する． | |
| 848 | ||
| 849 | \subsection{:ctf- コマンド}\label{sec:ctf-} | |
| 850 | ||
| 851 | \texttt{:ctf-} は \texttt{:ctf} コマンドと場合わけの機能については全く同じである． | |
| 852 | しかし作成された子ゴールに対して \texttt{RD} を適用した結果， | |
| 853 | 証明対象の文が discharge \textbf{されなかった}場合に次のような違いがある： | |
| 854 | \begin{itemize} | |
| 855 | \item \texttt{:ctf} コマンドの場合\\ | |
| 856 | 証明対象の文は \texttt{RD} の適用によって簡約化された状態のままとなる | |
| 857 | \item \texttt{:ctf-} コマンドの場合\\ | |
| 858 | 証明対象の文は \texttt{RD} が適用される前の状態に戻される | |
| 859 | \end{itemize} | |
| 860 | ||
| 861 | 一般に \texttt{RD} の適用により証明対象の文は破壊的に書き換えられるため， | |
| 862 | 場合分けを連続的に実施していくような証明の過程で \texttt{RD} 戦略を | |
| 863 | 適用した場合\footnote{:spoiler フラグが on の場合は常にそうなる}， | |
| 864 | うまく discharge できなかった際は元の証明対象の文に戻して | |
| 865 | さらに場合分けを続けていきたい． | |
| 866 | これを自動的に行うのに \texttt{:ctf-} が便利である． | |
| 867 | ||
| 868 | ||
| 869 | \subsection{:csp コマンド}\label{sec:csp} | |
| 870 | \texttt{:csp} コマンドは複数の等式または遷移規則を指定し， | |
| 871 | 各々が成立するとした小ゴールを作成する． | |
| 872 | もし :spoiler フラグが on の場合は， | |
| 873 | その後，各小ゴールに対して暗黙的に戦略 RD (\ref{sec:RD}) を適用する． | |
| 874 | ||
| 875 | \begin{itemize} | |
| 876 | \item 構文 | |
| 877 | \begin{vvtm} | |
| 878 | \begin{simplev} | |
| 879 | ケース指定分割 ::= :csp "{" { <Equation> . | <Transition> .}+ "}" | |
| 880 | \end{simplev} | |
| 881 | \end{vvtm} | |
| 882 | \end{itemize} | |
| 883 | ||
| 884 | \begin{figure}[hbt] | |
| 885 | \centering | |
| 886 | % \includegraphics[scale=0.6]{csp.pdf} | |
| 887 | \input csp.tikz | |
| 888 | \caption{:csp の動作} | |
| 889 | \label{fig:csp} | |
| 890 | \end{figure} | |
| 891 | ||
| 892 | \paragraph{図~\ref{fig:csp}の説明} | |
| 893 | ターゲットゴールが g だとする．”:csp { \textit{eq1} . \textit{eq2} . \textit{eq3} . }” のようにして | |
| 894 | 3つの等式 eq1, eq2, および eq3 を指定した場合，:csp は3個の小ゴール g-1, g-2, g-3 を生成し， | |
| 895 | それぞれに対して一つづつ指定された等式を配分する． | |
| 896 | 図は :spoiler フラグが on の状態を示しており， | |
| 897 | 生成された小ゴールに対して暗黙的に戦略 RD を適用する様子も示している． | |
| 898 | ||
| 899 | \subsection{:csp- コマンド}\label{sec:csp-} | |
| 900 | \texttt{:csp-} コマンドは場合わけの機能については \texttt{:csp} コマンドと全く同じである． | |
| 901 | 構文も同様ででキーワード \texttt{:csp} に代わって \texttt{:csp-} を指定する． | |
| 902 | 違いは \texttt{:ctf} と \texttt{:ctf-} の違いと同じである． | |
| 903 | すなわち，生成された子ゴールに対して適用された \texttt{RD} 戦略の結果 | |
| 904 | discharge されなかった場合に，元の証明対象の文に戻す(\texttt{:csp-})か | |
| 905 | 戻さない(\texttt{:csp})かの違いである． | |
| 906 | ||
| 907 | \subsection{:def コマンド}\label{sec:def-command} | |
| 908 | \subsubsection{連続した戦略の適用に名前をつける} | |
| 909 | \texttt{:def} コマンドは一連した戦略適用に名前をつけ \texttt{:apply} コマンドの | |
| 910 | 引数として与えることができるようにする． | |
| 911 | \begin{vvtm} | |
| 912 | \begin{simplev} | |
| 913 | 一連の戦略定義 ::= :def <name> = ( <戦略1> ... <戦略n> ) | |
| 914 | \end{simplev} | |
| 915 | \end{vvtm} | |
| 916 | ||
| 917 | 下は戦略 \texttt{IP} に引き続いて \texttt{RD} を適用することに | |
| 918 | \texttt{ip+rd} という名前をつけたものである． | |
| 919 | \begin{examplev} | |
| 920 | :def ip+rd = ( IP RD ) | |
| 921 | \end{examplev} | |
| 922 | 上のようにすることにより，\texttt{:apply} コマンドの引数として \texttt{ip+rd} を | |
| 923 | 指定することができるようになる． | |
| 924 | \begin{examplev} | |
| 925 | :apply (... ip+rd ...) | |
| 926 | \end{examplev} | |
| 927 | 上の \texttt{ip+rd} の定義は :spoiler フラグが on の場合の戦略 \texttt{IP} の | |
| 928 | 挙動と同じである．このように :spoiler フラグが off の状態(デフォルト) で | |
| 929 | \texttt{RD} を自動的に実行したい場合はこのような定義をしておくことで | |
| 930 | 簡便にこれを行うことができる． | |
| 931 | ||
| 932 | \subsubsection{\texttt{:ctf} などの戦略的な使用} | |
| 933 | また，\texttt{:ctf} コマンドの指定や \texttt{:csp} コマンドの指定に名前をつけ， | |
| 934 | \texttt{:apply} コマンドの引数として与えることができるようにする． | |
| 935 | \begin{vvtm} | |
| 936 | \begin{simplev} | |
| 937 | :ctf 戦略定義 ::= :def <name> = :ctf "{" { <Equation> . | <Transition> . } "}" | |
| 938 | | :def <name> = :ctf [ <Term> . ] | |
| 939 | :csp 戦略定義 ::= :def <name> = :csp "{" { <Equation> . | <Transition> .}+ "}" | |
| 940 | \end{simplev} | |
| 941 | \end{vvtm} | |
| 942 | \texttt{:ctf-} や \texttt{:csp-} も同じである． | |
| 943 | ||
| 944 | このようにすることで，\texttt{:ctf-} などのコマンドの適用を，他の戦略と組み合わせて | |
| 945 | \texttt{:apply} コマンドの引数として与えることができる． | |
| 946 | ||
| 947 | \subsection{:show コマンド} | |
| 948 | 証明の進行状況などを確認するために有用と思われる情報をみるため， | |
| 949 | 既存の show コマンドと類似の機能を提供する \texttt{:show} コマンドを提供する． | |
| 950 | ||
| 951 | \subsubsection{ゴール内容の表示 -- :show goal} | |
| 952 | \begin{itemize} | |
| 953 | \item ゴールの内容を表示する． | |
| 954 | \item 構文 | |
| 955 | \begin{vvtm} | |
| 956 | \begin{simplev} | |
| 957 | ゴールの表示 ::= :show goal [ <GoalName> ] | |
| 958 | \end{simplev} | |
| 959 | \end{vvtm} | |
| 960 | \item \verb|<GoalName>| で指定したゴールを表示する． | |
| 961 | \item \verb|<GoalName>| が省略された場合は，現在のターゲット・ゴールを表示する． | |
| 962 | \end{itemize} | |
| 963 | ||
| 964 | \subsubsection{未証明のゴールの表示 -- :show unproved} | |
| 965 | \begin{itemize} | |
| 966 | \item 現時点でまだ証明されていないゴールを表示する． | |
| 967 | \item 未証明のゴールとは，現在の証明過程における証明木で，末端のノードうち | |
| 968 | まだ証明対象の文が discharge されていないゴールの事を言う． | |
| 969 | \item 構文 | |
| 970 | \begin{vvtm} | |
| 971 | \begin{simplev} | |
| 972 | 未証明のゴール表示 ::= :show unproved | |
| 973 | \end{simplev} | |
| 974 | \end{vvtm} | |
| 975 | \end{itemize} | |
| 976 | ||
| 977 | \subsubsection{証明木の構造表示 -- :show/:describe proof} | |
| 978 | ||
| 979 | \paragraph{:show proof} | |
| 980 | \begin{itemize} | |
| 981 | \item 現時点における証明木の構造を図式的に表示する． | |
| 982 | \item 構文 | |
| 983 | \begin{vvtm} | |
| 984 | \begin{simplev} | |
| 985 | 証明木の表示 ::= :show proof | |
| 986 | \end{simplev} | |
| 987 | \end{vvtm} | |
| 988 | \item 証明木の表示にあったっては，以下の事が容易に判別出来るようにする． | |
| 989 | \begin{itemize} | |
| 990 | \item ゴールがどの戦略によって生成されたものであるか | |
| 991 | \item ターゲット・ゴールが何であるか | |
| 992 | \item ゴールは証明済みか否か | |
| 993 | \end{itemize} | |
| 994 | \end{itemize} | |
| 995 | ||
| 996 | \paragraph{:describe proof} | |
| 997 | \begin{itemize} | |
| 998 | \item \verb|show proof| と同様だが図式的な構造の表示では無く，証明の過程で | |
| 999 | 使用された演繹に関する情報を提示するのが目的である． | |
| 1000 | \item 構文 | |
| 1001 | \begin{vvtm} | |
| 1002 | \begin{simplev} | |
| 1003 | 証明過程の表示 ::= :describe proof | |
| 1004 | \end{simplev} | |
| 1005 | \end{vvtm} | |
| 1006 | \item 表示にあたっては，以下の情報を提示する． | |
| 1007 | \begin{itemize} | |
| 1008 | \item そのゴールを生成した戦略 | |
| 1009 | \item 証明すべき文 | |
| 1010 | \item 帰納法の対象とした変数 | |
| 1011 | \item SI あるいは TC 戦略を適用するにあたって導入された定数 | |
| 1012 | \item 戦略によって導入された公理 | |
| 1013 | \item ゴールが証明されているか否か | |
| 1014 | \end{itemize} | |
| 1015 | \end{itemize} | |
| 1016 | ||
| 1017 | ||
| 1018 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% | |
| 1019 | \chapter{例題} | |
| 1020 | \label{chap:prototype} | |
| 1021 | ||
| 1022 | 本章では~\ref{chap:new-commands}で説明した CITP for CafeOBJ の基本的な機能を網羅した例題について， | |
| 1023 | その実行例と合わせて説明する． | |
| 1024 | ||
| 1025 | \section{足し算の性質の帰納法による証明} | |
| 1026 | \label{sec:pnat} | |
| 1027 | ペアノ流の自然数の上で足し算を定義し，足し算の交換則と結合則が成り立つことを証明する． | |
| 1028 | ||
| 1029 | \subsubsection{PNATの定義} | |
| 1030 | 自然数のソートは \texttt{PNat} とし，下位ソートとして \texttt{PZero} (ゼロ)と | |
| 1031 | \texttt{PNzNat} (1以上の自然数)を定義する．足し算は \texttt{+}， | |
| 1032 | \texttt{0} と \texttt{s} が構成子である． | |
| 1033 | \begin{vvtm} | |
| 1034 | \begin{simplev} | |
| 1035 | ** | |
| 1036 | ** Prove associativity and commutativity of addition | |
| 1037 | ** using CITP for CafeOBJ | |
| 1038 | ** | |
| 1039 | ||
| 1040 | mod! PNAT { | |
| 1041 | [ PZero PNzNat < PNat ] | |
| 1042 | op 0 : -> PZero {ctor} . | |
| 1043 | op s_ : PNat -> PNzNat {ctor} . | |
| 1044 | op _+_ : PNat PNat -> PNat . | |
| 1045 | eq 0 + N:PNat = N . | |
| 1046 | eq s M:PNat + N:PNat = s(M + N) . | |
| 1047 | } | |
| 1048 | \end{simplev} | |
| 1049 | \end{vvtm} | |
| 1050 | ||
| 1051 | \subsection{準備} | |
| 1052 | ||
| 1053 | 結合則の証明に必要な性質として次の性質がある． | |
| 1054 | ||
| 1055 | \begin{verbatim} | |
| 1056 | N:PNat + 0 = N:PNat . | |
| 1057 | M:PNat + s N:PNat = s(M:PNat + N:PNat) . | |
| 1058 | \end{verbatim} | |
| 1059 | ||
| 1060 | そのため，まず最初に足し算\texttt{+}で，これらの性質を先に証明する． | |
| 1061 | CIT for Cafe で証明するため，最初に PNAT を文脈として設定してから | |
| 1062 | 証明したいゴールを設定する． | |
| 1063 | ||
| 1064 | \begin{vvtm} | |
| 1065 | \begin{simplev} | |
| 1066 | select PNAT . | |
| 1067 | :goal { eq [lemma-1]: M:PNat + 0 = M:PNat . | |
| 1068 | eq [lemma-2]: M:PNat + s N:PNat = s(M:PNat + N:PNat). } | |
| 1069 | \end{simplev} | |
| 1070 | \end{vvtm} | |
| 1071 | ||
| 1072 | 上の \texttt{:goal} コマンドの実行結果は次のようになる． | |
| 1073 | \begin{vvtm} | |
| 1074 | \begin{simplev} | |
| 1075 | :goal { ** root ----------------------------------------- | |
| 1076 | -- context module: PNAT | |
| 1077 | -- axioms to be proved | |
| 1078 | eq [lemma-1]: M:PNat + 0 = M . | |
| 1079 | eq [lemma-2]: M:PNat + s N:PNat = s (M + N) . | |
| 1080 | } | |
| 1081 | ** Initial goal (root) is generated. ** | |
| 1082 | \end{simplev} | |
| 1083 | \end{vvtm} | |
| 1084 | ゴール名が \texttt{root} であり，先に \texttt{:goal} コマンドで指定した文が | |
| 1085 | 証明対象となっている事が示されている． | |
| 1086 | ||
| 1087 | 証明は変数 \texttt{M:PNat} の上の帰納法によって行う．そのため \texttt{:ind on} コマンドで | |
| 1088 | 帰納法で使用する変数を宣言する．証明の過程で生成されるゴールを確認したいため | |
| 1089 | \texttt{:verbose} コマンドで \texttt{on} を指定する． | |
| 1090 | デフォルトでは \texttt{:verbose} の値は \texttt{off} である． | |
| 1091 | \begin{vvtm} | |
| 1092 | \begin{simplev} | |
| 1093 | :ind on (M:PNat) | |
| 1094 | ||
| 1095 | **> We want to see every goal generated in proof process. | |
| 1096 | :verbose on | |
| 1097 | \end{simplev} | |
| 1098 | \end{vvtm} | |
| 1099 | 上を実行するとシステムは \texttt{M} の上で帰納法を用いた証明を実施する旨表示する． | |
| 1100 | \begin{vvtm} | |
| 1101 | \begin{simplev} | |
| 1102 | **> Induction will be conducted on M:PNat | |
| 1103 | \end{simplev} | |
| 1104 | \end{vvtm} | |
| 1105 | ||
| 1106 | ||
| 1107 | 証明は戦略 \texttt{:auto} で行う．これは戦略 \texttt{(SI CA TC IP RD)} と等価である(\ref{sec:tactic-auto})． | |
| 1108 | また，\texttt{:auto} の実行中は，:spoiler フラグが on の状態で戦略が適用される(\ref{sec:auto-and-spoiler})． | |
| 1109 | ||
| 1110 | \begin{vvtm} | |
| 1111 | \begin{simplev} | |
| 1112 | :auto | |
| 1113 | \end{simplev} | |
| 1114 | \end{vvtm} | |
| 1115 | ||
| 1116 | 以下順次，\texttt{:auto} コマンドの出力を示す． | |
| 1117 | \begin{vvtm} | |
| 1118 | \begin{simplev} | |
| 1119 | [si]=> :goal{root} | |
| 1120 | ** Generated 2 goals | |
| 1121 | [si]=> | |
| 1122 | :goal { ** 1 ----------------------------------------- | |
| 1123 | -- context module: PNAT | |
| 1124 | -- induction variable | |
| 1125 | M:PNat | |
| 1126 | -- sentences to be proved | |
| 1127 | eq [lemma-1]: 0 + 0 = 0 . | |
| 1128 | eq [lemma-2]: 0 + s N:PNat = s (0 + N) . | |
| 1129 | } | |
| 1130 | [si]=> | |
| 1131 | :goal { ** 2 ----------------------------------------- | |
| 1132 | -- context module: PNAT | |
| 1133 | -- induction variable | |
| 1134 | M:PNat | |
| 1135 | -- constant for induction | |
| 1136 | op M#PNat : -> PNat { prec: 0 } | |
| 1137 | -- introduced axioms | |
| 1138 | eq [SI lemma-1]: M#PNat + 0 = M#PNat . | |
| 1139 | eq [SI lemma-2]: M#PNat + s N:PNat = s (M#PNat + N) . | |
| 1140 | -- sentences to be proved | |
| 1141 | eq [lemma-1]: s M#PNat + 0 = s M#PNat . | |
| 1142 | eq [lemma-2]: s M#PNat + s N:PNat = s (s M#PNat + N) . | |
| 1143 | } | |
| 1144 | \end{simplev} | |
| 1145 | \end{vvtm} | |
| 1146 | まず最初に戦略 \texttt{si} が適用され，2つのゴールが生成されている． | |
| 1147 | ゴール 1 は帰納法のベースケースであり，もとの証明対象の文にあった | |
| 1148 | 帰納法の変数 M を構成子 0 とした文が証明対象となる． | |
| 1149 | ||
| 1150 | ゴール 2 はステップケースである．帰納法の仮定として，``ある自然数 N で | |
| 1151 | 成り立つとしたとき'' に相当する文が導入されている．ある自然数 N に相当する | |
| 1152 | 項のために定数 \verb|M#PNat| が使われている．この定数を定義するために | |
| 1153 | 導入されたオペレータ宣言についてもゴールの表示で示されている． | |
| 1154 | ||
| 1155 | 証明対象とする文は，上で述べた仮定が成り立つとした時に示すべき文である． | |
| 1156 | そのため構成子 \texttt{s} により \verb|M#PNat| が展開されている． | |
| 1157 | ||
| 1158 | 戦略 si を適用したあと，システムは ca を自動的に適用する． | |
| 1159 | ca はまず最初にゴール1に対して適用される． | |
| 1160 | 複数の証明対象がゴールに含まれているため， | |
| 1161 | それぞれを別々の子ゴールに分配し，それぞれでケース分けが | |
| 1162 | 可能かどうかを調べる． | |
| 1163 | この場合ケースわけは実行されなかった(ケースわけの対象とする | |
| 1164 | 公理は宣言されていない)． | |
| 1165 | ||
| 1166 | ca はケースわけ分析が終了した後に，:spoiler フラグが on の場合に限って | |
| 1167 | 暗黙的に戦略RDに相当する処理(文の充足性と矛盾の有無の調査)を行うが， | |
| 1168 | その結果一つの文が充足されておりその旨出力する． | |
| 1169 | 具体的な出力は次のようになる． | |
| 1170 | ||
| 1171 | \begin{vvtm} | |
| 1172 | \begin{simplev} | |
| 1173 | [ca]=> :goal{1} | |
| 1174 | [ca] discharged: eq [lemma-1]: 0 = 0 | |
| 1175 | ** Generated 2 goals | |
| 1176 | [ca]=> | |
| 1177 | :goal { ** 1-1 ----------------------------------------- | |
| 1178 | -- context module: PNAT | |
| 1179 | -- discharged sentence | |
| 1180 | eq [ST lemma-1]: 0 = 0 . | |
| 1181 | -- induction variable | |
| 1182 | M:PNat | |
| 1183 | } << proved >> | |
| 1184 | [ca]=> | |
| 1185 | :goal { ** 1-2 ----------------------------------------- | |
| 1186 | -- context module: PNAT | |
| 1187 | -- induction variable | |
| 1188 | M:PNat | |
| 1189 | -- sentence to be proved | |
| 1190 | eq [lemma-2]: 0 + s N:PNat = s (0 + N) . | |
| 1191 | } | |
| 1192 | \end{simplev} | |
| 1193 | \end{vvtm} | |
| 1194 | :auto は一連の戦略適用 (SI CA TC IP RD) に等しいことを先に述べたが、 | |
| 1195 | 戦略CAで生成されたゴール 1-1 および 1-2 に対してCA以降の戦略が | |
| 1196 | 順に適用されて行く。1-1 は既に今回のCAの適用によって discharge | |
| 1197 | されているため、各戦略は何もしない。 | |
| 1198 | 1-2 はまだ証明すべき文が残っているため、戦略適用の対象となる。 | |
| 1199 | \begin{vvtm} | |
| 1200 | \begin{simplev} | |
| 1201 | [tc]=> :goal{1-1} | |
| 1202 | [ip]=> :goal{1-1} | |
| 1203 | [rd]=> :goal{1-1} | |
| 1204 | [tc]=> :goal{1-2} | |
| 1205 | [tc] discharged: | |
| 1206 | eq [TC lemma-2]: s N@PNat = s N@PNat | |
| 1207 | [tc] discharged the goal "1-2-1" | |
| 1208 | ** Generated 1 goal | |
| 1209 | [tc]=> | |
| 1210 | :goal { ** 1-2-1 ----------------------------------------- | |
| 1211 | -- context module: PNAT | |
| 1212 | -- discharged sentence | |
| 1213 | eq [TC TC lemma-2]: s N@PNat = s N@PNat . | |
| 1214 | -- induction variable | |
| 1215 | M:PNat | |
| 1216 | -- introduced constant | |
| 1217 | op N@PNat : -> PNat { prec: 0 } | |
| 1218 | } << proved >> | |
| 1219 | [ip]=> :goal{1-2-1} | |
| 1220 | [rd]=> :goal{1-2-1} | |
| 1221 | \end{simplev} | |
| 1222 | \end{vvtm} | |
| 1223 | TCは証明対象の文の変数を定数項で置き換えた後， | |
| 1224 | もし :spoiler フラグが on であれば文が成立するか否かを調べる． | |
| 1225 | 現在は :auto で実行しており、従って :spoiler が on の状態であるため, | |
| 1226 | 上の実行の様子のとおりゴール 1-2 の文が成立するかを確かめ, | |
| 1227 | その結果 discharge に成功している． | |
| 1228 | ||
| 1229 | ここまでで，システムはゴール 1 およびその子ゴールに対して順次戦略を適用し終わっている． | |
| 1230 | その後，残っているゴール2に対して再び ca 以降の戦略を順次適用する． | |
| 1231 | その実行の様子は次のようになる． | |
| 1232 | ここでも複数の証明対象を別々の小ゴールに分割してから， | |
| 1233 | それぞれでケース分け処理を実施する． | |
| 1234 | やはりケースわけは無く，処理の終わりで実施する ST + CT で， | |
| 1235 | ゴール 2-1 が discharge されている． | |
| 1236 | ||
| 1237 | \begin{vvtm} | |
| 1238 | \begin{simplev} | |
| 1239 | [ca]=> :goal{2} | |
| 1240 | [ca] discharged: eq [lemma-1]: (s M#PNat) = (s M#PNat) | |
| 1241 | ** Generated 2 goals | |
| 1242 | [ca]=> | |
| 1243 | :goal { ** 2-1 ----------------------------------------- | |
| 1244 | -- context module: PNAT | |
| 1245 | -- discharged sentence | |
| 1246 | eq [ST lemma-1]: s M#PNat = s M#PNat . | |
| 1247 | -- induction variable | |
| 1248 | M:PNat | |
| 1249 | -- constant for induction | |
| 1250 | op M#PNat : -> PNat { prec: 0 } | |
| 1251 | -- introduced axioms | |
| 1252 | eq [SI lemma-1]: M#PNat + 0 = M#PNat . | |
| 1253 | eq [SI lemma-2]: M#PNat + s N:PNat = s (M#PNat + N) . | |
| 1254 | } << proved >> | |
| 1255 | [ca]=> | |
| 1256 | :goal { ** 2-2 ----------------------------------------- | |
| 1257 | -- context module: PNAT | |
| 1258 | -- induction variable | |
| 1259 | M:PNat | |
| 1260 | -- constant for induction | |
| 1261 | op M#PNat : -> PNat { prec: 0 } | |
| 1262 | -- introduced axioms | |
| 1263 | eq [SI lemma-1]: M#PNat + 0 = M#PNat . | |
| 1264 | eq [SI lemma-2]: M#PNat + s N:PNat = s (M#PNat + N) . | |
| 1265 | -- sentence to be proved | |
| 1266 | eq [lemma-2]: s M#PNat + s N:PNat = s (s M#PNat + N) . | |
| 1267 | } | |
| 1268 | \end{simplev} | |
| 1269 | \end{vvtm} | |
| 1270 | 以降、ゴール１の場合と同様に残りの戦略が順次適用されていく. | |
| 1271 | 実行の様子を下に示す.新たに説明すべき挙動は無い． | |
| 1272 | ||
| 1273 | \begin{vvtm} | |
| 1274 | \begin{simplev} | |
| 1275 | [tc]=> :goal{2-1} | |
| 1276 | [ip]=> :goal{2-1} | |
| 1277 | [rd]=> :goal{2-1} | |
| 1278 | [tc]=> :goal{2-2} | |
| 1279 | [tc] discharged: | |
| 1280 | eq [TC lemma-2]: s (s (M#PNat + N@PNat)) | |
| 1281 | = s (s (M#PNat + N@PNat)) | |
| 1282 | [tc] discharged the goal "2-2-1" | |
| 1283 | ** Generated 1 goal | |
| 1284 | [tc]=> | |
| 1285 | :goal { ** 2-2-1 ----------------------------------------- | |
| 1286 | -- context module: PNAT | |
| 1287 | -- discharged sentence | |
| 1288 | eq [TC TC lemma-2]: s (s (M#PNat + N@PNat)) | |
| 1289 | = s (s (M#PNat + N@PNat)) . | |
| 1290 | -- induction variable | |
| 1291 | M:PNat | |
| 1292 | -- introduced constant | |
| 1293 | op N@PNat : -> PNat { prec: 0 } | |
| 1294 | -- constant for induction | |
| 1295 | op M#PNat : -> PNat { prec: 0 } | |
| 1296 | -- introduced axioms | |
| 1297 | eq [SI lemma-1]: M#PNat + 0 = M#PNat . | |
| 1298 | eq [SI lemma-2]: M#PNat + s N:PNat = s (M#PNat + N) . | |
| 1299 | } << proved >> | |
| 1300 | [ip]=> :goal{2-2-1} | |
| 1301 | [rd]=> :goal{2-2-1} | |
| 1302 | (consumed 0.0280 sec, including 16 rewrites + 58 matches) | |
| 1303 | ** All goals are successfully discharged. | |
| 1304 | } | |
| 1305 | \end{simplev} | |
| 1306 | \end{vvtm} | |
| 1307 | システムは全てのゴールが discharge され， | |
| 1308 | 当初の証明対象が証明できたことを印字して， | |
| 1309 | :auto コマンドの処理を終了している． | |
| 1310 | ||
| 1311 | 以上の証明において，戦略が適用されどのようにゴールが生成されたかは， | |
| 1312 | \verb|:show proof| コマンドによってみることが出来る． | |
| 1313 | 下に実行例を示す． | |
| 1314 | ||
| 1315 | \begin{vvtm} | |
| 1316 | \begin{simplev} | |
| 1317 | root* | |
| 1318 | [si] 1* | |
| 1319 | [ca] 1-1* | |
| 1320 | [ca] 1-2* | |
| 1321 | [tc] 1-2-1* | |
| 1322 | [si] 2* | |
| 1323 | [ca] 2-1* | |
| 1324 | [ca] 2-2* | |
| 1325 | [tc] 2-2-1* | |
| 1326 | \end{simplev} | |
| 1327 | \end{vvtm} | |
| 1328 | ゴール名の右側の \verb|*| は，そのゴールに含まれるすべての | |
| 1329 | 証明対象の文が discharge されていること，すなわち | |
| 1330 | 証明されていることを示す． | |
| 1331 | ||
| 1332 | \subsection{交換則と結合則の証明} | |
| 1333 | 引き続いて，足し算 \texttt{+} の交換則と結合則を証明する． | |
| 1334 | これら証明には先に証明した lemma-1 と lemma-2 が必要である． | |
| 1335 | そのためこれらを公理として導入した新たなモジュール PNAT-L を宣言する． | |
| 1336 | ||
| 1337 | \begin{vvtm} | |
| 1338 | \begin{simplev} | |
| 1339 | mod! PNAT-L { | |
| 1340 | inc(PNAT) | |
| 1341 | eq [lemma-1]: N:PNat + 0 = N . | |
| 1342 | eq [lemma-2]: M:PNat + s N:PNat = s(M + N). | |
| 1343 | } | |
| 1344 | \end{simplev} | |
| 1345 | \end{vvtm} | |
| 1346 | ||
| 1347 | \subsubsection{交換則の証明} | |
| 1348 | ||
| 1349 | まず最初に交換則を証明する．PNAT-L を文脈として設定し， | |
| 1350 | ゴールを宣言する． | |
| 1351 | \begin{vvtm} | |
| 1352 | \begin{simplev} | |
| 1353 | open PNAT-L . | |
| 1354 | :goal { eq M:PNat + N:PNat = N:PNat + M:PNat . } | |
| 1355 | \end{simplev} | |
| 1356 | \end{vvtm} | |
| 1357 | 今度は文脈の設定に select ではなく，open を用いた． | |
| 1358 | 実行結果は次のようになる． | |
| 1359 | \begin{vvtm} | |
| 1360 | \begin{simplev} | |
| 1361 | -- opening module PNAT-L.. done. | |
| 1362 | ||
| 1363 | :goal { ** root ----------------------------------------- | |
| 1364 | -- context module: % | |
| 1365 | -- axiom to be proved | |
| 1366 | eq M:PNat + N:PNat = N + M . | |
| 1367 | } | |
| 1368 | ** Initial goal (root) is generated. ** | |
| 1369 | \end{simplev} | |
| 1370 | \end{vvtm} | |
| 1371 | ||
| 1372 | 証明は帰納法を用いるため，帰納法で使用する変数を指定する． | |
| 1373 | \begin{vvtm} | |
| 1374 | \begin{simplev} | |
| 1375 | %PNAT-L> :ind on (M:PNat) | |
| 1376 | **> Induction will be conducted on M:PNat | |
| 1377 | \end{simplev} | |
| 1378 | \end{vvtm} | |
| 1379 | ||
| 1380 | 戦略として今回は :auto ではなく，陽に戦略を指定し :apply コマンドによって証明を試みる． | |
| 1381 | まず最初に SI コマンドによって帰納法のベースケースとステップケースに相当するゴールを | |
| 1382 | 作成する． | |
| 1383 | ||
| 1384 | \begin{vvtm} | |
| 1385 | \begin{simplev} | |
| 1386 | %PNAT-L> :apply (SI) | |
| 1387 | ||
| 1388 | [si]=> :goal{root} | |
| 1389 | ** Generated 2 goals | |
| 1390 | [si]=> | |
| 1391 | :goal { ** 1 ----------------------------------------- | |
| 1392 | -- context module: % | |
| 1393 | -- induction variable | |
| 1394 | M:PNat | |
| 1395 | -- sentence to be proved | |
| 1396 | eq 0 + N:PNat = N + 0 . | |
| 1397 | } | |
| 1398 | [si]=> | |
| 1399 | :goal { ** 2 ----------------------------------------- | |
| 1400 | -- context module: % | |
| 1401 | -- induction variable | |
| 1402 | M:PNat | |
| 1403 | -- constant for induction | |
| 1404 | op M#PNat : -> PNat { prec: 0 } | |
| 1405 | -- introduced axiom | |
| 1406 | eq [SI]: M#PNat + N:PNat = N + M#PNat . | |
| 1407 | -- sentence to be proved | |
| 1408 | eq s M#PNat + N:PNat = N + s M#PNat . | |
| 1409 | } | |
| 1410 | (consumed 0.0000 sec, including 0 rewrites + 0 matches) | |
| 1411 | >> Next target goal is "1". | |
| 1412 | >> Remaining 2 goals. | |
| 1413 | \end{simplev} | |
| 1414 | \end{vvtm} | |
| 1415 | ||
| 1416 | 上のように2つのゴールが生成された． | |
| 1417 | 現在の証明木は次のようになっている． | |
| 1418 | \begin{vvtm} | |
| 1419 | \begin{simplev} | |
| 1420 | %PNAT-L> show proof | |
| 1421 | root | |
| 1422 | >[si] 1 | |
| 1423 | [si] 2 | |
| 1424 | \end{simplev} | |
| 1425 | \end{vvtm} | |
| 1426 | ||
| 1427 | デフォルトで次の戦略の適用対象となるゴール, | |
| 1428 | すなわちターゲット・ゴールには， | |
| 1429 | 証明木のノードに \verb|>| と表示してそれと分かるようになっている． | |
| 1430 | 次に適用する戦略として TC を指定した例を下に示す． | |
| 1431 | 生成されるゴールが一々印字されるのを抑制するため, | |
| 1432 | \texttt{:verbose off} としている. | |
| 1433 | \begin{vvtm} | |
| 1434 | \begin{simplev} | |
| 1435 | %PNAT-L> :verbose off | |
| 1436 | ||
| 1437 | %PNAT-L> :apply (tc) | |
| 1438 | ||
| 1439 | [tc]=> :goal{root} | |
| 1440 | ** Generated 1 goal | |
| 1441 | (consumed 0.0200 sec, including 0 rewrites + 0 matches) | |
| 1442 | >> Next target goal is "1". | |
| 1443 | >> Remaining 1 goal. | |
| 1444 | ||
| 1445 | %PNAT-L> :show proof | |
| 1446 | root | |
| 1447 | >[tc] 1 | |
| 1448 | \end{simplev} | |
| 1449 | \end{vvtm} | |
| 1450 | TCの適用によって１つの子ゴールが生成され， | |
| 1451 | それが次のターゲット・ゴールとなっている． | |
| 1452 | これに対して戦略RDを適用して証明を試みる. | |
| 1453 | \begin{vvtm} | |
| 1454 | \begin{simplev} | |
| 1455 | %PNAT-L> :apply(rd) | |
| 1456 | ||
| 1457 | [rd]=> :goal{1-1} | |
| 1458 | [rd] discharged: | |
| 1459 | eq [TC]: 0 + N@PNat = N@PNat + 0 | |
| 1460 | [rd] discharged goal "1-1". | |
| 1461 | (consumed 0.0160 sec, including 3 rewrites + 6 matches) | |
| 1462 | >> Next target goal is "2". | |
| 1463 | >> Remaining 1 goal. | |
| 1464 | ||
| 1465 | %PNAT-L> :show proof | |
| 1466 | root | |
| 1467 | [si] 1* | |
| 1468 | [tc] 1-1* | |
| 1469 | >[si] 2 | |
| 1470 | \end{simplev} | |
| 1471 | \end{vvtm} | |
| 1472 | ||
| 1473 | dischage する事が出来た．証明木のノードに \verb|*| が付加されているのは | |
| 1474 | それが discharge されている事を示したものである． | |
| 1475 | ||
| 1476 | 残りのゴール 2 に対しても TC および RD で証明を試みる． | |
| 1477 | 今度はTCとRDをまとめて :apply の引数として指定する. | |
| 1478 | \begin{vvtm} | |
| 1479 | \begin{simplev} | |
| 1480 | %PNAT-L> :apply(tc rd) | |
| 1481 | ||
| 1482 | [tc]=> :goal{2} | |
| 1483 | ** Generated 1 goal | |
| 1484 | [rd]=> :goal{2-1} | |
| 1485 | [rd] discharged: | |
| 1486 | eq [TC]: s M#PNat + N@PNat = N@PNat + s M#PNat | |
| 1487 | [rd] discharged goal "2-1". | |
| 1488 | (consumed 0.0200 sec, including 4 rewrites + 31 matches) | |
| 1489 | ** All goals are successfully discharged. | |
| 1490 | ||
| 1491 | %PNAT-L> :show proof | |
| 1492 | root* | |
| 1493 | [si] 1* | |
| 1494 | [tc] 1-1* | |
| 1495 | [si] 2* | |
| 1496 | [tc] 2-1* | |
| 1497 | \end{simplev} | |
| 1498 | \end{vvtm} | |
| 1499 | これで，交換則の証明が完了した． | |
| 1500 | ||
| 1501 | 以上の証明は \verb|:apply (SI TC RD)| のようにして続けて自動で適用するようにできる． | |
| 1502 | この場合は，上の実施例のように TC を2度指定する必要はなくなる． | |
| 1503 | ||
| 1504 | 下の実行例で，:apply コマンドでノード指定(この場合 root)を指定している事に注意されたい. | |
| 1505 | ノードを指定すると，そのノードに対して引数の戦略を適用する. | |
| 1506 | この場合 root を指定しているため，これまで行った戦略適用をキャンセルし | |
| 1507 | 再び証明を開始するのに等しい. | |
| 1508 | ||
| 1509 | \begin{vvtm} | |
| 1510 | \begin{simplev} | |
| 1511 | %PNAT-L> :apply to root (SI TC RD) | |
| 1512 | ||
| 1513 | [si]=> :goal{root} | |
| 1514 | ** Generated 2 goals | |
| 1515 | [tc]=> :goal{1} | |
| 1516 | ** Generated 1 goal | |
| 1517 | [rd]=> :goal{1-1} | |
| 1518 | [rd] discharged: | |
| 1519 | eq [TC]: 0 + N@PNat = N@PNat + 0 | |
| 1520 | [rd] discharged goal "1-1". | |
| 1521 | [tc]=> :goal{2} | |
| 1522 | ** Generated 1 goal | |
| 1523 | [rd]=> :goal{2-1} | |
| 1524 | [rd] discharged: | |
| 1525 | eq [TC]: s M#PNat + N@PNat = N@PNat + s M#PNat | |
| 1526 | [rd] discharged goal "2-1". | |
| 1527 | (consumed 0.0320 sec, including 7 rewrites + 37 matches) | |
| 1528 | ** All goals are successfully discharged. | |
| 1529 | \end{simplev} | |
| 1530 | \end{vvtm} | |
| 1531 | ||
| 1532 | 上と同じことは，一旦 :select root として root をターゲット・ゴールとし， | |
| 1533 | 次いで :apply (si tc rd) としてもできる. | |
| 1534 | ||
| 1535 | \subsubsection{結合則の証明} | |
| 1536 | これまでと同じく，結合則も帰納法を用いて証明する． | |
| 1537 | 特に新たに説明が必要なものは使われていないため， | |
| 1538 | \verb|:verbose off| として :auto で実行した例を下に示す． | |
| 1539 | \begin{vvtm} | |
| 1540 | \begin{simplev} | |
| 1541 | %PNAT-L> :goal {eq (M:PNat + N:PNat) + P:PNat = N:PNat + (M:PNat + P:PNat) . } | |
| 1542 | :goal { ** root ----------------------------------------- | |
| 1543 | -- context module: % | |
| 1544 | -- axiom to be proved | |
| 1545 | eq (M:PNat + N:PNat) + P:PNat = N + (M + P) . | |
| 1546 | } | |
| 1547 | ** Initial goal (root) is generated. ** | |
| 1548 | %PNAT-L> :ind on (M:PNat) | |
| 1549 | **> Induction will be conducted on M:PNat | |
| 1550 | [si]=> :goal{root} | |
| 1551 | ** Generated 2 goals | |
| 1552 | [ca]=> :goal{1} | |
| 1553 | [tc]=> :goal{1} | |
| 1554 | [tc] discharged: | |
| 1555 | eq [TC]: N@PNat + P@PNat = N@PNat + P@PNat | |
| 1556 | [tc] discharged the goal "1-1" | |
| 1557 | ** Generated 1 goal | |
| 1558 | [ip]=> :goal{1-1} | |
| 1559 | [rd]=> :goal{1-1} | |
| 1560 | [ca]=> :goal{2} | |
| 1561 | [tc]=> :goal{2} | |
| 1562 | [tc] discharged: | |
| 1563 | eq [TC]: s (N@PNat + (M#PNat + P@PNat)) | |
| 1564 | = s (N@PNat + (M#PNat + P@PNat)) | |
| 1565 | [tc] discharged the goal "2-1" | |
| 1566 | ** Generated 1 goal | |
| 1567 | [ip]=> :goal{2-1} | |
| 1568 | [rd]=> :goal{2-1} | |
| 1569 | (consumed 0.0320 sec, including 9 rewrites + 128 matches) | |
| 1570 | ** All goals are successfully discharged. | |
| 1571 | ||
| 1572 | %PNAT-L> :show proof | |
| 1573 | root* | |
| 1574 | [si] 1* | |
| 1575 | [tc] 1-1* | |
| 1576 | [si] 2* | |
| 1577 | [tc] 2-1* | |
| 1578 | \end{simplev} | |
| 1579 | \end{vvtm} | |
| 1580 | ||
| 1581 | \section{場合分けによる証明} | |
| 1582 | 先の証明の例は場合分けが必要となるものではなかった． | |
| 1583 | ここでは戦略 CA を用いた場合分けによる証明を示す． | |
| 1584 | ||
| 1585 | \subsection{モジュール FG-FUN と証明対象} | |
| 1586 | ||
| 1587 | 下にモジュール FG-FUN の定義を示す． | |
| 1588 | この例題は Maude の CITP システムの例題を CafeOBJ 用に書きなおしたものである． | |
| 1589 | ||
| 1590 | \begin{vvtm} | |
| 1591 | \begin{simplev} | |
| 1592 | mod! FG-FUN { | |
| 1593 | pr(NAT) | |
| 1594 | op F : Nat -> Nat | |
| 1595 | op G : Nat -> Nat | |
| 1596 | ceq[CA-1]: F(X:Nat) = 5 if X <= 7 . | |
| 1597 | ceq[CA-2]: F(X:Nat) = 1 if 8 <= X . | |
| 1598 | ceq[CA-3]: G(Y:Nat) = 2 if Y <= 4 . | |
| 1599 | ceq[CA-4]: G(Y:Nat) = 7 if 5 <= Y . | |
| 1600 | } | |
| 1601 | \end{simplev} | |
| 1602 | \end{vvtm} | |
| 1603 | ||
| 1604 | 特に意味のないモジュール定義である． | |
| 1605 | 4つの条件付き等式が宣言されているが，それらは \texttt{CA} で始まる | |
| 1606 | ラベルを持っている．これはシステムに対して，これらの等式は | |
| 1607 | 場合分けのケースを網羅したものであり，これを用いて場合分けをするように | |
| 1608 | 指示するものである． | |
| 1609 | ||
| 1610 | 証明対象とする文は次の通りである． | |
| 1611 | \begin{vvtm} | |
| 1612 | \begin{simplev} | |
| 1613 | 9 <= G(F(X:Nat)) + G(X:Nat) = true | |
| 1614 | \end{simplev} | |
| 1615 | \end{vvtm} | |
| 1616 | いかなる時もこれが成立することを示すのが目標である． | |
| 1617 | 上の証明対象文に含まれている $F(X:Nat)$ と $G(X:Nat)$について， | |
| 1618 | それぞれが公理で宣言された 2 つのケースを持つため， | |
| 1619 | 可能なケースの組み合わせは表~\ref{tab:cases}のようになるはずである． | |
| 1620 | \begin{table} | |
| 1621 | \label{tab:cases} | |
| 1622 | \caption{可能な場合分けの組み合わせ} | |
| 1623 | \begin{center} | |
| 1624 | \begin{tabular}[htb]{|c|c|c|}\hline | |
| 1625 | &$F(X:Nat)$ & $G(X:Nat)$ \\\hline | |
| 1626 | (1)&$X \le 7$ & $X \le 4$ \\ | |
| 1627 | (2)&$X \le 7$ & $5 \le X$ \\ | |
| 1628 | (3)&$8 \le X$ & $X \le 4$ \\ | |
| 1629 | (4)&$8 \le X$ & $5 \le X$ \\\hline | |
| 1630 | \end{tabular} | |
| 1631 | \end{center} | |
| 1632 | \end{table} | |
| 1633 | ||
| 1634 | これらの組み合わせのうち，(3) のケースは | |
| 1635 | X が 8 以上かつ 4 以下という条件のためあり得ない． | |
| 1636 | 従ってシステムはこの組み合わせについてはこれを検知し， | |
| 1637 | 当該の条件を含むゴールを discharge できなければならない． | |
| 1638 | ||
| 1639 | \subsection{CITP for CafeOBJ による証明} | |
| 1640 | ||
| 1641 | 先に示したモジュール FG-FUN を文脈として証明を実施した例を以下に示す． | |
| 1642 | 個々の戦略の適用で作成されたゴールを見たいため，\verb|:verbose on| として実施した． | |
| 1643 | ||
| 1644 | また,各戦略で自動的に | |
| 1645 | ||
| 1646 | \begin{vvtm} | |
| 1647 | \begin{simplev} | |
| 1648 | FG-FUN> :goal { eq 9 <= G(F(X:Nat)) + G(X:Nat) = true . } | |
| 1649 | ||
| 1650 | :goal { ** root ----------------------------------------- | |
| 1651 | -- context module: FG-FUN | |
| 1652 | -- sentence to be proved | |
| 1653 | eq 9 <= (G(F(X:Nat)) + G(X)) = true . | |
| 1654 | } | |
| 1655 | ** Initial goal (root) is generated. ** | |
| 1656 | \end{simplev} | |
| 1657 | \end{vvtm} | |
| 1658 | ||
| 1659 | 上記のゴールに対して場合分けによる証明を行う． | |
| 1660 | 使用する戦略は (CA TC RD) である． | |
| 1661 | 以下システムの出力を幾つかに分割し，必要な説明を間に付加する形で示す． | |
| 1662 | ||
| 1663 | \begin{vvtm} | |
| 1664 | \begin{simplev} | |
| 1665 | FG-FUN> :apply (TC CA RD) | |
| 1666 | ||
| 1667 | [tc]=> :goal{root} | |
| 1668 | ** Generated 1 goal | |
| 1669 | [tc]=> | |
| 1670 | :goal { ** 1 ----------------------------------------- | |
| 1671 | -- context module: FG-FUN | |
| 1672 | -- introduced constant | |
| 1673 | op X@Nat : -> Nat { prec: 0 } | |
| 1674 | -- sentence to be proved | |
| 1675 | eq [TC]: 9 <= G(F(X@Nat)) + G(X@Nat) | |
| 1676 | = true . | |
| 1677 | } | |
| 1678 | \end{simplev} | |
| 1679 | \end{vvtm} | |
| 1680 | 最初にゴール root に TC が適用され，証明対象とする文 | |
| 1681 | \begin{verbatim} | |
| 1682 | eq 9 <= (G(F(X:Nat)) + G(X)) = true . | |
| 1683 | \end{verbatim} | |
| 1684 | の \texttt{X} を \verb|X@Nat| に置き換えた文とした新たなゴール 1 を生成している． | |
| 1685 | ||
| 1686 | 次にこのゴール1に対して戦略 CA が適用され，先に見た4つのケース毎に | |
| 1687 | ゴールが生成されている． | |
| 1688 | CAはケースを新たな公理として導入後，それらの間に矛盾が無いかどうかを | |
| 1689 | チェックする． | |
| 1690 | 現在は整数の順序関係の定義に矛盾が無いかどうかのみが検査される. | |
| 1691 | これによってゴール1-3が discharge されている． | |
| 1692 | ||
| 1693 | \begin{vvtm} | |
| 1694 | \begin{simplev} | |
| 1695 | [ca]=> :goal{1} | |
| 1696 | [le] discharged the goal "1-3" | |
| 1697 | ** Generated 4 goals | |
| 1698 | \end{simplev} | |
| 1699 | \end{vvtm} | |
| 1700 | ||
| 1701 | 以下ではシステムが生成した個々のゴールの内容をみる． | |
| 1702 | ||
| 1703 | \begin{vvtm} | |
| 1704 | \begin{simplev} | |
| 1705 | [ca]=> | |
| 1706 | :goal { ** 1-1 ----------------------------------------- | |
| 1707 | -- context module: FG-FUN | |
| 1708 | -- introduced constant | |
| 1709 | op X@Nat : -> Nat { prec: 0 } | |
| 1710 | -- introduced axioms | |
| 1711 | eq [CA]: 5 <= X@Nat = true . | |
| 1712 | eq [CA]: X@Nat <= 7 = true . | |
| 1713 | -- sentence to be proved | |
| 1714 | eq [TC]: 9 <= G(F(X@Nat)) + G(X@Nat) | |
| 1715 | = true . | |
| 1716 | } | |
| 1717 | [ca]=> | |
| 1718 | \end{simplev} | |
| 1719 | \end{vvtm} | |
| 1720 | ゴール1-1は先の表~\ref{tab:cases}に示した(2)のケースに対応する． | |
| 1721 | 文脈モジュール FG-FUN で宣言されていた公理 | |
| 1722 | \begin{verbatim} | |
| 1723 | ceq[CA-1]: F(X:Nat) = 5 if X <= 7 . | |
| 1724 | ceq[CA-2]: F(X:Nat) = 1 if 8 <= X . | |
| 1725 | ceq[CA-3]: G(Y:Nat) = 2 if Y <= 4 . | |
| 1726 | ceq[CA-4]: G(Y:Nat) = 7 if 5 <= Y . | |
| 1727 | \end{verbatim} | |
| 1728 | のうち，CA-1 とCA-4 からこれらのケースが得られている． | |
| 1729 | ||
| 1730 | \begin{vvtm} | |
| 1731 | \begin{simplev} | |
| 1732 | [ca]=> | |
| 1733 | :goal { ** 1-2 ----------------------------------------- | |
| 1734 | -- context module: FG-FUN | |
| 1735 | -- introduced constant | |
| 1736 | op X@Nat : -> Nat { prec: 0 } | |
| 1737 | -- introduced axioms | |
| 1738 | eq [CA]: 5 <= X@Nat = true . | |
| 1739 | eq [CA]: 8 <= X@Nat = true . | |
| 1740 | -- sentence to be proved | |
| 1741 | eq [TC]: 9 <= G(F(X@Nat)) + G(X@Nat) | |
| 1742 | = true . | |
| 1743 | } | |
| 1744 | } | |
| 1745 | \end{simplev} | |
| 1746 | \end{vvtm} | |
| 1747 | ゴール 1-2 は表~\ref{tab:cases}のケース(4)に対応している． | |
| 1748 | ||
| 1749 | \begin{vvtm} | |
| 1750 | \begin{simplev} | |
| 1751 | :goal { ** 1-3 ----------------------------------------- | |
| 1752 | -- context module: FG-FUN | |
| 1753 | -- discharged sentence | |
| 1754 | eq [LE TC]: 9 <= G(F(X@Nat)) + G(X@Nat) | |
| 1755 | = true . | |
| 1756 | -- introduced constant | |
| 1757 | op X@Nat : -> Nat { prec: 0 } | |
| 1758 | -- introduced axioms | |
| 1759 | eq [CA]: X@Nat <= 4 = true . | |
| 1760 | eq [CA]: 8 <= X@Nat = true . | |
| 1761 | } << proved >> | |
| 1762 | \end{simplev} | |
| 1763 | \end{vvtm} | |
| 1764 | ゴール1-3は表~\ref{tab:cases}のケース(3)に対応する． | |
| 1765 | 先に述べたとおり，導入された公理は互いに矛盾するため， | |
| 1766 | システムはこのゴールを discharge している． | |
| 1767 | discharge された証明対象であった文は， | |
| 1768 | ゴールの表示上ラベル LE を追加した文として表示されている． | |
| 1769 | ||
| 1770 | \begin{vvtm} | |
| 1771 | \begin{simplev} | |
| 1772 | [ca]=> | |
| 1773 | :goal { ** 1-4 ----------------------------------------- | |
| 1774 | -- context module: FG-FUN | |
| 1775 | -- introduced constant | |
| 1776 | op X@Nat : -> Nat { prec: 0 } | |
| 1777 | -- introduced axioms | |
| 1778 | eq [CA]: X@Nat <= 4 = true . | |
| 1779 | eq [CA]: X@Nat <= 7 = true . | |
| 1780 | -- sentence to be proved | |
| 1781 | eq [TC]: 9 <= G(F(X@Nat)) + G(X@Nat) | |
| 1782 | = true . | |
| 1783 | } | |
| 1784 | \end{simplev} | |
| 1785 | \end{vvtm} | |
| 1786 | CAが生成した最後にのゴール1-4は表~\ref{tab:cases}に示したケース | |
| 1787 | (1) に対応する． | |
| 1788 | ||
| 1789 | 以上のCAが生成した4つのゴールのうち，1個(1-3)は既に CA の | |
| 1790 | 内部処理によって discharge されている．残りの3ゴールに対して | |
| 1791 | RD が適用される．RD が行うことは文の充足性検査と矛盾の検査であった. | |
| 1792 | ||
| 1793 | \begin{vvtm} | |
| 1794 | \begin{simplev} | |
| 1795 | [rd]=> :goal{1-1} | |
| 1796 | [rd] discharged: | |
| 1797 | eq [TC]: 9 <= G(F(X@Nat)) + G(X@Nat) = true | |
| 1798 | [rd] discharged goal "1-1". | |
| 1799 | [rd]=> :goal{1-2} | |
| 1800 | [rd] discharged: | |
| 1801 | eq [TC]: 9 <= G(F(X@Nat)) + G(X@Nat) = true | |
| 1802 | [rd] discharged goal "1-2". | |
| 1803 | [rd]=> :goal{1-3} | |
| 1804 | [rd]=> :goal{1-4} | |
| 1805 | [rd] discharged: | |
| 1806 | eq [TC]: 9 <= G(F(X@Nat)) + G(X@Nat) = true | |
| 1807 | [rd] discharged goal "1-4". | |
| 1808 | (consumed 0.0320 sec, including 35 rewrites + 117 matches) | |
| 1809 | ** All goals are successfully discharged. | |
| 1810 | \end{simplev} | |
| 1811 | \end{vvtm} | |
| 1812 | ||
| 1813 | 上の実行例の通り，全てのゴールが満足されている． | |
| 1814 | ||
| 1815 | 以上の証明の結果に対応する証明木を表示すると次のようになる． | |
| 1816 | \begin{vvtm} | |
| 1817 | \begin{simplev} | |
| 1818 | FG-FUN> :show proof | |
| 1819 | root* | |
| 1820 | [tc] 1* | |
| 1821 | [ca] 1-1* | |
| 1822 | [ca] 1-2* | |
| 1823 | [ca] 1-3* | |
| 1824 | [ca] 1-4* | |
| 1825 | \end{simplev} | |
| 1826 | \end{vvtm} | |
| 1827 | RD はゴールを生成しないため，証明木上で新たなノードは表示されていない． | |
| 1828 | 結果を確認するため，ゴール1-1を表示してみると次のようになる． | |
| 1829 | \begin{vvtm} | |
| 1830 | \begin{simplev} | |
| 1831 | FG-FUN> :show goal 1-1 | |
| 1832 | ||
| 1833 | [ca]=> | |
| 1834 | :goal { ** 1-1 ----------------------------------------- | |
| 1835 | -- context module: FG-FUN | |
| 1836 | -- discharged sentence | |
| 1837 | eq [RD TC]: 9 <= G(F(X@Nat)) + G(X@Nat) | |
| 1838 | = true . | |
| 1839 | -- introduced constant | |
| 1840 | op X@Nat : -> Nat { prec: 0 } | |
| 1841 | -- introduced axioms | |
| 1842 | eq [CA]: 5 <= X@Nat = true . | |
| 1843 | eq [CA]: X@Nat <= 7 = true . | |
| 1844 | } << proved >> | |
| 1845 | \end{simplev} | |
| 1846 | \end{vvtm} | |
| 1847 | RD によって discharge された文は，ラベルに RD が追加されて表示される． | |
| 1848 | これによって，RD の適用による discharge であったことを知ることができる． | |
| 1849 | ||
| 1850 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% | |
| 1851 | \bibliographystyle{plain} | |
| 1852 | \bibliography{bib} | |
| 1853 | \end{document} | |
| 1854 | %%% Local Variables: | |
| 1855 | %%% mode: latex | |
| 1856 | %%% TeX-master: t | |
| 1857 | %%% End: |
Binary diff not shown
Binary diff not shown
| 0 | \tikzstyle{goal} = [draw, rectangle, minimum width=1cm, minimum height=2em, very thick, rounded corners=1mm] | |
| 1 | \tikzstyle{ded} = [-stealth,very thick] | |
| 2 | \begin{tikzpicture}[node distance=3cm] | |
| 3 | \node at (0,4) (g) [goal] {g}; | |
| 4 | \node at (-3,2) (g-1) [goal] {g-1}; | |
| 5 | \node at (0,2) (g-2) [goal] {g-2}; | |
| 6 | \node at (3,2) (g-3) [goal] {g-3}; | |
| 7 | \node [left of=g,node distance=0.5cm,anchor=east] | |
| 8 | {\texttt{\texttt{:csp \{ eq1 .\ eq2 .\ eq 3 .\ \}}}}; | |
| 9 | \draw[rounded corners=3mm] (-4,1.4) rectangle (4,2.6); | |
| 10 | \path[ded] (g) edge node[fill=white] {:csp} (g-1) | |
| 11 | edge node[fill=white] {:csp} (g-2) | |
| 12 | edge node[fill=white] {:csp} (g-3) ; | |
| 13 | \node at (-3,0.5) (a1) {g + \texttt{\{ eq 1\ .\ \}}} ; | |
| 14 | \node at ( 0,0.5) (a2) {g + \texttt{\{ eq 2\ .\ \}}} ; | |
| 15 | \node at ( 3,0.5) (a3) {g + \texttt{\{ eq 3\ .\ \}}} ; | |
| 16 | \path[-stealth,dashed] (a1) edge (g-1) ; | |
| 17 | \path[-stealth,dashed] (a2) edge (g-2) ; | |
| 18 | \path[-stealth,dashed] (a3) edge (g-3) ; | |
| 19 | \node at (-4.2,2) [anchor=east] {\texttt{:apply(RD)}} ; | |
| 20 | \end{tikzpicture} |
Binary diff not shown
Binary diff not shown
| 0 | \tikzstyle{goal} = [draw, rectangle, minimum width=1cm, minimum height=2em, very thick, rounded corners=1mm] | |
| 1 | \tikzstyle{ded} = [-stealth,very thick] | |
| 2 | \begin{tikzpicture}[node distance=3cm] | |
| 3 | \node at (0,4) (g) [goal] {g}; | |
| 4 | \node at (-3,2) (g-1) [goal] {g-1}; | |
| 5 | \node at (3,2) (g-2) [goal] {g-2}; | |
| 6 | \node [left of=g,node distance=0.5cm,anchor=east] {\texttt{:ctf \{ eq l = r . \}}}; | |
| 7 | \draw[rounded corners=3mm] (-4,1.4) rectangle (4,2.6); | |
| 8 | \path[ded] (g) edge node[fill=white] {:ctf} (g-1) | |
| 9 | edge node[fill=white] {:ctf} (g-2) ; | |
| 10 | \node at (-4.8,0.5) (a) [anchor=west] {g + \texttt{\{ eq l = r . \}}} ; | |
| 11 | \node at (4,0.5) (b) [anchor=east] {g + \texttt{\{ eq (l = r) = false . \}}} ; | |
| 12 | \path[-stealth,dashed] (a) edge (g-1) ; | |
| 13 | \path[-stealth,dashed] (b) edge (g-2) ; | |
| 14 | % \node at (-4.2,2) [anchor=east] {\texttt{:apply(RD)}} ; | |
| 15 | \end{tikzpicture} |
| 0 | \tikzstyle{goal} = [draw, rectangle, minimum width=1cm, minimum height=2em, very thick, rounded corners=1mm] | |
| 1 | \tikzstyle{ded} = [-stealth,very thick] | |
| 2 | \begin{tikzpicture}[node distance=3cm] | |
| 3 | \node at (0,4) (g) [goal] {g}; | |
| 4 | \node at (-3,2) (g-1) [goal] {g-1}; | |
| 5 | \node at (3,2) (g-2) [goal] {g-2}; | |
| 6 | \node [left of=g,node distance=0.5cm,anchor=east] {\texttt{:ctf [ t . ]}}; | |
| 7 | \draw[rounded corners=3mm] (-4,1.4) rectangle (4,2.6); | |
| 8 | \path[ded] (g) edge node[fill=white] {:ctf} (g-1) | |
| 9 | edge node[fill=white] {:ctf} (g-2) ; | |
| 10 | \node at (-4.8,0.5) (a) [anchor=west] {g + \texttt{\{ eq t = true . \}}} ; | |
| 11 | \node at (4,0.5) (b) [anchor=east] {g + \texttt{\{ eq t = false . \}}} ; | |
| 12 | \path[-stealth,dashed] (a) edge (g-1) ; | |
| 13 | \path[-stealth,dashed] (b) edge (g-2) ; | |
| 14 | % \node at (-4.2,2) [anchor=east] {\texttt{:apply(RD)}} ; | |
| 15 | \end{tikzpicture} |
| 0 | ** CITP on Maude | |
| 1 | -- (fmod FG-FUN is | |
| 2 | -- protecting NAT . | |
| 3 | -- op F : Nat -> Nat . | |
| 4 | -- op G : Nat -> Nat . | |
| 5 | -- vars X Y : Nat . | |
| 6 | -- ceq F(X) = 5 if X <= 7 [metadata "CA-"]. | |
| 7 | -- ceq F(X) = 1 if 8 <= X [metadata "CA-"]. | |
| 8 | -- ceq G(Y) = 2 if Y <= 4 [metadata "CA-"]. | |
| 9 | -- ceq G(Y) = 7 if 5 <= Y [metadata "CA-"]. | |
| 10 | -- endfm) | |
| 11 | ||
| 12 | mod! FG-FUN { | |
| 13 | pr(NAT) | |
| 14 | op F : Nat -> Nat | |
| 15 | op G : Nat -> Nat | |
| 16 | ceq [CA-1]: F(X:Nat) = 5 if X <= 7 . | |
| 17 | ceq [CA-2]: F(X:Nat) = 1 if 8 <= X . | |
| 18 | ceq [CA-3]: G(Y:Nat) = 2 if Y <= 4 . | |
| 19 | ceq [CA-4]: G(Y:Nat) = 7 if 5 <= Y . | |
| 20 | } | |
| 21 | ||
| 22 | select FG-FUN . | |
| 23 | :set(spoiler, off) | |
| 24 | **> ':verbose on' => print out every generated goal in the process of proof | |
| 25 | :verbose on | |
| 26 | :goal { eq 9 <= G(F(X:Nat)) + G(X:Nat) = true . } | |
| 27 | :apply (TC CA RD) | |
| 28 | **> show proof prints out the tree of the current proof tree. | |
| 29 | :show proof | |
| 30 | ||
| 31 | eof | |
| 32 |
Binary diff not shown
| 0 | ** | |
| 1 | ** Prove associativity and commutativity of addition | |
| 2 | ** using CITP for CafeOBJ | |
| 3 | ** | |
| 4 | ||
| 5 | mod! PNAT { | |
| 6 | [ PZero PNzNat < PNat ] | |
| 7 | op 0 : -> PZero {ctor} . | |
| 8 | op s_ : PNat -> PNzNat {ctor} . | |
| 9 | op _+_ : PNat PNat -> PNat . | |
| 10 | eq 0 + N:PNat = N . | |
| 11 | eq s M:PNat + N:PNat = s(M + N) . | |
| 12 | } | |
| 13 | ||
| 14 | select PNAT . | |
| 15 | :goal { eq [lemma-1]: M:PNat + 0 = M:PNat . | |
| 16 | eq [lemma-2]: M:PNat + s N:PNat = s(M:PNat + N:PNat). } | |
| 17 | ||
| 18 | :ind on (M:PNat) | |
| 19 | ||
| 20 | **> We want to see every goal generated in proof process. | |
| 21 | :verbose on | |
| 22 | **> We do the proof by 'auto' | |
| 23 | :auto | |
| 24 | ||
| 25 | **> :show proof shows the current proof tree . | |
| 26 | **> at this time, all goals should have been proved. | |
| 27 | :show proof | |
| 28 | ||
| 29 | ** Proof of commuativity and associativity of _+_ | |
| 30 | ||
| 31 | mod! PNAT-L { | |
| 32 | inc(PNAT) | |
| 33 | -- we have already prooved these. | |
| 34 | eq [lemma-1]: N:PNat + 0 = N . | |
| 35 | eq [lemma-2]: M:PNat + s N:PNat = s(M + N). | |
| 36 | } | |
| 37 | ||
| 38 | open PNAT-L . | |
| 39 | :goal { eq M:PNat + N:PNat = N:PNat + M:PNat . } | |
| 40 | --> induction on variable M:PNat | |
| 41 | :ind on (M:PNat) | |
| 42 | --> :apply (si) | |
| 43 | :apply (SI) | |
| 44 | --> :show proof should shows base case and induction step | |
| 45 | :show proof | |
| 46 | --> :apply (tc) | |
| 47 | :verbose off | |
| 48 | :apply (TC) | |
| 49 | --> :apply (rd) | |
| 50 | :apply (RD) | |
| 51 | --> :show proof | |
| 52 | :show proof | |
| 53 | --> rest :apply (tc rd) | |
| 54 | :apply (TC RD) | |
| 55 | --> done for all | |
| 56 | :show proof | |
| 57 | **> we redo the same proof by one :apply | |
| 58 | :apply to root (SI TC RD) | |
| 59 | **> the above is equvalent to the followings | |
| 60 | --> select root | |
| 61 | :select root | |
| 62 | :apply (SI TC RD) | |
| 63 | ||
| 64 | ** associativity | |
| 65 | --> use :auto | |
| 66 | :goal {eq (M:PNat + N:PNat) + P:PNat = N:PNat + (M:PNat + P:PNat) . } | |
| 67 | :ind on (M:PNat) | |
| 68 | :auto | |
| 69 | :show proof | |
| 70 | eof | |
| 71 | ||
| 72 | ||
| 73 | ||
| 74 | ||
| 75 |
Binary diff not shown
Binary diff not shown
| 0 | \tikzstyle{goal} = [draw, rectangle, minimum width=1cm, minimum height=2em, very thick, rounded corners=1mm] | |
| 1 | \tikzstyle{ded} = [-stealth,very thick] | |
| 2 | \begin{tikzpicture}[node distance=2cm] | |
| 3 | \node (root) [goal] {root}; | |
| 4 | \node (2) [goal,below of=root] {2}; | |
| 5 | \node (1) [goal,left of=2] {1}; | |
| 6 | \node (dots1) [goal,right of=2] {\ldots}; | |
| 7 | \node (1-2) [goal,below of=1] {1-2}; | |
| 8 | \node (1-1) [goal,left of=1-2] {1-1}; | |
| 9 | \node (2-1) [goal,right of=1-2] {2-1}; | |
| 10 | \node (2-2) [goal,right of=2-1] {2-2}; | |
| 11 | \node (1-2-2) [goal,below of=1-2] {1-2-2}; | |
| 12 | \node (1-2-1) [goal,left of=1-2-2] {1-2-1}; | |
| 13 | \node (dots2) [goal,right of=1-2-2] {\ldots}; | |
| 14 | \path[ded] (root) edge node[fill=white] {T1} (1) | |
| 15 | edge node[fill=white] {T1} (2) | |
| 16 | edge node[fill=white] {T1} (dots1) ; | |
| 17 | \path[ded] (1) edge node[fill=white] {T2} (1-1) | |
| 18 | edge node[fill=white] {T2} (1-2) ; | |
| 19 | \path[ded] (2) edge node[fill=white] {T3} (2-1) | |
| 20 | edge node[fill=white] {T3} (2-2) ; | |
| 21 | \path[ded] (1-2) edge node[fill=white] {Tn} (1-2-1) | |
| 22 | edge node[fill=white] {Tn} (1-2-2) | |
| 23 | edge node[fill=white] {Tn} (dots2) ; | |
| 24 | ||
| 25 | \end{tikzpicture} | |
| 26 |
| 0 | \tikzstyle{goal} = [draw, rectangle, minimum width=1cm, minimum height=2em, very thick, rounded corners=1mm] | |
| 1 | \tikzstyle{target} = [draw, fill=gray, rectangle, minimum width=1cm, minimum height=2em, very thick, rounded corners=1mm] | |
| 2 | \tikzstyle{ded} = [-stealth,very thick] | |
| 3 | \begin{tikzpicture}[node distance=2cm] | |
| 4 | \node (root) [goal] {root}; | |
| 5 | \node (2) [goal,below of=root] {2}; | |
| 6 | \node (1) [goal,left of=2] {1}; | |
| 7 | \node (dots1) [goal,right of=2] {\ldots}; | |
| 8 | \node (1-2) [goal,below of=1] {1-2}; | |
| 9 | \node (1-1) [target,left of=1-2] {1-1}; | |
| 10 | \node (2-1) [goal,right of=1-2] {2-1}; | |
| 11 | \node (2-2) [goal,right of=2-1] {2-2}; | |
| 12 | \path[ded] (root) edge node[fill=white] {T1} (1) | |
| 13 | edge node[fill=white] {T1} (2) | |
| 14 | edge node[fill=white] {T1} (dots1) ; | |
| 15 | \path[ded] (1) edge node[fill=white] {T2} (1-1) | |
| 16 | edge node[fill=white] {T2} (1-2) ; | |
| 17 | \path[ded] (2) edge node[fill=white] {T3} (2-1) | |
| 18 | edge node[fill=white] {T3} (2-2) ; | |
| 19 | \end{tikzpicture} | |
| 20 | $$ | |
| 21 | \Downarrow\mbox{:select 2} | |
| 22 | $$ | |
| 23 | \begin{tikzpicture}[node distance=2cm] | |
| 24 | \node (root) [goal] {root}; | |
| 25 | \node (2) [target,below of=root] {2}; | |
| 26 | \node (1) [goal,left of=2] {1}; | |
| 27 | \node (dots1) [goal,right of=2] {\ldots}; | |
| 28 | \node (1-2) [goal,below of=1] {1-2}; | |
| 29 | \node (1-1) [goal,left of=1-2] {1-1}; | |
| 30 | \path[ded] (root) edge node[fill=white] {T1} (1) | |
| 31 | edge node[fill=white] {T1} (2) | |
| 32 | edge node[fill=white] {T1} (dots1) ; | |
| 33 | \path[ded] (1) edge node[fill=white] {T2} (1-1) | |
| 34 | edge node[fill=white] {T2} (1-2) ; | |
| 35 | \end{tikzpicture} | |
| 36 |
| 3 | 3 | -- imperative program", MIT Press. |
| 4 | 4 | -- * program codes are converted from OBJ to CafeOBJ |
| 5 | 5 | -- |
| 6 | "ZZ extends CafeoBJ's built-in representation of the integers with an | |
| 6 | ||
| 7 | #|------------------------------ | |
| 8 | ZZ extends CafeoBJ's built-in representation of the integers with an | |
| 7 | 9 | equality predicate, _is_, and with some equations that are useful for |
| 8 | 10 | manipulating inequalities. In paricular, these equations are useful |
| 9 | 11 | as lemmas in the correctness proof given in the book. For example, |
| 18 | 20 | lemma for the proof. In fact, there is not set of equations that can allow |
| 19 | 21 | the automatic verification of all properties of integer expressions which |
| 20 | 22 | contain indeterminate values such as `s[['X]]'; in other words, first order |
| 21 | arithmetic is \"undecidable\". | |
| 22 | " | |
| 23 | arithmetic is "undecidable". | |
| 24 | --------------------------|# | |
| 23 | 25 | |
| 24 | 26 | module ZZ { |
| 25 | 27 | imports { |
| 26 | 28 | protecting (INT) |
| 27 | 29 | } |
| 28 | 30 | signature { |
| 29 | "The predicate _is_ is intended to represent equality on integers. | |
| 31 | #| | |
| 32 | The predicate _is_ is intended to represent equality on integers. | |
| 30 | 33 | The reason for introducing a new equality predicate rather then |
| 31 | 34 | using CafeOBJ's builtin equality _==_ is that we want to use |
| 32 | 35 | integer expressions which indeterminate values in program |
| 33 | correctness proofs (cf. Section 2.1.1 of Chapter2). " | |
| 36 | correctness proofs (cf. Section 2.1.1 of Chapter2). | |
| 37 | |# | |
| 34 | 38 | op _is_ : Int Int -> Bool |
| 35 | 39 | } |
| 36 | 40 | axioms { |
| 0 | ** | |
| 1 | ** polynomial.cafe | |
| 2 | ** | |
| 3 | ** parametrized polynomials over commutative rings | |
| 4 | ** | |
| 5 | ** | |
| 6 | ** Copyright (c) 2015, Norbert Preining. All rights reserved. | |
| 7 | ** | |
| 8 | ** Redistribution and use in source and binary forms, with or without | |
| 9 | ** modification, are permitted provided that the following conditions | |
| 10 | ** are met: | |
| 11 | ** | |
| 12 | ** * Redistributions of source code must retain the above copyright | |
| 13 | ** notice, this list of conditions and the following disclaimer. | |
| 14 | ** | |
| 15 | ** * Redistributions in binary form must reproduce the above | |
| 16 | ** copyright notice, this list of conditions and the following | |
| 17 | ** disclaimer in the documentation and/or other materials | |
| 18 | ** provided with the distribution. | |
| 19 | ** | |
| 20 | ** THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED | |
| 21 | ** OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED | |
| 22 | ** WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE | |
| 23 | ** ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY | |
| 24 | ** DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL | |
| 25 | ** DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE | |
| 26 | ** GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS | |
| 27 | ** INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, | |
| 28 | ** WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING | |
| 29 | ** NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS | |
| 30 | ** SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. | |
| 31 | ** | |
| 32 | ||
| 33 | mod* RING { | |
| 34 | [ Elem ] | |
| 35 | op OO : -> Elem { constr } | |
| 36 | op II : -> Elem { constr } | |
| 37 | op _ + _ : Elem Elem -> Elem { comm assoc }. | |
| 38 | op _ - _ : Elem Elem -> Elem . | |
| 39 | op _ * _ : Elem Elem -> Elem { comm assoc }. | |
| 40 | eq OO + E:Elem = E . | |
| 41 | eq II * E:Elem = E . | |
| 42 | } | |
| 43 | ||
| 44 | mod! POLYNOMIAL ( COEFF :: RING ) { | |
| 45 | pr(INT) | |
| 46 | [ Elem < Poly ] | |
| 47 | vars I I1 I2 I3 : Elem . | |
| 48 | vars N N1 N2 N3 : Nat . | |
| 49 | vars M M1 M2 M3 : Nat . | |
| 50 | vars IP IP1 IP2 IP3 IP4 : Poly . | |
| 51 | ||
| 52 | op X^_ : Nat -> Poly {constr} . | |
| 53 | ||
| 54 | op _ + _ : Poly Poly -> Poly { assoc comm } . | |
| 55 | op _ - _ : Poly Poly -> Poly . | |
| 56 | op - _ : Poly -> Poly . | |
| 57 | op _ * _ : Poly Poly -> Poly { assoc comm } . | |
| 58 | ||
| 59 | eq OO + IP = IP . | |
| 60 | eq II * IP = IP . | |
| 61 | ||
| 62 | ||
| 63 | eq ( IP - IP1 ) = ( IP + ( - IP1 ) ) . | |
| 64 | eq IP + (- IP) = OO . | |
| 65 | eq X^ 0 = II . | |
| 66 | ||
| 67 | -- normalization of polynomial expressions | |
| 68 | eq ( I1 * ( X^ N ) ) + ( I2 * ( X^ N ) ) = ( I1 + I2 ) * ( X^ N ) . | |
| 69 | -- we have to treat the implicite 1 * explicitly | |
| 70 | eq ( X^ N ) + ( I2 * ( X^ N ) ) = ( II + I2 ) * ( X^ N ) . | |
| 71 | eq ( ( X^ N ) * ( X^ N1 ) ) = X^ ( N + N1 ) . | |
| 72 | ||
| 73 | -- now for the polynom operation | |
| 74 | eq ( IP1 + IP2 ) * IP3 = (IP1 * IP3) + (IP2 * IP3) . | |
| 75 | ||
| 76 | op max : Nat Nat -> Nat { strat: (1 2 0) } . | |
| 77 | ceq max ( N , M ) = N if ( N >= M ) . | |
| 78 | ceq max ( N , M ) = M if ( M >= N ) . | |
| 79 | ||
| 80 | op rank : Poly -> Nat . | |
| 81 | eq rank ( I * IP ) = rank ( IP ) . | |
| 82 | eq rank ( I ) = 0 . | |
| 83 | eq rank ( X^ N ) = N . | |
| 84 | eq rank ( IP + IP2 ) = max ( rank ( IP ) , rank ( IP2 ) ) . | |
| 85 | } | |
| 86 | ||
| 87 | ||
| 88 | ** end of the input file | |
| 89 | eof | |
| 90 | ||
| 91 | ** | |
| 92 | ** for testing and usage, see below examples | |
| 93 | ** | |
| 94 | ||
| 95 | view INT-AS-RING from RING to INT { | |
| 96 | sort Elem -> Int, | |
| 97 | op OO -> 0, | |
| 98 | op II -> 1 | |
| 99 | } | |
| 100 | ||
| 101 | open POLYNOMIAL(COEFF <= INT-AS-RING) . | |
| 102 | red 3 * X^ 2 + 5 * X^ 2 . | |
| 103 | red 4 * X^ 2 - 2 * X^ 2 . | |
| 104 | red ( 3 * X^ 1 * 4 * X^ 3 ) . | |
| 105 | red ( 3 * X^ 1 * -4 * X^ 3 ) . | |
| 106 | red ( ( 3 * X^ 2 + X^ 1 + 2 * X^ 0 ) * ( X^ 1 + X^ 0 ) ) . | |
| 107 | -- set trace whole on | |
| 108 | red ( ( 3 * X^ 2 + X^ 1 + 2 * X^ 0 ) * ( X^ 1 - X^ 0 ) ) . | |
| 109 | close | |
| 110 | ||
| 111 | view RAT-AS-RING from RING to RAT { | |
| 112 | sort Elem -> Rat, | |
| 113 | op OO -> 0, | |
| 114 | op II -> 1 | |
| 115 | } | |
| 116 | ||
| 117 | open POLYNOMIAL(COEFF <= RAT-AS-RING) . | |
| 118 | red ( ( 3/2 * X^ 2 + X^ 1 + 2/5 * X^ 0 ) * ( X^ 1 - 3/2 * X^ 0 ) ) . | |
| 119 | red ( X^ 3 - X^ 1 + 5/3 ) * ( X^ 2 + 2/9 * X^ 1 - 7/3 ) . | |
| 120 | ||
| 121 | red rank ( ( 3/2 * X^ 2 + X^ 1 + 2/5 * X^ 0 ) * ( X^ 1 - 3/2 * X^ 0 ) ) . | |
| 122 |
| 6282 | 6282 | %\end{ccode} |
| 6283 | 6283 | %\end{vvtm} |
| 6284 | 6284 | |
| 6285 | \subsection{Coherence} \label{sec:p2-coherence} | |
| 6285 | \section{Coherence} \label{sec:p2-coherence} | |
| 6286 | 6286 | |
| 6287 | 6287 | As explained in Section \ref{sec:p2-evaluation-command} and |
| 6288 | 6288 | \ref{sec:p2-eval-exs-3}, |
| 32 | 32 | <li><a href="#gorydetails">Gory Details</a><ul> |
| 33 | 33 | <li><a href="#ctrld">Ctrl-D</a></li> |
| 34 | 34 | <li><a href="#commandexec"><code>! <command></code></a></li> |
| 35 | <li><a href="#sharp-define"><code>#define</code></a></li> | |
| 35 | <li><a href="#sharp-define"><code>#define <symbol> := <term> .</code></a></li> | |
| 36 | 36 | <li><a href="#starstar"><code>**</code>, <code>**></code></a></li> |
| 37 | 37 | <li><a href="#dashdash"><code>--</code>, <code>--></code></a></li> |
| 38 | 38 | <li><a href="#dotsep"><code>.</code></a></li> |
| 39 | <li><a href="#apply-tactic-...-to-goal-name-apply"><code>:apply (<tactic> ...) [to <goal-name>]</code> ## {#:apply}</a></li> | |
| 40 | <li><a href="#auto-auto"><code>:auto</code> ## {#:auto}</a></li> | |
| 41 | <li><a href="#backward-equation-backward"><code>:backward equation</code> ## {#:backward}</a></li> | |
| 42 | <li><a href="#cp-label-axiom-.-label-axiom-.-cp"><code>:cp { "[" <label> "]" | "(" <axiom> . ")" } >< { "[" <label> "]" | "(" <axiom> .")" }</code> ## {#:cp}</a></li> | |
| 43 | <li><a href="#csp-eq-op-exp-term-term-.-...-csp"><code>:csp { eq [ <op-exp>]: <term> = <term> . ...}</code> ## {#:csp}</a></li> | |
| 44 | <li><a href="#ctf-eq-op-exp-term-term-.-ctf"><code>:ctf { eq [ <op-exp> ]: <term> = <term> .</code> ## {#:ctf}</a></li> | |
| 45 | <li><a href="#describe-something-describe"><code>:describe <something></code> ## {#:describe}</a></li> | |
| 46 | <li><a href="#equation-equation"><code>:equation</code> ## {#:equation}</a></li> | |
| 47 | <li><a href="#goal-axiom-.-...-goal"><code>:goal { <axiom> . ... }</code> ## {#:goal}</a></li> | |
| 48 | <li><a href="#ind-on-variable-...-.-ind"><code>:ind on <variable> ... .</code> ## {#:ind}</a></li> | |
| 49 | <li><a href="#init-label-axiom-variable---term-...-init"><code>:init { "[" <label> "]" | "(" <axiom> "")} "{" <variable> <- <term>; ... "}"</code> ## {#:init}</a></li> | |
| 50 | <li><a href="#is-is"><code>:is</code> ## {#:is}</a></li> | |
| 51 | <li><a href="#lred-term-.-red"><code>:lred <term> .</code> ## {#:red}</a></li> | |
| 52 | <li><a href="#roll-back-roll"><code>:roll back</code> ## {#:roll}</a></li> | |
| 53 | <li><a href="#rule-rule"><code>:rule</code> ## {#:rule}</a></li> | |
| 54 | <li><a href="#select-goal-name-select"><code>:select <goal-name></code> ## {#:select}</a></li> | |
| 55 | <li><a href="#show-something-show"><code>:show <something></code> ## {#:show}</a></li> | |
| 56 | <li><a href="#verbose-on-off-verbose"><code>:verbose { on | off }</code> ## {#:verbose}</a></li> | |
| 57 | 39 | <li><a href="#axeq"><code>=</code></a></li> |
| 58 | 40 | <li><a href="#searchpredsymb"><code>=(n)=></code>, <code>=(n,m)=></code>, <code>=()=></code></a></li> |
| 59 | 41 | <li><a href="#bequality"><code>=*=</code></a></li> |
| 62 | 44 | <li><a href="#transrel"><code>==></code></a></li> |
| 63 | 45 | <li><a href="#help"><code>? [<term>]</code></a></li> |
| 64 | 46 | <li><a href="#apropos"><code>?apropos <term> [<term> ...]</code></a></li> |
| 47 | <li><a href="#help-commands"><code>?com [ <term> ]</code></a></li> | |
| 65 | 48 | <li><a href="#sortsymbol"><code>[</code></a></li> |
| 66 | 49 | <li><a href="#switch-accept"><code>accept =*= proof</code> switch</a></li> |
| 67 | 50 | <li><a href="#switch-all-axioms"><code>all axioms</code> switch</a></li> |
| 68 | 51 | <li><a href="#switch-always-memo"><code>always memo</code> switch</a></li> |
| 52 | <li><a href="#citp-apply"><code>:apply (<tactic> ...) [to <goal-name>]</code></a></li> | |
| 69 | 53 | <li><a href="#apply"><code>apply <action> [ <subst> ] <range> <selection></code></a></li> |
| 54 | <li><a href="#citp-auto"><code>:auto</code></a></li> | |
| 70 | 55 | <li><a href="#switch-auto-context"><code>auto context</code> switch</a></li> |
| 71 | <li><a href="#autoload"><code>autoload</code></a></li> | |
| 72 | <li><a href="#ax"><code>ax</code></a></li> | |
| 56 | <li><a href="#autoload"><code>autoload <module-name> <file-name></code></a></li> | |
| 57 | <li><a href="#ax"><code>ax [ <label-exp> ] <term> = <term></code> .</a></li> | |
| 73 | 58 | <li><a href="#axioms"><code>axioms { <decls> }</code></a></li> |
| 74 | <li><a href="#bax"><code>bax</code></a></li> | |
| 75 | <li><a href="#bceq"><code>bceq [ <op-exp> ] <term> = <term> if <boolterm> .</code></a></li> | |
| 59 | <li><a href="#citp-backward"><code>:backward equation</code></a></li> | |
| 60 | <li><a href="#bax"><code>bax [ <label-exp> ] <term> = <term></code> .</a></li> | |
| 61 | <li><a href="#bceq"><code>bceq [ <label-exp> ] <term> = <term> if <boolterm> .</code></a></li> | |
| 62 | <li><a href="#bcrule"><code>bcrule [ <label-exp> ] <term> => <term> if <term> .</code></a></li> | |
| 76 | 63 | <li><a href="#bctrans"><code>bctrans [ <label-exp> ] <term> => <term> if <bool> .</code></a></li> |
| 77 | <li><a href="#beq"><code>beq [ <op-exp> ] <term> = <term> .</code></a></li> | |
| 78 | <li><a href="#bgoal"><code>bgoal</code></a></li> | |
| 64 | <li><a href="#beq"><code>beq [ <label-exp> ] <term> = <term> .</code></a></li> | |
| 65 | <li><a href="#bgoal"><code>bgoal <term> .</code></a></li> | |
| 66 | <li><a href="#binspect"><code>binspect [in <module-name> :] <boolean-term> .</code></a></li> | |
| 67 | <li><a href="#citp-binspect"><code>:binspect [in <goal-name> :] <boolean-term> .</code></a></li> | |
| 79 | 68 | <li><a href="#bop"><code>bop <op-spec> : <sorts> -> <sort></code></a></li> |
| 80 | 69 | <li><a href="#bpred"><code>bpred <op-spec> : <sorts></code></a></li> |
| 81 | 70 | <li><a href="#breduce"><code>breduce [ in <mod-exp> : ] <term> .</code></a></li> |
| 82 | <li><a href="#brl"><code>brl</code></a></li> | |
| 83 | <li><a href="#brule"><code>brule</code></a></li> | |
| 71 | <li><a href="#bresolve"><code>{binspect | :binspect}</code></a></li> | |
| 72 | <li><a href="#brule"><code>brule [ <label-exp> ] <term> => <term> .</code></a></li> | |
| 73 | <li><a href="#bshow"><code>{bshow | :bshow} [tree]</code></a></li> | |
| 84 | 74 | <li><a href="#bsort"><code>bsort</code></a></li> |
| 85 | 75 | <li><a href="#btrans"><code>btrans [ <label-exp> ] <term> => <term> .</code></a></li> |
| 86 | <li><a href="#cbred"><code>cbred</code></a></li> | |
| 76 | <li><a href="#cbred"><code>cbred [ in <mod-exp> :] <term> .</code></a></li> | |
| 87 | 77 | <li><a href="#cd"><code>cd <dirname></code></a></li> |
| 88 | <li><a href="#ceq"><code>ceq [ <op-exp> ] <term> = <term> if <boolterm> .</code></a></li> | |
| 78 | <li><a href="#ceq"><code>ceq [ <label-exp> ] <term> = <term> if <boolterm> .</code></a></li> | |
| 89 | 79 | <li><a href="#check"><code>check <options></code></a></li> |
| 90 | 80 | <li><a href="#switch-check"><code>check <something></code> switch</a></li> |
| 91 | 81 | <li><a href="#choose"><code>choose <selection></code></a></li> |
| 92 | <li><a href="#clause"><code>clause</code></a></li> | |
| 82 | <li><a href="#clause"><code>clause <term> .</code></a></li> | |
| 93 | 83 | <li><a href="#cleanmemo"><code>clean memo</code></a></li> |
| 94 | 84 | <li><a href="#switch-clean-memo"><code>clean memo</code> switch</a></li> |
| 95 | 85 | <li><a href="#close"><code>close</code></a></li> |
| 86 | <li><a href="#help"><code>commands</code></a></li> | |
| 96 | 87 | <li><a href="#comments">comments</a></li> |
| 97 | 88 | <li><a href="#switch-cond-limit"><code>cond limit</code> switch</a></li> |
| 98 | 89 | <li><a href="#cont"><code>cont</code></a></li> |
| 99 | <li><a href="#ctrans"><code>ctrans [ <label-exp> ] <term> => <term> .</code></a></li> | |
| 100 | <li><a href="#db"><code>db</code></a></li> | |
| 101 | <li><a href="#dbpred"><code>dbpred</code></a></li> | |
| 90 | <li><a href="#citp-cp"><code>:cp { "[" <label> "]" | "(" <sentense> . ")" } >< { "[" <label> "]" | "(" <sentence> .")" }</code></a></li> | |
| 91 | <li><a href="#crule"><code>crule [ <label-exp> ] <term> => <term> if <term> .</code></a></li> | |
| 92 | <li><a href="#citp-csp"><code>:csp { eq [ <label-exp>] <term> = <term> . ...}</code></a></li> | |
| 93 | <li><a href="#citp-csp-"><code>:csp { eq [ <label-exp>] <term> = <term> . ...}</code></a></li> | |
| 94 | <li><a href="#citp-ctf"><code>:ctf { eq [ <label-exp> ] <term> = <term> .}</code></a></li> | |
| 95 | <li><a href="#citp-ctf-"><code>:ctf { eq [ <label-exp> ] <term> = <term> .}</code></a></li> | |
| 96 | <li><a href="#ctrans"><code>ctrans [ <label-exp> ] <term> => <term> if <term> .</code></a></li> | |
| 97 | <li><a href="#db"><code>db reset</code></a></li> | |
| 102 | 98 | <li><a href="#demod"><code>demod</code></a></li> |
| 99 | <li><a href="#citp-describe"><code>:describe <something></code></a></li> | |
| 103 | 100 | <li><a href="#describe"><code>describe <something></code></a></li> |
| 104 | 101 | <li><a href="#dirs"><code>dirs</code></a></li> |
| 105 | <li><a href="#dpred"><code>dpred</code></a></li> | |
| 106 | 102 | <li><a href="#dribble"><code>dribble</code></a></li> |
| 107 | 103 | <li><a href="#eof"><code>eof</code></a></li> |
| 108 | <li><a href="#eq"><code>eq [ <op-exp> ]: <term> = <term> .</code></a></li> | |
| 104 | <li><a href="#eq"><code>eq [ <label-exp> ] <term> = <term> .</code></a></li> | |
| 105 | <li><a href="#citp-equation"><code>:equation</code></a></li> | |
| 109 | 106 | <li><a href="#switch-exec-limit"><code>exec limit</code> switch</a></li> |
| 110 | 107 | <li><a href="#switch-exec-trace"><code>exec trace</code> switch</a></li> |
| 111 | <li><a href="#execute-dash"><code>exec!</code></a></li> | |
| 108 | <li><a href="#execute-dash"><code>exec! [ in <mod-exp> : ] <term> .</code></a></li> | |
| 112 | 109 | <li><a href="#execute"><code>execute [ in <mod-exp> : ] <term> .</code></a></li> |
| 113 | 110 | <li><a href="#extending"><code>extending ( <modexp> )</code></a></li> |
| 114 | 111 | <li><a href="#find"><code>find</code></a></li> |
| 115 | 112 | <li><a href="#switch-find-all-rules"><code>find all rules</code> switch</a></li> |
| 116 | <li><a href="#flag"><code>flag</code></a></li> | |
| 113 | <li><a href="#flag"><code>flag(<name>, { on | off })</code></a></li> | |
| 117 | 114 | <li><a href="#fullreset"><code>full reset</code></a></li> |
| 118 | 115 | <li><a href="#gendoc"><code>gendoc <pathname></code></a></li> |
| 119 | <li><a href="#goal"><code>goal</code></a></li> | |
| 116 | <li><a href="#citp-goal"><code>:goal { <sentence> . ... }</code></a></li> | |
| 117 | <li><a href="#goal"><code>goal <term> .</code></a></li> | |
| 120 | 118 | <li><a href="#imports"><code>imports { <import-decl> }</code></a></li> |
| 121 | 119 | <li><a href="#switch-include-bool"><code>include BOOL</code> switch</a></li> |
| 122 | 120 | <li><a href="#switch-include-rwl"><code>include RWL</code> switch</a></li> |
| 123 | 121 | <li><a href="#including"><code>including ( <modexp> )</code></a></li> |
| 122 | <li><a href="#citp-ind"><code>:ind on <variable> ... .</code></a></li> | |
| 123 | <li><a href="#citp-init"><code>:init { "[" <label> "]" | "(" <sentence> "")} "{" <variable> <- <term>; ... "}"</code></a></li> | |
| 124 | 124 | <li><a href="#input"><code>input <pathname></code></a></li> |
| 125 | <li><a href="#inspect"><code>inspect</code></a></li> | |
| 125 | <li><a href="#inspect"><code>inspect <term></code></a></li> | |
| 126 | 126 | <li><a href="#instantiation">instantiation of parameterized modules</a></li> |
| 127 | <li><a href="#citp-is"><code>:is</code></a></li> | |
| 127 | 128 | <li><a href="#let"><code>let <identifier> = <term> .</code></a></li> |
| 128 | <li><a href="#lex"><code>lex</code></a></li> | |
| 129 | <li><a href="#lex"><code>lex (<op>, ..., <op>)</code></a></li> | |
| 129 | 130 | <li><a href="#switch-libpath"><code>libpath</code> switch</a></li> |
| 130 | 131 | <li><a href="#lisp"><code>lisp</code></a></li> |
| 131 | 132 | <li><a href="#lispq"><code>lispq</code></a></li> |
| 132 | <li><a href="#list"><code>list</code></a></li> | |
| 133 | <li><a href="#list"><code>list { axiom | sos | usable | flag | param | option | demod }</code></a></li> | |
| 133 | 134 | <li><a href="#lookup"><code>look up <something></code></a></li> |
| 134 | 135 | <li><a href="#ls"><code>ls <pathname></code></a></li> |
| 135 | 136 | <li><a href="#make"><code>make</code></a></li> |
| 137 | 138 | <li><a href="#switch-memo"><code>memo</code> switch</a></li> |
| 138 | 139 | <li><a href="#module"><code>[sys:]module[!|*] <modname> [ ( <params> ) ] [ <principal_sort_spec> ] { mod_elements ... }</code></a></li> |
| 139 | 140 | <li><a href="#moduleexpression"><code>module expression</code></a></li> |
| 140 | <li><a href="#names"><code>names</code></a></li> | |
| 141 | <li><a href="#names"><code>names <mod-exp></code> .</a></li> | |
| 142 | <li><a href="#no-autoload"><code>no autoload <module-name></code></a></li> | |
| 143 | <li><a href="#citp-normalize"><code>:normalize { on | off}</code></a></li> | |
| 141 | 144 | <li><a href="#onthefly">on-the-fly declarations</a></li> |
| 142 | 145 | <li><a href="#op"><code>op <op-spec> : <sorts> -> <sort> { <attribute-list> }</code></a></li> |
| 143 | 146 | <li><a href="#open"><code>open <mod_exp> .</code></a></li> |
| 144 | 147 | <li><a href="#opattr"><code>operator attributes</code></a></li> |
| 145 | 148 | <li><a href="#opprec"><code>operator precedence</code></a></li> |
| 146 | <li><a href="#option"><code>option</code></a></li> | |
| 147 | <li><a href="#param"><code>param</code></a></li> | |
| 149 | <li><a href="#option"><code>option { reset | = <name> }</code></a></li> | |
| 150 | <li><a href="#param"><code>param(<name>, <value>)</code></a></li> | |
| 148 | 151 | <li><a href="#parameterizedmodule"><code>parameterized module</code></a></li> |
| 149 | 152 | <li><a href="#parse"><code>parse [ in <mod-exp> : ] <term> .</code></a></li> |
| 150 | 153 | <li><a href="#switch-parse-normalize"><code>parse normalize</code> switch</a></li> |
| 154 | <li><a href="#citp-pctf"><code>:pctf { <bool-term> . ... <bool-term> .}</code></a></li> | |
| 155 | <li><a href="#citp-pctf-"><code>:pctf- { <bool-term> . ... <bool-term> . }</code></a></li> | |
| 151 | 156 | <li><a href="#popd"><code>popd</code></a></li> |
| 152 | 157 | <li><a href="#pred"><code>pred <op-spec> : <sorts></code></a></li> |
| 153 | 158 | <li><a href="#prelude"><code>prelude</code></a></li> |
| 157 | 162 | <li><a href="#protect"><code>protect <module-name></code></a></li> |
| 158 | 163 | <li><a href="#protecting"><code>protecting ( <modexp> )</code></a></li> |
| 159 | 164 | <li><a href="#provide"><code>provide <feature></code></a></li> |
| 160 | <li><a href="#pushd"><code>pushd</code></a></li> | |
| 161 | <li><a href="#pvar"><code>pvar</code></a></li> | |
| 165 | <li><a href="#pushd"><code>pushd <directory></code></a></li> | |
| 166 | <li><a href="#pvar"><code>pvar <var-name> : <sort-name></code></a></li> | |
| 162 | 167 | <li><a href="#pwd"><code>pwd</code></a></li> |
| 163 | 168 | <li><a href="#qualifiedother">qualified sort/operator/parameter</a></li> |
| 164 | 169 | <li><a href="#qualified"><code>qualified term</code></a></li> |
| 165 | 170 | <li><a href="#switch-quiet"><code>quiet</code> switch</a></li> |
| 166 | 171 | <li><a href="#quit"><code>quit</code></a></li> |
| 172 | <li><a href="#citp-red"><code>{ :red | :exec | :bred } [in <goal-name> :] <term> .</code></a></li> | |
| 167 | 173 | <li><a href="#reduce"><code>reduce [ in <mod-exp> : ] <term> .</code></a></li> |
| 168 | 174 | <li><a href="#switch-reduce-conditions"><code>reduce conditions</code> switch</a></li> |
| 169 | 175 | <li><a href="#regularize"><code>regularize <mod-name></code></a></li> |
| 170 | 176 | <li><a href="#switch-regularize-signature"><code>regularize signature</code> switch</a></li> |
| 171 | 177 | <li><a href="#require"><code>require <feature> [ <pathname> ]</code></a></li> |
| 172 | 178 | <li><a href="#reset"><code>reset</code></a></li> |
| 173 | <li><a href="#resolve"><code>resolve</code></a></li> | |
| 179 | <li><a href="#resolve"><code>resolve {. | <file-path> }</code></a></li> | |
| 174 | 180 | <li><a href="#restore"><code>restore <pathname></code></a></li> |
| 175 | 181 | <li><a href="#switch-rewrite"><code>rewrite limit</code> switch</a></li> |
| 176 | <li><a href="#rl"><code>rl</code></a></li> | |
| 177 | <li><a href="#rule"><code>rule</code></a></li> | |
| 182 | <li><a href="#citp-roll"><code>:roll back</code></a></li> | |
| 183 | <li><a href="#citp-rule"><code>:rule</code></a></li> | |
| 184 | <li><a href="#rule"><code>rule [ <label-exp> ] <term> => <term> .</code></a></li> | |
| 178 | 185 | <li><a href="#save"><code>save <pathname></code></a></li> |
| 179 | <li><a href="#save-option"><code>save-option</code></a></li> | |
| 186 | <li><a href="#save-option"><code>save-option <name></code></a></li> | |
| 180 | 187 | <li><a href="#save-system"><code>save-system <pathname></code></a></li> |
| 181 | <li><a href="#scase"><code>scase</code></a></li> | |
| 188 | <li><a href="#scase"><code>scase (<term>) in (<mod-exp>) as <name> { <decl> ..} : <term> .</code></a></li> | |
| 182 | 189 | <li><a href="#searchpredicate"><code>search predicates</code></a></li> |
| 190 | <li><a href="#citp-select"><code>:select <goal-name></code></a></li> | |
| 183 | 191 | <li><a href="#select"><code>select <mod_exp> .</code></a></li> |
| 184 | 192 | <li><a href="#set"><code>set <name> [option] <value></code></a></li> |
| 193 | <li><a href="#citp-show"><code>:show <something></code></a></li> | |
| 185 | 194 | <li><a href="#show"><code>show <something></code></a></li> |
| 186 | 195 | <li><a href="#switch-show-mode"><code>show mode</code> switch</a></li> |
| 187 | <li><a href="#sigmatch"><code>sigmatch</code></a></li> | |
| 196 | <li><a href="#sigmatch"><code>sigmatch (<mod-exp>) to (<mod-exp>)</code></a></li> | |
| 188 | 197 | <li><a href="#signature"><code>signature { <sig-decl> }</code></a></li> |
| 189 | 198 | <li><a href="#sort">sort declaration</a></li> |
| 190 | <li><a href="#sos"><code>sos</code></a></li> | |
| 199 | <li><a href="#sos"><code>sos { = | + | - } { <clause> , ... }</code></a></li> | |
| 200 | <li><a href="#citp-spoiler"><code>:spoiler { on | off}</code></a></li> | |
| 191 | 201 | <li><a href="#start"><code>start <term> .</code></a></li> |
| 192 | 202 | <li><a href="#switch-statistics"><code>statistics</code> switch</a></li> |
| 193 | 203 | <li><a href="#switch-step"><code>step</code> switch</a></li> |
| 199 | 209 | <li><a href="#unprotect"><code>unprotect <module-name></code></a></li> |
| 200 | 210 | <li><a href="#using"><code>using ( <modexp> )</code></a></li> |
| 201 | 211 | <li><a href="#var"><code>var <var-name> : <sort-name></code></a></li> |
| 212 | <li><a href="#citp-verbose"><code>:verbose { on | off }</code></a></li> | |
| 202 | 213 | <li><a href="#switch-verbose"><code>verbose</code> switch</a></li> |
| 203 | 214 | <li><a href="#version"><code>version</code></a></li> |
| 204 | 215 | <li><a href="#view"><code>view <name> from <modname> to <modname> { <viewelems> }</code></a></li> |
| 216 | 227 | |
| 217 | 228 | % \include{reference.md} |
| 218 | 229 | --> |
| 219 | ||
| 220 | ||
| 221 | 230 | <h1 id="introduction">Introduction</h1> |
| 222 | 231 | <p>This manual introduces the language CafeOBJ. Is is a reference manual with the aim to document the current status of the language, and not targeting at an exhaustive presentation of the mathematical and logical background. Still, the next section will give a short summary of the underlying formal approach and carry references for those in search for details.</p> |
| 223 | 232 | <p>The manual is structured into three parts. The first one being this introduction, the second one being the presentation of basic concepts of CafeOBJ by providing a simple protocol which will get specified and verified. Although the second part tries to give a view onto the core features and their usage, it should not be considered a course in CafeOBJ, and cannot replace a proper introduction to the language. The CafeOBJ distribution also includes a <em>user manual</em>. This user manual is slightly outdated with respect to the current status of the language, but is targeting those without and prior knowledge of CafeOBJ.</p> |
| 229 | 238 | <p>CafeOBJ is based on three extensions to the basic many-sorted equational logic:</p> |
| 230 | 239 | <dl> |
| 231 | 240 | <dt>Order-sorted logic</dt> |
| 232 | <dd>In addition to having different sorts (similar to types in other programming languages), these sorts can be ordered, or in other words, one sort can be a subset of another sort: Take for example the number stack: CafeOBJ allows for the provision of natural numbers, which are part of the rational numbers, which are part of the real numbers. This concept allows for operator inheritance and overloading. | |
| 233 | </dd> | |
| 234 | <dt>Behavioral logic</dt> | |
| 235 | <dd>Algebraic modeling is often based on constructors, i.e., all terms under discussion are built up from given operations, and equality can be decided via an equational theory. While being very successful, it is often necessary to model infinite objects (like data streams), which cannot be achieved in this way. CafeOBJ includes <em>behavioral logic</em> and the respective <em>hidden sorts</em> as methodology to model infinite objects which identity is defined via behavior instead of the equational theory. | |
| 236 | </dd> | |
| 237 | <dt>Rewriting logic</dt> | |
| 241 | <dd>In addition to having different sorts (similar to types in other programming languages), these sorts can be ordered, or in other words, one sort can be a subset of another sort: Take for example the number stack: CafeOBJ allows for the provision of natural numbers, which are part of the rational numbers, which are part of the real numbers. This concept allows for operator inheritance and overloading. Behavioral logic | |
| 242 | </dd> | |
| 243 | <dd>Algebraic modeling is often based on constructors, i.e., all terms under discussion are built up from given operations, and equality can be decided via an equational theory. While being very successful, it is often necessary to model infinite objects (like data streams), which cannot be achieved in this way. CafeOBJ includes <em>behavioral logic</em> and the respective <em>hidden sorts</em> as methodology to model infinite objects which identity is defined via behavior instead of the equational theory. Rewriting logic | |
| 244 | </dd> | |
| 238 | 245 | <dd>Aim of a algebraic specification and verification is to give a formal proof of correctness. CafeOBJ contains order-sorted term rewriting as operational semantics, which allows for <em>execution of proof scores</em>, CafeOBJ code which forms a proof of the required properties. |
| 239 | 246 | </dd> |
| 240 | 247 | </dl> |
| 431 | 438 | <p>In the following case we ended up with five different predicates that combined worked as invariant:</p> |
| 432 | 439 | <dl> |
| 433 | 440 | <dt><code>cloud-idle-pcs-idle</code></dt> |
| 434 | <dd><p>If the cloud is in the idle state, then all the pcs are also in the idle state.</p> | |
| 441 | <dd>If the cloud is in the idle state, then all the pcs are also in the idle state. | |
| 435 | 442 | </dd> |
| 436 | 443 | <dt><code>pc-clval</code></dt> |
| 437 | <dd><p>If the cloud is in busy state, then the value of the cloud and the value in the temporary storage area of any PCs in the <code>gotvalue</code> or <code>updated</code> states agree.</p> | |
| 444 | <dd>If the cloud is in busy state, then the value of the cloud and the value in the temporary storage area of any PCs in the <code>gotvalue</code> or <code>updated</code> states agree. | |
| 438 | 445 | </dd> |
| 439 | 446 | <dt><code>one-active</code></dt> |
| 440 | <dd><p>At most one PC is out of the idle state.</p> | |
| 447 | <dd>At most one PC is out of the idle state. | |
| 441 | 448 | </dd> |
| 442 | 449 | <dt><code>gotvalue-cloud-value</code></dt> |
| 443 | <dd><p>If a PC is in the <code>gotvalue</code> state, then the value saved in the temporary storage area and the one of the cloud agree.</p> | |
| 450 | <dd>If a PC is in the <code>gotvalue</code> state, then the value saved in the temporary storage area and the one of the cloud agree. | |
| 444 | 451 | </dd> |
| 445 | 452 | <dt><code>goal</code></dt> |
| 446 | <dd><p>If a PC is in the <code>updated</code> state, then the value of the PC and the value of the cloud agree.</p> | |
| 453 | <dd>If a PC is in the <code>updated</code> state, then the value of the PC and the value of the cloud agree. | |
| 447 | 454 | </dd> |
| 448 | 455 | </dl> |
| 449 | 456 | <p>See the mentioned web-page for the full code of these modules.</p> |
| 483 | 490 | <h2 id="ctrld">Ctrl-D</h2> |
| 484 | 491 | <h2 id="commandexec"><code>! <command></code></h2> |
| 485 | 492 | <p>On Unix only, forks a shell and executes the given <code><command></code>.</p> |
| 486 | <h2 id="sharp-define"><code>#define</code></h2> | |
| 493 | <h2 id="sharp-define"><code>#define <symbol> := <term> .</code></h2> | |
| 487 | 494 | <h2 id="starstar"><code>**</code>, <code>**></code></h2> |
| 488 | 495 | <p>Starts a comment which extends to the end of the line. With the additional <code>></code> the comment is displayed while evaluated by the interpreter.</p> |
| 489 | 496 | <p>Related: <a href="#comments">comments</a>, <a href="#starstar"><code>--</code></a></p> |
| 492 | 499 | <p>Related: <a href="#comments">comments</a>, <a href="#starstar"><code>**</code></a></p> |
| 493 | 500 | <h2 id="dotsep"><code>.</code></h2> |
| 494 | 501 | <p>Do nothing.</p> |
| 495 | <h2 id="apply-tactic-...-to-goal-name-apply"><code>:apply (<tactic> ...) [to <goal-name>]</code> ## {#:apply}</h2> | |
| 496 | <p>TODO</p> | |
| 497 | <h2 id="auto-auto"><code>:auto</code> ## {#:auto}</h2> | |
| 498 | <p>TODO</p> | |
| 499 | <h2 id="backward-equation-backward"><code>:backward equation</code> ## {#:backward}</h2> | |
| 500 | <p>TODO</p> | |
| 501 | <h2 id="cp-label-axiom-.-label-axiom-.-cp"><code>:cp { "[" <label> "]" | "(" <axiom> . ")" } >< { "[" <label> "]" | "(" <axiom> .")" }</code> ## {#:cp}</h2> | |
| 502 | <p>TODO</p> | |
| 503 | <h2 id="csp-eq-op-exp-term-term-.-...-csp"><code>:csp { eq [ <op-exp>]: <term> = <term> . ...}</code> ## {#:csp}</h2> | |
| 504 | <p>TODO</p> | |
| 505 | <h2 id="ctf-eq-op-exp-term-term-.-ctf"><code>:ctf { eq [ <op-exp> ]: <term> = <term> .</code> ## {#:ctf}</h2> | |
| 506 | <p>TODO</p> | |
| 507 | <h2 id="describe-something-describe"><code>:describe <something></code> ## {#:describe}</h2> | |
| 508 | <p>Similar to the <code>:show</code> command but with more details. See <code>:describe ?</code> for the possible set of invocations.</p> | |
| 509 | <p>Related: <a href="#:show"><code>:show</code></a></p> | |
| 510 | <h2 id="equation-equation"><code>:equation</code> ## {#:equation}</h2> | |
| 511 | <p>TODO</p> | |
| 512 | <h2 id="goal-axiom-.-...-goal"><code>:goal { <axiom> . ... }</code> ## {#:goal}</h2> | |
| 513 | <p>TODO</p> | |
| 514 | <h2 id="ind-on-variable-...-.-ind"><code>:ind on <variable> ... .</code> ## {#:ind}</h2> | |
| 515 | <p>TODO</p> | |
| 516 | <h2 id="init-label-axiom-variable---term-...-init"><code>:init { "[" <label> "]" | "(" <axiom> "")} "{" <variable> <- <term>; ... "}"</code> ## {#:init}</h2> | |
| 517 | <p>TODO</p> | |
| 518 | <h2 id="is-is"><code>:is</code> ## {#:is}</h2> | |
| 519 | <p>Boolean expression: <code>A :is B</code> where <code>A</code> is a term and <code>B</code> is a sort. Returns true if <code>A</code> is of sort <code>B</code>.</p> | |
| 520 | <h2 id="lred-term-.-red"><code>:lred <term> .</code> ## {#:red}</h2> | |
| 521 | <p>TODO</p> | |
| 522 | <h2 id="roll-back-roll"><code>:roll back</code> ## {#:roll}</h2> | |
| 523 | <p>TODO</p> | |
| 524 | <h2 id="rule-rule"><code>:rule</code> ## {#:rule}</h2> | |
| 525 | <p>TODO</p> | |
| 526 | <h2 id="select-goal-name-select"><code>:select <goal-name></code> ## {#:select}</h2> | |
| 527 | <p>TODO</p> | |
| 528 | <h2 id="show-something-show"><code>:show <something></code> ## {#:show}</h2> | |
| 529 | <p>TODO</p> | |
| 530 | <p>Related: <a href="#:describe"><code>:describe</code></a></p> | |
| 531 | <h2 id="verbose-on-off-verbose"><code>:verbose { on | off }</code> ## {#:verbose}</h2> | |
| 532 | <p>TODO</p> | |
| 533 | 502 | <h2 id="axeq"><code>=</code></h2> |
| 534 | 503 | <p>The syntax element <code>=</code> introduces an axiom of the equational theory, and is different from <code>==</code> which specifies an equality based on rewriting.</p> |
| 535 | 504 | <p>Related: <a href="#eq"><code>eq</code></a>, <a href="#equality"><code>==</code></a></p> |
| 546 | 515 | <p>This binary predicate is defined on each visible sort, and defines the transition relation, which is reflexive, transitive, and closed under operator application. It expresses the fact that two states (terms) are connected via transitions.</p> |
| 547 | 516 | <p>Related: <a href="#searchpredicate">search predicates</a>, <a href="#trans"><code>trans</code></a></p> |
| 548 | 517 | <h2 id="help"><code>? [<term>]</code></h2> |
| 549 | <p>Without any argument, lists all top-level commands. With argument gives the reference manual description of <code>term</code>. In addition to this, many commands allow for passing <code>?</code> as argument to obtain further help.</p> | |
| 518 | <p>Without any argument, shows the brief guide of online help system. With argument gives the reference manual description of <code>term</code>. In addition to this, many commands allow for passing <code>?</code> as argument to obtain further help.</p> | |
| 550 | 519 | <p>In case examples are provided for the <code><term></code>, they can be displayed using <code>?ex <term></code>. In this case the normal help output will also contain an informational message that examples are available.</p> |
| 551 | 520 | <p>When called as ?? both documentation and examples are shown.</p> |
| 552 | 521 | <h2 id="apropos"><code>?apropos <term> [<term> ...]</code></h2> |
| 557 | 526 | <p>will search for all entries that contain both <code>prec</code> and <code>oper</code> as sub-strings. Matching is done as simple sub-string match.</p> |
| 558 | 527 | <pre><code>CafeOBJ> ?ap foo att[er]</code></pre> |
| 559 | 528 | <p>will search for entries that contain the string <code>foo</code> as well as either the string <code>atte</code> or <code>attr</code>.</p> |
| 529 | <h2 id="help-commands"><code>?com [ <term> ]</code></h2> | |
| 530 | <p>List commands or declarations categorized by the key <term>. <term> is one of 'decl', 'module', 'parse', 'rewrite', 'inspect', 'switch', 'proof', 'system', 'inspect', 'library', 'help', 'io' or 'misc'. If <term> is omitted, the list of available <term> will be printed.</p> | |
| 560 | 531 | <h2 id="sortsymbol"><code>[</code></h2> |
| 561 | 532 | <p>Starts a sort declaration. See <a href="#sort">sort declaration</a> for details.</p> |
| 562 | 533 | <h2 id="switch-accept"><code>accept =*= proof</code> switch</h2> |
| 567 | 538 | <h2 id="switch-always-memo"><code>always memo</code> switch</h2> |
| 568 | 539 | <p>Turns on memorization of computation also for operators without the <a href="#opattr"><code>memo</code></a> operator attribute.</p> |
| 569 | 540 | <p>Related: <a href="#opattr">operator attributes</a>, <a href="#switch-memo"><code>memo</code></a></p> |
| 541 | <h2 id="citp-apply"><code>:apply (<tactic> ...) [to <goal-name>]</code></h2> | |
| 542 | <p>TODO</p> | |
| 570 | 543 | <h2 id="apply"><code>apply <action> [ <subst> ] <range> <selection></code></h2> |
| 571 | 544 | <p>Applies one of the following actions <code>reduce</code>, <code>exec</code>, <code>print</code>, or a rewrite rule to the term in focus.</p> |
| 572 | 545 | <dl> |
| 573 | 546 | <dt><code>reduce</code>, <code>exec</code>, <code>print</code></dt> |
| 574 | <dd><p>the operation acts on the (sub)term specified by <code><range></code> and <code><selection></code>.</p> | |
| 547 | <dd>the operation acts on the (sub)term specified by <code><range></code> and <code><selection></code>. | |
| 575 | 548 | </dd> |
| 576 | 549 | <dt>rewrite rule</dt> |
| 577 | 550 | <dd><p>in this case a rewrite rule spec has to be given in the following form:</p> |
| 588 | 561 | <p>where each <code><selector></code> is one of</p> |
| 589 | 562 | <dl> |
| 590 | 563 | <dt><code>top</code>, <code>term</code></dt> |
| 591 | <dd><p>Selects the whole term</p> | |
| 564 | <dd>Selects the whole term | |
| 592 | 565 | </dd> |
| 593 | 566 | <dt><code>subterm</code></dt> |
| 594 | <dd><p>Selects the pre-chosen subterm (see <a href="#choose"><code>choose</code></a>)</p> | |
| 567 | <dd>Selects the pre-chosen subterm (see <a href="#choose"><code>choose</code></a>) | |
| 595 | 568 | </dd> |
| 596 | 569 | <dt><code>( <number_list> )</code></dt> |
| 597 | <dd><p>A list of numbers separated by blanks as in <code>(2 1)</code> indicates a subterm by tree search. <code>(2 1)</code> means the first argument of the second argument.</p> | |
| 570 | <dd>A list of numbers separated by blanks as in <code>(2 1)</code> indicates a subterm by tree search. <code>(2 1)</code> means the first argument of the second argument. | |
| 598 | 571 | </dd> |
| 599 | 572 | <dt><code>[ <number1> .. <number2> ]</code></dt> |
| 600 | 573 | <dd><p>This selector can only be used with associative operators. It indicates a subterm in a flattened structure and selects the subterm between and including the two numbers given. <code>[n .. n]</code> can be abbreviated to <code>[n]</code>.</p> |
| 601 | 574 | <p>Example: If the term is <code>a * b * c * d * e</code>, then the expression <code>[2 .. 4]</code> selects the subterm <code>b * c * d</code>.</p> |
| 602 | 575 | </dd> |
| 603 | 576 | <dt><code>{ <number_set> }</code></dt> |
| 604 | <dd>This selector can only be used with associative and commutative | |
| 577 | <dd>This selector can only be used with associative and commutative operators. It indicates a subterm in a multiset structure obtained from selecting the subterms at position given by the numbers. | |
| 605 | 578 | </dd> |
| 606 | 579 | </dl> |
| 607 | <p>operators. It indicates a subterm in a multiset structure obtained from selecting the subterms at position given by the numbers.</p> | |
| 608 | 580 | <p>Example: If the operator <code>_*_</code> is declared as associative and commutative, and the current term is <code>b * c * d * c * e</code>, then then the expression <code>{2, 4, 5}</code> selects the subterm <code>c * c * e</code>.</p> |
| 609 | 581 | <p>Related: <a href="#start"><code>start</code></a>, <a href="#choose"><code>choose</code></a></p> |
| 582 | <h2 id="citp-auto"><code>:auto</code></h2> | |
| 583 | <p>TODO</p> | |
| 610 | 584 | <h2 id="switch-auto-context"><code>auto context</code> switch</h2> |
| 611 | 585 | <p>Possible values: <code>on</code> or <code>off</code>, default is <code>off</code>.</p> |
| 612 | 586 | <p>If this switch is <code>on</code>, the context will automatically switch to the most recent module, i.e., defining a module or inspecting a module's content will switch the current module.</p> |
| 613 | <h2 id="autoload"><code>autoload</code></h2> | |
| 614 | <h2 id="ax"><code>ax</code></h2> | |
| 587 | <h2 id="autoload"><code>autoload <module-name> <file-name></code></h2> | |
| 588 | <p>When evaluating a <module-name> and found that it is not yet declared, the system read in <file-name> then retries the evaluation.</p> | |
| 589 | <p>Related: <a href="#no-autoload"><code>no autoload</code></a></p> | |
| 590 | <h2 id="ax"><code>ax [ <label-exp> ] <term> = <term></code> .</h2> | |
| 615 | 591 | <p>(pignose)</p> |
| 616 | 592 | <h2 id="axioms"><code>axioms { <decls> }</code></h2> |
| 617 | 593 | <p>Block enclosing declarations of variables, equations, and transitions. Other statements are not allowed within the <code>axioms</code> block. Optional structuring of the statements in a module.</p> |
| 618 | 594 | <p>Related: <a href="#trans"><code>trans</code></a>, <a href="#eq"><code>eq</code></a>, <a href="#var"><code>var</code></a>, <a href="#imports"><code>imports</code></a>, <a href="#signature"><code>signature</code></a></p> |
| 619 | <h2 id="bax"><code>bax</code></h2> | |
| 620 | <p>(pignose)</p> | |
| 621 | <h2 id="bceq"><code>bceq [ <op-exp> ] <term> = <term> if <boolterm> .</code></h2> | |
| 595 | <h2 id="citp-backward"><code>:backward equation</code></h2> | |
| 596 | <p>TODO</p> | |
| 597 | <h2 id="bax"><code>bax [ <label-exp> ] <term> = <term></code> .</h2> | |
| 598 | <p>(pignose)</p> | |
| 599 | <h2 id="bceq"><code>bceq [ <label-exp> ] <term> = <term> if <boolterm> .</code></h2> | |
| 622 | 600 | <p>Defines a behavioral conditional equation. For details see <a href="#ceq"><code>ceq</code></a>.</p> |
| 623 | 601 | <p>Related: <a href="#beq"><code>beq</code></a>, <a href="#ceq"><code>ceq</code></a>, <a href="#eq"><code>eq</code></a></p> |
| 602 | <h2 id="bcrule"><code>bcrule [ <label-exp> ] <term> => <term> if <term> .</code></h2> | |
| 603 | <p>Synonym of 'bctrans'</p> | |
| 604 | <p>Related: <a href="#bctrans"><code>bctrans</code></a></p> | |
| 624 | 605 | <h2 id="bctrans"><code>bctrans [ <label-exp> ] <term> => <term> if <bool> .</code></h2> |
| 625 | 606 | <p>Defines a behavioral conditional transition. For details see <a href="#ctrans"><code>ctrans</code></a>.</p> |
| 626 | 607 | <p>Related: <a href="#btrans"><code>btrans</code></a>, <a href="#ctrans"><code>ctrans</code></a>, <a href="#trans"><code>trans</code></a></p> |
| 627 | <h2 id="beq"><code>beq [ <op-exp> ] <term> = <term> .</code></h2> | |
| 608 | <h2 id="beq"><code>beq [ <label-exp> ] <term> = <term> .</code></h2> | |
| 628 | 609 | <p>Defines a behavioral equation. For details see <a href="#eq"><code>eq</code></a>.</p> |
| 629 | 610 | <p>Related: <a href="#bceq"><code>bceq</code></a>, <a href="#ceq"><code>ceq</code></a>, <a href="#eq"><code>eq</code></a></p> |
| 630 | <h2 id="bgoal"><code>bgoal</code></h2> | |
| 631 | <p>(pignose)</p> | |
| 611 | <h2 id="bgoal"><code>bgoal <term> .</code></h2> | |
| 612 | <p>(pignose)</p> | |
| 613 | <h2 id="binspect"><code>binspect [in <module-name> :] <boolean-term> .</code></h2> | |
| 614 | <p>TODO</p> | |
| 615 | <h2 id="citp-binspect"><code>:binspect [in <goal-name> :] <boolean-term> .</code></h2> | |
| 616 | <p>TODO</p> | |
| 632 | 617 | <h2 id="bop"><code>bop <op-spec> : <sorts> -> <sort></code></h2> |
| 633 | 618 | <p>Defines a behavioral operator by its domain, co-domain, and the term construct. <code><sorts></code> is a space separated list of sort names containing <em>exactly</em> one hidden sort. <code><sort></code> is a single sort name.</p> |
| 634 | 619 | <p>For <code><op-spec></code> see the explanations of <a href="#op"><code>op</code></a>.</p> |
| 640 | 625 | <p>Reduce the given term in the given module, if <code><mod-exp></code> is given, otherwise in the current module.</p> |
| 641 | 626 | <p>For <code>breduce</code> equations, possibly conditional, possibly behavioral, are taken into account for reduction.</p> |
| 642 | 627 | <p>Related: <a href="#reduce"><code>reduce</code></a>, <a href="#execute"><code>execute</code></a></p> |
| 643 | <h2 id="brl"><code>brl</code></h2> | |
| 644 | <h2 id="brule"><code>brule</code></h2> | |
| 628 | <h2 id="bresolve"><code>{binspect | :binspect}</code></h2> | |
| 629 | <p>TODO</p> | |
| 630 | <h2 id="brule"><code>brule [ <label-exp> ] <term> => <term> .</code></h2> | |
| 631 | <p>Synonym of 'btrans'.</p> | |
| 632 | <p>Related: <a href="#btrans"><code>btrans</code></a></p> | |
| 633 | <h2 id="bshow"><code>{bshow | :bshow} [tree]</code></h2> | |
| 634 | <p>TODO</p> | |
| 645 | 635 | <h2 id="bsort"><code>bsort</code></h2> |
| 646 | 636 | <h2 id="btrans"><code>btrans [ <label-exp> ] <term> => <term> .</code></h2> |
| 647 | 637 | <p>Defines a behavioral transition. For details see <a href="#trans"><code>trans</code></a>.</p> |
| 648 | 638 | <p>Related: <a href="#bctrans"><code>bctrans</code></a>, <a href="#ctrans"><code>ctrans</code></a>, <a href="#trans"><code>trans</code></a></p> |
| 649 | <h2 id="cbred"><code>cbred</code></h2> | |
| 639 | <h2 id="cbred"><code>cbred [ in <mod-exp> :] <term> .</code></h2> | |
| 650 | 640 | <h2 id="cd"><code>cd <dirname></code></h2> |
| 651 | 641 | <p>Change the current working directory, like the Unix counterpart. The argument is necessary. No kind of expansion or substitution is done.</p> |
| 652 | 642 | <p>Related: <a href="#ls"><code>ls</code></a>, <a href="#pwd"><code>pwd</code></a></p> |
| 653 | <h2 id="ceq"><code>ceq [ <op-exp> ] <term> = <term> if <boolterm> .</code></h2> | |
| 643 | <h2 id="ceq"><code>ceq [ <label-exp> ] <term> = <term> if <boolterm> .</code></h2> | |
| 654 | 644 | <p>Defines a conditional equation. Spaces around the <code>if</code> are obligatory. <code><boolterm></code> needs to be a Boolean term. For other requirements see <a href="#eq"><code>eq</code></a>.</p> |
| 655 | 645 | <p>Related: <a href="#bceq"><code>bceq</code></a>, <a href="#beq"><code>beq</code></a>, <a href="#eq"><code>eq</code></a></p> |
| 656 | 646 | <h2 id="check"><code>check <options></code></h2> |
| 657 | 647 | <p>This command allows for checking of certain properties of modules and operators.</p> |
| 658 | 648 | <dl> |
| 659 | 649 | <dt><code>check regularity <mod_exp></code></dt> |
| 660 | <dd><p>Checks whether the module given by the module expression <code><mod_exp></code> is regular.</p> | |
| 650 | <dd>Checks whether the module given by the module expression <code><mod_exp></code> is regular. | |
| 661 | 651 | </dd> |
| 662 | 652 | <dt><code>check compatibility <mod_exp></code></dt> |
| 663 | <dd><p>Checks whether term rewriting system of the module given by the module expression <code><mod_exp></code> is compatible, i.e., every application of every rewrite rule to every well-formed term results in a well-formed term. (This is not necessarily the case in order-sorted rewriting!)</p> | |
| 653 | <dd>Checks whether term rewriting system of the module given by the module expression <code><mod_exp></code> is compatible, i.e., every application of every rewrite rule to every well-formed term results in a well-formed term. (This is not necessarily the case in order-sorted rewriting!) | |
| 664 | 654 | </dd> |
| 665 | 655 | <dt><code>check laziness <op_name></code></dt> |
| 666 | <dd><p>Checks whether the given operator can be evaluated lazily. If not <code><op_name></code> is given, all operators of the current module are checked.</p> | |
| 656 | <dd>Checks whether the given operator can be evaluated lazily. If not <code><op_name></code> is given, all operators of the current module are checked. | |
| 667 | 657 | </dd> |
| 668 | 658 | </dl> |
| 669 | 659 | <p>Related: <a href="#regularize"><code>regularize</code></a></p> |
| 671 | 661 | <p>These switches turn on automatic checking of certain properties:</p> |
| 672 | 662 | <dl> |
| 673 | 663 | <dt><code>check coherency</code></dt> |
| 674 | <dd><p>TODO</p> | |
| 664 | <dd>TODO | |
| 675 | 665 | </dd> |
| 676 | 666 | <dt><code>check compatibility</code></dt> |
| 677 | <dd><p>see the <a href="#check"><code>check</code></a> command</p> | |
| 667 | <dd>see the <a href="#check"><code>check</code></a> command | |
| 678 | 668 | </dd> |
| 679 | 669 | <dt><code>check import</code></dt> |
| 680 | <dd><p>TODO</p> | |
| 670 | <dd>TODO | |
| 681 | 671 | </dd> |
| 682 | 672 | <dt><code>check regularity</code></dt> |
| 683 | <dd><p>see the <a href="#check"><code>check</code></a> command</p> | |
| 673 | <dd>see the <a href="#check"><code>check</code></a> command | |
| 684 | 674 | </dd> |
| 685 | 675 | <dt><code>check sensible</code></dt> |
| 686 | <dd><p>TODO</p> | |
| 676 | <dd>TODO | |
| 687 | 677 | </dd> |
| 688 | 678 | </dl> |
| 689 | 679 | <h2 id="choose"><code>choose <selection></code></h2> |
| 690 | 680 | <p>Chooses a subterm by the given <code><selection></code>. See <a href="#apply"><code>apply</code></a> for details on <code><selection></code>.</p> |
| 691 | 681 | <p>Related: <a href="#opattr"><code>strat</code> in operator attributes</a>, <a href="#start"><code>start</code></a>, <a href="#apply"><code>apply</code></a></p> |
| 692 | <h2 id="clause"><code>clause</code></h2> | |
| 682 | <h2 id="clause"><code>clause <term> .</code></h2> | |
| 693 | 683 | <p>(pignose)</p> |
| 694 | 684 | <h2 id="cleanmemo"><code>clean memo</code></h2> |
| 695 | 685 | <p>Resets (clears) the memo storage of the system. Memorized computations are forgotten.</p> |
| 700 | 690 | <h2 id="close"><code>close</code></h2> |
| 701 | 691 | <p>This command closes a modification of a module started by <code>open</code>.</p> |
| 702 | 692 | <p>Related: <a href="#open"><code>open</code></a></p> |
| 693 | <h2 id="help"><code>commands</code></h2> | |
| 694 | <p>Print outs the list of main toplevel commands.</p> | |
| 703 | 695 | <h2 id="comments">comments</h2> |
| 704 | 696 | <p>The interpreter accepts the following strings as start of a comment that extends to the end of the line: <code>--</code>, <code>--></code>, <code>**</code>, <code>**></code>.</p> |
| 705 | 697 | <p>The difference in the variants with <code>></code> is that the comment is displayed when run through the interpreter.</p> |
| 706 | 698 | <p>Related: <a href="#starstar"><code>--</code></a>, <a href="#starstar"><code>**</code></a></p> |
| 707 | 699 | <h2 id="switch-cond-limit"><code>cond limit</code> switch</h2> |
| 708 | 700 | <h2 id="cont"><code>cont</code></h2> |
| 709 | <h2 id="ctrans"><code>ctrans [ <label-exp> ] <term> => <term> .</code></h2> | |
| 701 | <h2 id="citp-cp"><code>:cp { "[" <label> "]" | "(" <sentense> . ")" } >< { "[" <label> "]" | "(" <sentence> .")" }</code></h2> | |
| 702 | <p>TODO</p> | |
| 703 | <h2 id="crule"><code>crule [ <label-exp> ] <term> => <term> if <term> .</code></h2> | |
| 704 | <p>Synonym of 'ctrans'</p> | |
| 705 | <p>Related: <a href="#rule"><code>rule</code></a>, <a href="#ctrans"><code>ctrans</code></a></p> | |
| 706 | <h2 id="citp-csp"><code>:csp { eq [ <label-exp>] <term> = <term> . ...}</code></h2> | |
| 707 | <p>TODO</p> | |
| 708 | <h2 id="citp-csp-"><code>:csp { eq [ <label-exp>] <term> = <term> . ...}</code></h2> | |
| 709 | <p>TODO</p> | |
| 710 | <h2 id="citp-ctf"><code>:ctf { eq [ <label-exp> ] <term> = <term> .}</code></h2> | |
| 711 | <p>TODO</p> | |
| 712 | <h2 id="citp-ctf-"><code>:ctf { eq [ <label-exp> ] <term> = <term> .}</code></h2> | |
| 713 | <p>TODO</p> | |
| 714 | <h2 id="ctrans"><code>ctrans [ <label-exp> ] <term> => <term> if <term> .</code></h2> | |
| 710 | 715 | <p>Defines a conditional transition. For details see <a href="#trans"><code>trans</code></a> and <a href="#ceq"><code>ceq</code></a>.</p> |
| 711 | 716 | <p>Related: <a href="#bctrans"><code>bctrans</code></a>, <a href="#btrans"><code>btrans</code></a>, <a href="#trans"><code>trans</code></a></p> |
| 712 | <h2 id="db"><code>db</code></h2> | |
| 713 | <p>(pignose)</p> | |
| 714 | <h2 id="dbpred"><code>dbpred</code></h2> | |
| 717 | <h2 id="db"><code>db reset</code></h2> | |
| 715 | 718 | <p>(pignose)</p> |
| 716 | 719 | <h2 id="demod"><code>demod</code></h2> |
| 717 | 720 | <p>(pignose)</p> |
| 721 | <h2 id="citp-describe"><code>:describe <something></code></h2> | |
| 722 | <p>Similar to the <code>:show</code> command but with more details. Call <code>:describe ?</code> for the possible set of invocations.</p> | |
| 723 | <p>Related: <a href="#citp-show"><code>:show</code></a></p> | |
| 718 | 724 | <h2 id="describe"><code>describe <something></code></h2> |
| 719 | <p>Similar to the <code>show</code> command but with more details. See <code>describe ?</code> for the possible set of invocations.</p> | |
| 725 | <p>Similar to the <code>show</code> command but with more details. Call <code>describe ?</code> for the possible set of invocations.</p> | |
| 720 | 726 | <p>Related: <a href="#show"><code>show</code></a></p> |
| 721 | 727 | <h2 id="dirs"><code>dirs</code></h2> |
| 722 | <h2 id="dpred"><code>dpred</code></h2> | |
| 723 | <p>(pignose)</p> | |
| 724 | 728 | <h2 id="dribble"><code>dribble</code></h2> |
| 725 | 729 | <h2 id="eof"><code>eof</code></h2> |
| 726 | 730 | <p>Terminates reading of the current file. Allows for keeping untested code or documentations below the <code>eof</code> mark. Has to be on a line by itself without leading spaces.</p> |
| 727 | <h2 id="eq"><code>eq [ <op-exp> ]: <term> = <term> .</code></h2> | |
| 731 | <h2 id="eq"><code>eq [ <label-exp> ] <term> = <term> .</code></h2> | |
| 728 | 732 | <p>Declares an axiom, or equation.</p> |
| 729 | 733 | <p>Spaces around the <code>=</code> are necessary to separate the left from the right hand side. The terms given must belong to the same connected component in the graph defined by the sort ordering.</p> |
| 730 | 734 | <p>In simple words, the objects determined by the terms must be interpretable as of the same sort.</p> |
| 731 | <p>The optional part <code><op-exp></code> serves two purposes, one is to give an axiom an identifier, and one is to modify its behavior. The <code><op-exp></code> is of the form:</p> | |
| 735 | <p>The optional part <code><label-exp></code> serves two purposes, one is to give an axiom an identifier, and one is to modify its behavior. The <code><label-exp></code> is of the form:</p> | |
| 732 | 736 | <p><code>[ <modifier> <label> ] :</code></p> |
| 733 | 737 | <p>Warning: The square brackets here are <em>not</em> specifying optional components, but syntactical elements. Thus, a labeled axiom can look like:</p> |
| 734 | 738 | <p><code>eq[foobar] : foo = bar .</code></p> |
| 740 | 744 | eq [:m-or]: q2(N1:Nat NS:NatSet) = p1(N1) .</code></pre> |
| 741 | 745 | <p>In this case an expression like <code>q1(1 2 3)</code> would reduce to <code>p1(1) and p1(2) and p1(3)</code> (modulo AC), and <code>q2(1 2 3)</code> into the same term with <code>or</code> instead.</p> |
| 742 | 746 | <p>Related: <a href="#bceq"><code>bceq</code></a>, <a href="#beq"><code>beq</code></a>, <a href="#ceq"><code>ceq</code></a></p> |
| 747 | <h2 id="citp-equation"><code>:equation</code></h2> | |
| 748 | <p>TODO</p> | |
| 743 | 749 | <h2 id="switch-exec-limit"><code>exec limit</code> switch</h2> |
| 744 | 750 | <p>Possible values: integers, default limit 4611686018427387903.</p> |
| 745 | 751 | <p>Controls the number of maximal transition steps.</p> |
| 748 | 754 | <p>Possible values: <code>on</code> <code>off, default</code>off`.</p> |
| 749 | 755 | <p>controls whether further output is provided during reductions.</p> |
| 750 | 756 | <p>Related: <a href="#reduce"><code>reduce</code></a></p> |
| 751 | <h2 id="execute-dash"><code>exec!</code></h2> | |
| 757 | <h2 id="execute-dash"><code>exec! [ in <mod-exp> : ] <term> .</code></h2> | |
| 752 | 758 | <p>exec! [in <Modexpr> :] <Term> .</p> |
| 753 | 759 | <h2 id="execute"><code>execute [ in <mod-exp> : ] <term> .</code></h2> |
| 754 | 760 | <p>Reduce the given term in the given module, if <code><mod-exp></code> is given, otherwise in the current module.</p> |
| 759 | 765 | <p>Related: <a href="#using"><code>using</code></a>, <a href="#protecting"><code>protecting</code></a>, <a href="#including"><code>including</code></a></p> |
| 760 | 766 | <h2 id="find"><code>find</code></h2> |
| 761 | 767 | <h2 id="switch-find-all-rules"><code>find all rules</code> switch</h2> |
| 762 | <h2 id="flag"><code>flag</code></h2> | |
| 768 | <h2 id="flag"><code>flag(<name>, { on | off })</code></h2> | |
| 763 | 769 | <p>(pignose)</p> |
| 764 | 770 | <h2 id="fullreset"><code>full reset</code></h2> |
| 765 | 771 | <p>Reinitializes the internal state of the system. All supplied modules definitions are lost.</p> |
| 766 | 772 | <p>Related: <a href="#reset"><code>reset</code></a></p> |
| 767 | 773 | <h2 id="gendoc"><code>gendoc <pathname></code></h2> |
| 768 | 774 | <p>generates reference manual from system's on line help documents, and save it to <code>pathname</code>.</p> |
| 769 | <h2 id="goal"><code>goal</code></h2> | |
| 775 | <h2 id="citp-goal"><code>:goal { <sentence> . ... }</code></h2> | |
| 776 | <p>TODO</p> | |
| 777 | <h2 id="goal"><code>goal <term> .</code></h2> | |
| 770 | 778 | <p>(pignose)</p> |
| 771 | 779 | <h2 id="imports"><code>imports { <import-decl> }</code></h2> |
| 772 | 780 | <p>Block enclosing import of other modules (<code>protecting</code> etc). Other statements are not allowed within the <code>imports</code> block. Optional structuring of the statements in a module.</p> |
| 782 | 790 | <p>Imports the object specified by <code>modexp</code> into the current module.</p> |
| 783 | 791 | <p>See <a href="#moduleexpression"><code>module expression</code></a> for format of <code>modexp</code>.</p> |
| 784 | 792 | <p>Related: <a href="#moduleexpression">module expression</a>, <a href="#using"><code>using</code></a>, <a href="#protecting"><code>protecting</code></a>, <a href="#extending"><code>extending</code></a></p> |
| 793 | <h2 id="citp-ind"><code>:ind on <variable> ... .</code></h2> | |
| 794 | <p>TODO</p> | |
| 795 | <h2 id="citp-init"><code>:init { "[" <label> "]" | "(" <sentence> "")} "{" <variable> <- <term>; ... "}"</code></h2> | |
| 796 | <p>TODO</p> | |
| 785 | 797 | <h2 id="input"><code>input <pathname></code></h2> |
| 786 | 798 | <p>Requests the system to read the file specified by the pathname. The file itself may contain <code>input</code> commands. CafeOBJ reads the file up to the end, or until it encounters a line that only contains (the literal) <code>eof</code>.</p> |
| 787 | <h2 id="inspect"><code>inspect</code></h2> | |
| 799 | <h2 id="inspect"><code>inspect <term></code></h2> | |
| 800 | <p>Inspect the internal structure of <term>.</p> | |
| 788 | 801 | <h2 id="instantiation">instantiation of parameterized modules</h2> |
| 789 | 802 | <p>Parameterized modules allow for instantiation. The process of instantiation binds actual parameters to formal parameters. The result of an instantiation is a new module, obtained by replacing occurrences of parameter sorts and operators by their actual counterparts. If, as a result of instantiation, a module is imported twice, it is assumed to be imported once and shared throughout.</p> |
| 790 | 803 | <p>Instantiation is done by</p> |
| 814 | 827 | protecting ( ILIST(SIMPLE-NAT { sort Elt -> Nat }, |
| 815 | 828 | DATATYPE { sort Elt -> Data }) ) |
| 816 | 829 | }</code></pre> |
| 830 | <h2 id="citp-is"><code>:is</code></h2> | |
| 831 | <p>Boolean expression: <code>A :is B</code> where <code>A</code> is a term and <code>B</code> is a sort. Returns true if <code>A</code> is of sort <code>B</code>.</p> | |
| 817 | 832 | <h2 id="let"><code>let <identifier> = <term> .</code></h2> |
| 818 | 833 | <p>Using <code>let</code> one can define aliases, or context variables. Bindings are local to the current module. Variable defined with <code>let</code> can be used in various commands like <code>reduce</code> and <code>parse</code>.</p> |
| 819 | 834 | <p>Although <code>let</code> defined variable behave very similar to syntactic shorthands, they are not. The right hand side <code><term></code> needs to be a fully parsable expression.</p> |
| 820 | <h2 id="lex"><code>lex</code></h2> | |
| 835 | <h2 id="lex"><code>lex (<op>, ..., <op>)</code></h2> | |
| 821 | 836 | <p>(pignose)</p> |
| 822 | 837 | <h2 id="switch-libpath"><code>libpath</code> switch</h2> |
| 823 | 838 | <p>Possible values: list of strings.</p> |
| 833 | 848 | (+ 4 5) -> 9</code></pre> |
| 834 | 849 | <h2 id="lispq"><code>lispq</code></h2> |
| 835 | 850 | <p>Evaluates the following quoted lisp expression. (TODO ???)</p> |
| 836 | <h2 id="list"><code>list</code></h2> | |
| 851 | <h2 id="list"><code>list { axiom | sos | usable | flag | param | option | demod }</code></h2> | |
| 837 | 852 | <p>(pignose)</p> |
| 838 | 853 | <h2 id="lookup"><code>look up <something></code></h2> |
| 839 | 854 | <p>TODO (memory-fault on sbcl)</p> |
| 860 | 875 | <p><code>module*</code> introduces a loose semantic based module.</p> |
| 861 | 876 | <p><code>module!</code> introduces a strict semantic based module.</p> |
| 862 | 877 | <p><code>module</code> introduces a module without specified semantic type.</p> |
| 863 | <p>If <code>params</code> are given, it is a parameterized module. See <code>parameterized module</code> for more details.</p> | |
| 878 | <p>If <code>params</code> are given, it is a parameterized module. See <a href="#parameterizedmodule"><code>parameterized module</code></a> for more details.</p> | |
| 864 | 879 | <p>If <code>principal_sort_spec</code> is given, it has to be of the form <code>principal-sort <sortname></code> (or <code>p-sort <sortname></code>). The principal sort of the module is specified, which allows more concise <code>view</code>s from single-sort modules as the sort mapping needs not be given.</p> |
| 865 | 880 | <h2 id="moduleexpression"><code>module expression</code></h2> |
| 866 | 881 | <p>In various syntax elements not only module names itself, but whole module expressions can appear. A typical example is</p> |
| 868 | 883 | <p>which opens a module expression. The following constructs are supported:</p> |
| 869 | 884 | <dl> |
| 870 | 885 | <dt>module name</dt> |
| 871 | <dd><p>using the name of a module</p> | |
| 886 | <dd>using the name of a module | |
| 872 | 887 | </dd> |
| 873 | 888 | <dt>renaming</dt> |
| 874 | 889 | <dd><p><code><mod_exp> * { <mappings> }</code></p> |
| 879 | 894 | <p>This expression describes a module consisting of all the module elements of the summands. If a submodule is imported more than once, it is assumed to be shared.</p> |
| 880 | 895 | </dd> |
| 881 | 896 | </dl> |
| 882 | <h2 id="names"><code>names</code></h2> | |
| 883 | <p>show</p> | |
| 897 | <h2 id="names"><code>names <mod-exp></code> .</h2> | |
| 898 | <p>List up all the named objects in module <mod-exp>.</p> | |
| 899 | <h2 id="no-autoload"><code>no autoload <module-name></code></h2> | |
| 900 | <p>Stop <code>autoload</code> of module with the name <module-name> . Please refer to <code>autoload</code> command.</p> | |
| 901 | <p>Related: <a href="#autoload"><code>autoload</code></a></p> | |
| 902 | <h2 id="citp-normalize"><code>:normalize { on | off}</code></h2> | |
| 903 | <p>Normalize the LHS of an instance of the axiom generated by :init command.</p> | |
| 884 | 904 | <h2 id="onthefly">on-the-fly declarations</h2> |
| 885 | 905 | <p>Variables and constants can be declared <em>on-the-fly</em> (or <em>inline</em>). If an equation contains a qualified variable (see <a href="#qualified">qualified term</a>), i.e., <code><name>:<sort-name></code>, then from this point on <em>within</em> the current equation only <code><name></code> is declared as a variable of sort <code><sort-name></code>.</p> |
| 886 | 906 | <p>It is allowed to redeclare a previously defined variable name via an on-the-fly declaration, but as mentioned above, not via an explicit redeclaration.</p> |
| 895 | 915 | <dl> |
| 896 | 916 | <dt>prefix-spec</dt> |
| 897 | 917 | <dd><p>the <code><op-spec></code> does not contain a literal <code>_</code>: This defines a normal prefix operator with domain <code><sorts></code> and co-domain <code><sort></code></p> |
| 898 | Example: <code>op f : S T -> U</code> | |
| 899 | </dd> | |
| 900 | <dt>mixfix-spec</dt> | |
| 918 | <p>Example: <code>op f : S T -> U</code> mixfix-spec</p> | |
| 919 | </dd> | |
| 901 | 920 | <dd><p>the <code><op-spec></code> contains exactly as many literal <code>_</code> as there are sort names in <code><sorts></code>: This defines an arbitrary mixfix (including postfix) operator where the arguments are inserted into the positions designated by the underbars.</p> |
| 902 | 921 | <p>Example: <code>op _+_ : S S -> S</code></p> |
| 903 | 922 | </dd> |
| 910 | 929 | <p>In the specification of an operator using the <a href="#op"><code>op</code></a> (and related) keyword, attributes of the operator can be specified. An <code><attribute-list></code> is a space-separate list of single attribute definitions. Currently the following attributes are supported</p> |
| 911 | 930 | <dl> |
| 912 | 931 | <dt><code>associative</code></dt> |
| 913 | <dd><p>specifies an associative operator, alias <code>assoc</code></p> | |
| 932 | <dd>specifies an associative operator, alias <code>assoc</code> | |
| 914 | 933 | </dd> |
| 915 | 934 | <dt><code>commutative</code></dt> |
| 916 | <dd><p>specifies a commutative operator, alias <code>comm</code></p> | |
| 935 | <dd>specifies a commutative operator, alias <code>comm</code> | |
| 917 | 936 | </dd> |
| 918 | 937 | <dt><code>itempotence</code></dt> |
| 919 | <dd><p>specifies an idempotent operator, alias <code>idem</code></p> | |
| 938 | <dd>specifies an idempotent operator, alias <code>idem</code> | |
| 920 | 939 | </dd> |
| 921 | 940 | <dt><code>id: <const></code></dt> |
| 922 | <dd><p>specifies that an identity of the operator exists and that it is <code><const></code></p> | |
| 941 | <dd>specifies that an identity of the operator exists and that it is <code><const></code> | |
| 923 | 942 | </dd> |
| 924 | 943 | <dt><code>prec: <int></code></dt> |
| 925 | <dd><p>specifies the parsing precedence of the operator, an integer <int>. Smaller precedence values designate stronger binding. See <a href="#opprec">operator precedence</a> for details of the predefined operator precedence values.</p> | |
| 944 | <dd>specifies the parsing precedence of the operator, an integer <int>. Smaller precedence values designate stronger binding. See <a href="#opprec">operator precedence</a> for details of the predefined operator precedence values. | |
| 926 | 945 | </dd> |
| 927 | 946 | <dt><code>l-assoc</code> and <code>r-assoc</code></dt> |
| 928 | <dd>specifies that the operator is left-associative or | |
| 929 | </dd> | |
| 930 | </dl> | |
| 931 | <p>right-associative</p> | |
| 932 | <dl> | |
| 947 | <dd>specifies that the operator is left-associative or right-associative | |
| 948 | </dd> | |
| 933 | 949 | <dt><code>constr</code></dt> |
| 934 | <dd><p>specifies that the operator is a constructor of the coarity sort. (not evaluated at the moment)</p> | |
| 950 | <dd>specifies that the operator is a constructor of the coarity sort. (not evaluated at the moment) | |
| 935 | 951 | </dd> |
| 936 | 952 | <dt><code>strat: ( <int-list> )</code></dt> |
| 937 | 953 | <dd><p>specifies the evaluation strategy. Each integer in the list refers to an argument of the operator, where <code>0</code> refers to the whole term, <code>1</code> for the first argument, etc. Evaluation proceeds in order of the <code><int-list></code>. Example:</p> |
| 940 | 956 | <p>Using negative values allows for lazy evaluation of the corresponding arguments.</p> |
| 941 | 957 | </dd> |
| 942 | 958 | <dt><code>memo</code></dt> |
| 943 | <dd><p>tells the system to remember the results of evaluations where the operator appeared. See <a href="#switch-memo"><code>memo</code> switch</a> for details.</p> | |
| 959 | <dd>tells the system to remember the results of evaluations where the operator appeared. See <a href="#switch-memo"><code>memo</code> switch</a> for details. | |
| 944 | 960 | </dd> |
| 945 | 961 | </dl> |
| 946 | 962 | <p>Remarks:</p> |
| 962 | 978 | <li>all other operators (constants, operators of the form <code>a _ b</code>, etc.) receive precedence 0.</li> |
| 963 | 979 | </ul> |
| 964 | 980 | <p>Related: <a href="#opattr">operator attributes</a></p> |
| 965 | <h2 id="option"><code>option</code></h2> | |
| 966 | <p>(pignose)</p> | |
| 967 | <h2 id="param"><code>param</code></h2> | |
| 981 | <h2 id="option"><code>option { reset | = <name> }</code></h2> | |
| 982 | <p>(pignose)</p> | |
| 983 | <h2 id="param"><code>param(<name>, <value>)</code></h2> | |
| 968 | 984 | <p>(pignose)</p> |
| 969 | 985 | <h2 id="parameterizedmodule"><code>parameterized module</code></h2> |
| 970 | 986 | <p>A module with a parameter list (see <code>module</code>) is a parameterized module. Parameters are given as a comma (<code>,</code>) separated list. Each parameter is of the form <code>[ <import_mode> ] <param_name> :: <module_name></code> (spaces around <code>::</code> are obligatory).</p> |
| 985 | 1001 | <p>In case of ambiguous terms, i.e., different possible parse trees, the command will prompt for one of the trees.</p> |
| 986 | 1002 | <p>Related: <a href="#qualified"><code>qualified term</code></a></p> |
| 987 | 1003 | <h2 id="switch-parse-normalize"><code>parse normalize</code> switch</h2> |
| 1004 | <h2 id="citp-pctf"><code>:pctf { <bool-term> . ... <bool-term> .}</code></h2> | |
| 1005 | <p>TODO</p> | |
| 1006 | <h2 id="citp-pctf-"><code>:pctf- { <bool-term> . ... <bool-term> . }</code></h2> | |
| 1007 | <p>TODO</p> | |
| 988 | 1008 | <h2 id="popd"><code>popd</code></h2> |
| 989 | 1009 | <h2 id="pred"><code>pred <op-spec> : <sorts></code></h2> |
| 990 | 1010 | <p>Short hand for <code>op <op-spec> : <sorts> -> Bool</code> defining a predicate.</p> |
| 1004 | 1024 | <p>Protect a module from being overwritten. Some modules vital for the system are initially protected. Can be reversed with <code>unprotect</code>.</p> |
| 1005 | 1025 | <p>Related: <a href="#unprotect"><code>unprotect</code></a></p> |
| 1006 | 1026 | <h2 id="protecting"><code>protecting ( <modexp> )</code></h2> |
| 1007 | <p>Imports the object specified by <code>modexp</code> into the current module, preserving all intended models as they are. See <code>module expression</code> for format of <code>modexp</code>.</p> | |
| 1027 | <p>Imports the object specified by <code>modexp</code> into the current module, preserving all intended models as they are. See <a href="#moduleexpression"><code>module expression</code></a> for format of <code>modexp</code>.</p> | |
| 1008 | 1028 | <p>Related: <a href="#including"><code>including</code></a>, <a href="#using"><code>using</code></a>, <a href="#extending"><code>extending</code></a></p> |
| 1009 | 1029 | <h2 id="provide"><code>provide <feature></code></h2> |
| 1010 | 1030 | <p>Discharges a feature requirement: once <code>provide</code>d, all the subsequent <code>require</code>ments of a feature are assumed to have been fulfilled already.</p> |
| 1011 | 1031 | <p>Related: <a href="#require"><code>require</code></a></p> |
| 1012 | <h2 id="pushd"><code>pushd</code></h2> | |
| 1013 | <h2 id="pvar"><code>pvar</code></h2> | |
| 1014 | <p>(pignose)</p> | |
| 1032 | <h2 id="pushd"><code>pushd <directory></code></h2> | |
| 1033 | <h2 id="pvar"><code>pvar <var-name> : <sort-name></code></h2> | |
| 1034 | <p>(pignose)</p> | |
| 1035 | <p>Related: <a href="#var"><code>vars</code></a>, <a href="#var"><code>var</code></a></p> | |
| 1015 | 1036 | <h2 id="pwd"><code>pwd</code></h2> |
| 1016 | 1037 | <p>Prints the current working directory.</p> |
| 1017 | 1038 | <p>Related: <a href="#ls"><code>ls</code></a>, <a href="#cd"><code>cd</code></a></p> |
| 1024 | 1045 | <p>In case that a term can be parsed into different sort, it is possible to qualify the term to one of the possible sorts by affixing it with <code>: <sort-name></code> (spaces before and after the <code>:</code> are optional).</p> |
| 1025 | 1046 | <p>Related: <a href="#parse"><code>parse</code></a></p> |
| 1026 | 1047 | <h3 id="example-3">Example</h3> |
| 1027 | <p><code>1:NzNat</code> <code>2:Nat</code></p> | |
| 1048 | <p><code>(1):NzNat</code> <code>(2):Nat</code></p> | |
| 1028 | 1049 | <h2 id="switch-quiet"><code>quiet</code> switch</h2> |
| 1029 | 1050 | <p>Possible values: <code>on</code> <code>off</code>, default <code>off</code></p> |
| 1030 | 1051 | <p>If set to <code>on</code>, the system only issues error messages.</p> |
| 1031 | 1052 | <p>Related: <a href="#switch-verbose"><code>verbose</code></a></p> |
| 1032 | 1053 | <h2 id="quit"><code>quit</code></h2> |
| 1033 | 1054 | <p>Leaves the CafeOBJ interpreter.</p> |
| 1055 | <h2 id="citp-red"><code>{ :red | :exec | :bred } [in <goal-name> :] <term> .</code></h2> | |
| 1056 | <p>reduce the term in specified goal <goal-name>.</p> | |
| 1034 | 1057 | <h2 id="reduce"><code>reduce [ in <mod-exp> : ] <term> .</code></h2> |
| 1035 | 1058 | <p>Reduce the given term in the given module, if <code><mod-exp></code> is given, otherwise in the current module.</p> |
| 1036 | 1059 | <p>For <code>reduce</code> only equations and conditional equations are taken into account for reduction.</p> |
| 1050 | 1073 | <h2 id="reset"><code>reset</code></h2> |
| 1051 | 1074 | <p>Restores the definitions of built-in modules and preludes, but does not affect other modules.</p> |
| 1052 | 1075 | <p>Related: <a href="#fullreset"><code>full reset</code></a></p> |
| 1053 | <h2 id="resolve"><code>resolve</code></h2> | |
| 1076 | <h2 id="resolve"><code>resolve {. | <file-path> }</code></h2> | |
| 1054 | 1077 | <p>(pignose)</p> |
| 1055 | 1078 | <h2 id="restore"><code>restore <pathname></code></h2> |
| 1056 | 1079 | <p>Restores module definitions from the designated file <code>pathname</code> which has been saved with the <code>save</code> command. <code>input</code> can also be used but the effects might be different.</p> |
| 1060 | 1083 | <p>Possible values: positive integers, default not specified.</p> |
| 1061 | 1084 | <p>Allows limiting the number of rewrite steps during a step-wise execution.</p> |
| 1062 | 1085 | <p>Related: <a href="#switch-step"><code>step switch</code></a></p> |
| 1063 | <h2 id="rl"><code>rl</code></h2> | |
| 1064 | <h2 id="rule"><code>rule</code></h2> | |
| 1086 | <h2 id="citp-roll"><code>:roll back</code></h2> | |
| 1087 | <p>TODO</p> | |
| 1088 | <h2 id="citp-rule"><code>:rule</code></h2> | |
| 1089 | <p>TODO</p> | |
| 1090 | <h2 id="rule"><code>rule [ <label-exp> ] <term> => <term> .</code></h2> | |
| 1091 | <p>Synonym of 'trans'.</p> | |
| 1092 | <p>Related: <a href="#trans"><code>trans</code></a></p> | |
| 1065 | 1093 | <h2 id="save"><code>save <pathname></code></h2> |
| 1066 | 1094 | <p>Saves module definitions into the designated file <code>pathname</code>. File names should be suffixed with <code>.bin</code>.</p> |
| 1067 | 1095 | <p><code>save</code> also saves the contents of prelude files as well as module definitions given in the current session.</p> |
| 1068 | 1096 | <p>Related: <a href="#save-system"><code>save-system</code></a>, <a href="#restore"><code>restore</code></a>, <a href="#input"><code>input</code></a></p> |
| 1069 | <h2 id="save-option"><code>save-option</code></h2> | |
| 1097 | <h2 id="save-option"><code>save-option <name></code></h2> | |
| 1070 | 1098 | <p>(pignose)</p> |
| 1071 | 1099 | <h2 id="save-system"><code>save-system <pathname></code></h2> |
| 1072 | 1100 | <p>Dumps the image of the whole system into a file. This is functionality provided by the underlying Common Lisp system and might carry some restrictions.</p> |
| 1073 | 1101 | <p>Related: <a href="#restore"><code>restore</code></a>, <a href="#save"><code>save</code></a>, <a href="#input"><code>input</code></a></p> |
| 1074 | <h2 id="scase"><code>scase</code></h2> | |
| 1102 | <h2 id="scase"><code>scase (<term>) in (<mod-exp>) as <name> { <decl> ..} : <term> .</code></h2> | |
| 1075 | 1103 | <h2 id="searchpredicate"><code>search predicates</code></h2> |
| 1076 | 1104 | <p>CafeOBJ provides a whole set of search predicates, that searches the reachable states starting from a given state, optionally checking additional conditions. All of them based on the following three basic ones:</p> |
| 1077 | 1105 | <ul> |
| 1089 | 1117 | <p>There are two orthogonal extension to this search predicate, one adds a <code>suchThat</code> clause, one adds a <code>withStateEq</code> clause.</p> |
| 1090 | 1118 | <dl> |
| 1091 | 1119 | <dt><code>S =(n,m)=>* SS [if Pred1] suchThat Pred2</code></dt> |
| 1092 | <dd><p>(and similar for <code>!</code> and <code>+</code>) In this case not only the existence, of a transition sequence is tested, but also whether the predicate <code>Pred2</code>, which normally takes <code>S</code> and <code>SS</code> as arguments, holds.</p> | |
| 1120 | <dd>(and similar for <code>!</code> and <code>+</code>) In this case not only the existence, of a transition sequence is tested, but also whether the predicate <code>Pred2</code>, which normally takes <code>S</code> and <code>SS</code> as arguments, holds. | |
| 1093 | 1121 | </dd> |
| 1094 | 1122 | <dt><code>S =(n,m)=>* SS [if Pred1] withStateEq Pred2</code></dt> |
| 1095 | <dd><p>(and similar for <code>!</code> and <code>+</code>) TODO</p> | |
| 1123 | <dd>(and similar for <code>!</code> and <code>+</code>) TODO | |
| 1096 | 1124 | </dd> |
| 1097 | 1125 | </dl> |
| 1098 | 1126 | <p>These two cases can also be combined into</p> |
| 1099 | 1127 | <p><code>S =(n,m)=>* SS [if Pred1] suchThat Pred2 withStateEq Pred3</code></p> |
| 1128 | <h2 id="citp-select"><code>:select <goal-name></code></h2> | |
| 1129 | <p>TODO</p> | |
| 1100 | 1130 | <h2 id="select"><code>select <mod_exp> .</code></h2> |
| 1101 | 1131 | <p>Selects a module given by the module expression <code><mod_exp></code> as the current module. All further operations are carried out within the given module. In contrast to <code>open</code> this does not allow for modification of the module, e.g., addition of new sorts etc.</p> |
| 1102 | 1132 | <p>Related: <a href="#moduleexpression"><code>module expression</code></a>, <a href="#open"><code>open</code></a></p> |
| 1104 | 1134 | <p>Depending on the type of the switch, options and value specification varies. Possible value types for switches are Boolean (<code>on</code>, <code>off</code>), string (<code>"value"</code>), integers (5434443), lists (lisp syntax).</p> |
| 1105 | 1135 | <p>For a list of all available switches, use <code>set ?</code>. To see the current values, use <code>show switches</code>. To single out two general purpose switches, <code>verbose</code> and <code>quiet</code> tell the system to behave in the respective way.</p> |
| 1106 | 1136 | <p>Related: <a href="#switches"><code>switches</code></a>, <a href="#show"><code>show</code></a></p> |
| 1137 | <h2 id="citp-show"><code>:show <something></code></h2> | |
| 1138 | <p>TODO</p> | |
| 1139 | <p>Related: <a href="#citp-describe"><code>:describe</code></a></p> | |
| 1107 | 1140 | <h2 id="show"><code>show <something></code></h2> |
| 1108 | 1141 | <p>The <code>show</code> command provides various ways to inspect all kind of objects of the CafeOBJ language. For a full list call <code>show ?</code>.</p> |
| 1109 | 1142 | <p>Some of the more important (but far from complete list) ways to call the <code>show</code> command are:</p> |
| 1113 | 1146 | <li><code>show switches</code> - lists all possible switches</li> |
| 1114 | 1147 | <li><code>show term [ tree ]</code> - displays a term, possible in tree format</li> |
| 1115 | 1148 | </ul> |
| 1116 | <p>See the entry for <code>switches</code> for a full list.</p> | |
| 1149 | <p>See the entry for <a href="#switches"><code>switches</code></a> for a full list.</p> | |
| 1117 | 1150 | <p>Related: <a href="#describe"><code>describe</code></a>, <a href="#switches"><code>switches</code></a></p> |
| 1118 | 1151 | <h2 id="switch-show-mode"><code>show mode</code> switch</h2> |
| 1119 | 1152 | <p>Possible values for <code>set show mode <mode></code> are <code>cafeobj</code> and <code>meta</code>.</p> |
| 1120 | 1153 | <p>TODO no further information on what this changes</p> |
| 1121 | <h2 id="sigmatch"><code>sigmatch</code></h2> | |
| 1154 | <h2 id="sigmatch"><code>sigmatch (<mod-exp>) to (<mod-exp>)</code></h2> | |
| 1122 | 1155 | <p>(pignose)</p> |
| 1123 | 1156 | <h2 id="signature"><code>signature { <sig-decl> }</code></h2> |
| 1124 | 1157 | <p>Block enclosing declarations of sorts and operators. Other statements are not allowed within the <code>signature</code> block. Optional structuring of the statements in a module.</p> |
| 1134 | 1167 | <h3 id="example-4">Example</h3> |
| 1135 | 1168 | <pre><code> [ A B , C D < A < E, B < D ]</code></pre> |
| 1136 | 1169 | <p>defines five sorts <code>A</code>,...,<code>E</code>, with the following relations: <code>C < A</code>, <code>D < A</code>, <code>A < E</code>, <code>B < D</code>.</p> |
| 1137 | <h2 id="sos"><code>sos</code></h2> | |
| 1138 | <p>(pignose)</p> | |
| 1170 | <h2 id="sos"><code>sos { = | + | - } { <clause> , ... }</code></h2> | |
| 1171 | <p>(pignose)</p> | |
| 1172 | <h2 id="citp-spoiler"><code>:spoiler { on | off}</code></h2> | |
| 1173 | <p>TODO</p> | |
| 1139 | 1174 | <h2 id="start"><code>start <term> .</code></h2> |
| 1140 | 1175 | <p>Sets the focus onto the given term <code><term></code> of the currently opened module or context. Commands like <code>apply</code>, <code>choose</code>, or <code>match</code> will then operate on this term.</p> |
| 1141 | 1176 | <p>Related: <a href="#match"><code>match</code></a>, <a href="#choose"><code>choose</code></a>, <a href="#apply"><code>apply</code></a></p> |
| 1147 | 1182 | <p>With this switch turned on, rewriting proceeds in steps and prompts the user interactively. At each prompt the following commands can be given to the stepper (with our without leading colon <code>:</code>):</p> |
| 1148 | 1183 | <dl> |
| 1149 | 1184 | <dt><code>help</code></dt> |
| 1150 | <dd>(<code>h</code>, <code>?</code>) print out help page | |
| 1151 | </dd> | |
| 1152 | <dt><code>next</code></dt> | |
| 1153 | <dd>(<code>n</code>) go one step | |
| 1154 | </dd> | |
| 1155 | <dt><code>continue</code></dt> | |
| 1156 | <dd>(<code>c</code>) continue rewriting without stepping | |
| 1157 | </dd> | |
| 1158 | <dt><code>quit</code></dt> | |
| 1159 | <dd>(<code>q</code>) leave stepper continuing rewrite | |
| 1160 | </dd> | |
| 1161 | <dt><code>abort</code></dt> | |
| 1162 | <dd>(<code>a</code>) abort rewriting | |
| 1163 | </dd> | |
| 1164 | <dt><code>rule</code></dt> | |
| 1165 | <dd>(<code>r</code>) print out current rewrite rule | |
| 1166 | </dd> | |
| 1167 | <dt><code>subst</code></dt> | |
| 1168 | <dd>(<code>s</code>) print out substitution | |
| 1169 | </dd> | |
| 1170 | <dt><code>limit</code></dt> | |
| 1171 | <dd>(<code>l</code>) print out rewrite limit count | |
| 1172 | </dd> | |
| 1173 | <dt><code>pattern</code></dt> | |
| 1174 | <dd>(<code>p</code>) print out stop pattern | |
| 1175 | </dd> | |
| 1176 | <dt><code>stop [<term>] .</code></dt> | |
| 1177 | <dd>set (or unset) stop pattern | |
| 1178 | </dd> | |
| 1179 | <dt><code>rwt [<number>] .</code></dt> | |
| 1185 | <dd>(<code>h</code>, <code>?</code>) print out help page <code>next</code> | |
| 1186 | </dd> | |
| 1187 | <dd>(<code>n</code>) go one step <code>continue</code> | |
| 1188 | </dd> | |
| 1189 | <dd>(<code>c</code>) continue rewriting without stepping <code>quit</code> | |
| 1190 | </dd> | |
| 1191 | <dd>(<code>q</code>) leave stepper continuing rewrite <code>abort</code> | |
| 1192 | </dd> | |
| 1193 | <dd>(<code>a</code>) abort rewriting <code>rule</code> | |
| 1194 | </dd> | |
| 1195 | <dd>(<code>r</code>) print out current rewrite rule <code>subst</code> | |
| 1196 | </dd> | |
| 1197 | <dd>(<code>s</code>) print out substitution <code>limit</code> | |
| 1198 | </dd> | |
| 1199 | <dd>(<code>l</code>) print out rewrite limit count <code>pattern</code> | |
| 1200 | </dd> | |
| 1201 | <dd>(<code>p</code>) print out stop pattern <code>stop [<term>] .</code> | |
| 1202 | </dd> | |
| 1203 | <dd>set (or unset) stop pattern <code>rwt [<number>] .</code> | |
| 1204 | </dd> | |
| 1180 | 1205 | <dd>set (or unset) max number of rewrite |
| 1181 | 1206 | </dd> |
| 1182 | 1207 | </dl> |
| 1213 | 1238 | <p>Remove overwrite protection from a module that has been protected with the <code>protect</code> call. Some modules vital for the system are initially protected.</p> |
| 1214 | 1239 | <p>Related: <a href="#protect"><code>protect</code></a></p> |
| 1215 | 1240 | <h2 id="using"><code>using ( <modexp> )</code></h2> |
| 1216 | <p>Imports the object specified by <code>modexp</code> into the current module without any restrictions on the models. See <code>module expression</code> for format of <code>modexp</code>.</p> | |
| 1241 | <p>Imports the object specified by <code>modexp</code> into the current module without any restrictions on the models. See <a href="#moduleexpression"><code>module expression</code></a> for format of <code>modexp</code>.</p> | |
| 1217 | 1242 | <p>Related: <a href="#protecting"><code>protecting</code></a>, <a href="#including"><code>including</code></a>, <a href="#extending"><code>extending</code></a></p> |
| 1218 | 1243 | <h2 id="var"><code>var <var-name> : <sort-name></code></h2> |
| 1219 | 1244 | <p>Declares a variable <code><var-name></code> to be of sort <code><sort-name></code>. The scope of the variable is the current module. Redeclarations of variable names are not allowed. Several variable of the same sort can be declared at the same time using the <code>vars</code> construct:</p> |
| 1220 | 1245 | <p><code>vars <var-name> ... : <sort-name></code></p> |
| 1221 | 1246 | <p>Related: <a href="#onthefly"><code>on-the-fly</code></a>, <a href="#qualified"><code>qualified term</code></a>, <a href="#op"><code>op</code></a></p> |
| 1247 | <h2 id="citp-verbose"><code>:verbose { on | off }</code></h2> | |
| 1248 | <p>TODO</p> | |
| 1222 | 1249 | <h2 id="switch-verbose"><code>verbose</code> switch</h2> |
| 1223 | 1250 | <p>Possible values: <code>on</code> <code>off</code>, default <code>off</code>.</p> |
| 1224 | 1251 | <p>If turn <code>on</code>, the system is much more verbose in many commands.</p> |
| 0 | 0 | --- |
| 1 | 1 | title: CafeOBJ Reference Manual |
| 2 | date: 2015-02-25 (v1.5.3) | |
| 2 | date: 2015-09-08 (v1.5.4b14) | |
| 3 | 3 | author: Toshimi Sawada, Kokichi Futatsugi, Norbert Preining |
| 4 | 4 | bibliography: manual.bib |
| 5 | 5 | --- |
Binary diff not shown
| 7 | 7 | On Unix only, forks a shell and executes the given `<command>`. |
| 8 | 8 | |
| 9 | 9 | |
| 10 | ## `#define` ## {#sharp-define} | |
| 10 | ## `#define <symbol> := <term> .` ## {#sharp-define} | |
| 11 | 11 | |
| 12 | 12 | |
| 13 | 13 | |
| 35 | 35 | |
| 36 | 36 | Do nothing. |
| 37 | 37 | |
| 38 | ||
| 39 | ## `:apply (<tactic> ...) [to <goal-name>]` ## {#:apply} | |
| 40 | ||
| 41 | TODO | |
| 42 | ||
| 43 | ## `:auto` ## {#:auto} | |
| 44 | ||
| 45 | TODO | |
| 46 | ||
| 47 | ## `:backward equation` ## {#:backward} | |
| 48 | ||
| 49 | TODO | |
| 50 | ||
| 51 | ## `:cp { "[" <label> "]" | "(" <axiom> . ")" } >< { "[" <label> "]" | "(" <axiom> .")" }` ## {#:cp} | |
| 52 | ||
| 53 | TODO | |
| 54 | ||
| 55 | ## `:csp { eq [ <op-exp>]: <term> = <term> . ...}` ## {#:csp} | |
| 56 | ||
| 57 | TODO | |
| 58 | ||
| 59 | ## `:ctf { eq [ <op-exp> ]: <term> = <term> .` ## {#:ctf} | |
| 60 | ||
| 61 | TODO | |
| 62 | ||
| 63 | ## `:describe <something>` ## {#:describe} | |
| 64 | ||
| 65 | Similar to the `:show` command but with more details. See `:describe ?` for | |
| 66 | the possible set of invocations. | |
| 67 | ||
| 68 | ||
| 69 | Related: [`:show`](#:show) | |
| 70 | ||
| 71 | ## `:equation` ## {#:equation} | |
| 72 | ||
| 73 | TODO | |
| 74 | ||
| 75 | ## `:goal { <axiom> . ... }` ## {#:goal} | |
| 76 | ||
| 77 | TODO | |
| 78 | ||
| 79 | ## `:ind on <variable> ... .` ## {#:ind} | |
| 80 | ||
| 81 | TODO | |
| 82 | ||
| 83 | ## `:init { "[" <label> "]" | "(" <axiom> "")} "{" <variable> <- <term>; ... "}"` ## {#:init} | |
| 84 | ||
| 85 | TODO | |
| 86 | ||
| 87 | ## `:is` ## {#:is} | |
| 88 | ||
| 89 | Boolean expression: `A :is B` where `A` is a term and | |
| 90 | `B` is a sort. Returns true if `A` is of sort `B`. | |
| 91 | ||
| 92 | ||
| 93 | ## `:lred <term> .` ## {#:red} | |
| 94 | ||
| 95 | TODO | |
| 96 | ||
| 97 | ## `:roll back` ## {#:roll} | |
| 98 | ||
| 99 | TODO | |
| 100 | ||
| 101 | ## `:rule` ## {#:rule} | |
| 102 | ||
| 103 | TODO | |
| 104 | ||
| 105 | ## `:select <goal-name>` ## {#:select} | |
| 106 | ||
| 107 | TODO | |
| 108 | ||
| 109 | ## `:show <something>` ## {#:show} | |
| 110 | ||
| 111 | TODO | |
| 112 | ||
| 113 | Related: [`:describe`](#:describe) | |
| 114 | ||
| 115 | ## `:verbose { on | off }` ## {#:verbose} | |
| 116 | ||
| 117 | TODO | |
| 118 | 38 | |
| 119 | 39 | ## `=` ## {#axeq} |
| 120 | 40 | |
| 165 | 85 | |
| 166 | 86 | ## `? [<term>]` ## {#help} |
| 167 | 87 | |
| 168 | Without any argument, lists all top-level commands. | |
| 88 | Without any argument, shows the brief guide of online help system. | |
| 169 | 89 | With argument gives the reference manual description of `term`. |
| 170 | 90 | In addition to this, many commands allow for passing `?` as argument |
| 171 | 91 | to obtain further help. |
| 203 | 123 | will search for entries that contain the string `foo` as well as |
| 204 | 124 | either the string `atte` or `attr`. |
| 205 | 125 | |
| 126 | ## `?com [ <term> ]` ## {#help-commands} | |
| 127 | ||
| 128 | List commands or declarations categorized by the key <term>. | |
| 129 | <term> is one of 'decl', 'module', 'parse', 'rewrite', | |
| 130 | 'inspect', 'switch', 'proof', 'system', 'inspect', 'library', 'help', 'io' or 'misc'. | |
| 131 | If <term> is omitted, the list of available <term> will be printed. | |
| 132 | ||
| 133 | ||
| 206 | 134 | ## `[` ## {#sortsymbol} |
| 207 | 135 | |
| 208 | 136 | Starts a sort declaration. See [sort declaration](#sort) for details. |
| 229 | 157 | |
| 230 | 158 | |
| 231 | 159 | Related: [operator attributes](#opattr), [`memo`](#switch-memo) |
| 160 | ||
| 161 | ## `:apply (<tactic> ...) [to <goal-name>]` ## {#citp-apply} | |
| 162 | ||
| 163 | Apply the list of tactics given within parenthesis to either | |
| 164 | the current goal, or the goal given as `<goal-name>`. | |
| 165 | ||
| 166 | Related: [`citp`](#citp) | |
| 232 | 167 | |
| 233 | 168 | ## `apply <action> [ <subst> ] <range> <selection>` ## {#apply} |
| 234 | 169 | |
| 302 | 237 | |
| 303 | 238 | Related: [`start`](#start), [`choose`](#choose) |
| 304 | 239 | |
| 240 | ## `:auto` ## {#citp-auto} | |
| 241 | ||
| 242 | Applies the following set of tactics: `(SI CA TC IP RD)`. | |
| 243 | ||
| 244 | Related: [`citp`](#citp) | |
| 245 | ||
| 305 | 246 | ## `auto context` switch ## {#switch-auto-context} |
| 306 | 247 | |
| 307 | 248 | Possible values: `on` or `off`, default is `off`. |
| 311 | 252 | a module's content will switch the current module. |
| 312 | 253 | |
| 313 | 254 | |
| 314 | ## `autoload` ## {#autoload} | |
| 315 | ||
| 316 | ||
| 317 | ||
| 318 | ||
| 319 | ## `ax` ## {#ax} | |
| 255 | ## `autoload <module-name> <file-name>` ## {#autoload} | |
| 256 | ||
| 257 | When evaluating a <module-name> and found that | |
| 258 | it is not yet declared, the system read in <file-name> then | |
| 259 | retries the evaluation. | |
| 260 | ||
| 261 | ||
| 262 | Related: [`no autoload`](#no-autoload) | |
| 263 | ||
| 264 | ## `ax [ <label-exp> ] <term> = <term>` . ## {#ax} | |
| 320 | 265 | |
| 321 | 266 | (pignose) |
| 322 | 267 | |
| 331 | 276 | |
| 332 | 277 | Related: [`trans`](#trans), [`eq`](#eq), [`var`](#var), [`imports`](#imports), [`signature`](#signature) |
| 333 | 278 | |
| 334 | ## `bax` ## {#bax} | |
| 279 | ## `:backward equation` ## {#citp-backward} | |
| 280 | ||
| 281 | TODO | |
| 282 | ||
| 283 | Related: [`citp`](#citp) | |
| 284 | ||
| 285 | ## `bax [ <label-exp> ] <term> = <term>` . ## {#bax} | |
| 335 | 286 | |
| 336 | 287 | (pignose) |
| 337 | 288 | |
| 338 | 289 | |
| 339 | ## `bceq [ <op-exp> ] <term> = <term> if <boolterm> .` ## {#bceq} | |
| 290 | ## `bceq [ <label-exp> ] <term> = <term> if <boolterm> .` ## {#bceq} | |
| 340 | 291 | |
| 341 | 292 | Defines a behavioral conditional equation. For details see [`ceq`](#ceq). |
| 342 | 293 | |
| 343 | 294 | |
| 344 | 295 | Related: [`beq`](#beq), [`ceq`](#ceq), [`eq`](#eq) |
| 296 | ||
| 297 | ## `bcrule [ <label-exp> ] <term> => <term> if <term> .` ## {#bcrule} | |
| 298 | ||
| 299 | Synonym of 'bctrans' | |
| 300 | ||
| 301 | ||
| 302 | Related: [`bctrans`](#bctrans) | |
| 345 | 303 | |
| 346 | 304 | ## `bctrans [ <label-exp> ] <term> => <term> if <bool> .` ## {#bctrans} |
| 347 | 305 | |
| 351 | 309 | |
| 352 | 310 | Related: [`btrans`](#btrans), [`ctrans`](#ctrans), [`trans`](#trans) |
| 353 | 311 | |
| 354 | ## `beq [ <op-exp> ] <term> = <term> .` ## {#beq} | |
| 312 | ## `beq [ <label-exp> ] <term> = <term> .` ## {#beq} | |
| 355 | 313 | |
| 356 | 314 | Defines a behavioral equation. For details see [`eq`](#eq). |
| 357 | 315 | |
| 358 | 316 | |
| 359 | 317 | Related: [`bceq`](#bceq), [`ceq`](#ceq), [`eq`](#eq) |
| 360 | 318 | |
| 361 | ## `bgoal` ## {#bgoal} | |
| 319 | ## `bgoal <term> .` ## {#bgoal} | |
| 362 | 320 | |
| 363 | 321 | (pignose) |
| 364 | 322 | |
| 323 | ||
| 324 | ## `binspect [in <module-name> :] <boolean-term> .` ## {#binspect} | |
| 325 | ||
| 326 | TODO | |
| 327 | ||
| 328 | ## `:binspect [in <goal-name> :] <boolean-term> .` ## {#citp-binspect} | |
| 329 | ||
| 330 | TODO | |
| 365 | 331 | |
| 366 | 332 | ## `bop <op-spec> : <sorts> -> <sort>` ## {#bop} |
| 367 | 333 | |
| 393 | 359 | |
| 394 | 360 | Related: [`reduce`](#reduce), [`execute`](#execute) |
| 395 | 361 | |
| 396 | ## `brl` ## {#brl} | |
| 397 | ||
| 398 | ||
| 399 | ||
| 400 | ||
| 401 | ## `brule` ## {#brule} | |
| 402 | ||
| 403 | ||
| 404 | ||
| 362 | ## `{bresolve | :bresolve}` ## {#bresolve} | |
| 363 | ||
| 364 | TODO | |
| 365 | ||
| 366 | ## `brule [ <label-exp> ] <term> => <term> .` ## {#brule} | |
| 367 | ||
| 368 | Synonym of 'btrans'. | |
| 369 | ||
| 370 | ||
| 371 | Related: [`btrans`](#btrans) | |
| 372 | ||
| 373 | ## `{bshow | :bshow} [tree]` ## {#bshow} | |
| 374 | ||
| 375 | TODO | |
| 405 | 376 | |
| 406 | 377 | ## `bsort` ## {#bsort} |
| 407 | 378 | |
| 415 | 386 | |
| 416 | 387 | Related: [`bctrans`](#bctrans), [`ctrans`](#ctrans), [`trans`](#trans) |
| 417 | 388 | |
| 418 | ## `cbred` ## {#cbred} | |
| 389 | ## `cbred [ in <mod-exp> :] <term> .` ## {#cbred} | |
| 419 | 390 | |
| 420 | 391 | |
| 421 | 392 | |
| 428 | 399 | |
| 429 | 400 | Related: [`ls`](#ls), [`pwd`](#pwd) |
| 430 | 401 | |
| 431 | ## `ceq [ <op-exp> ] <term> = <term> if <boolterm> .` ## {#ceq} | |
| 402 | ## `ceq [ <label-exp> ] <term> = <term> if <boolterm> .` ## {#ceq} | |
| 432 | 403 | |
| 433 | 404 | Defines a conditional equation. Spaces around the `if` are obligatory. |
| 434 | 405 | `<boolterm>` needs to be a Boolean term. For other requirements |
| 489 | 460 | |
| 490 | 461 | Related: [`strat` in operator attributes](#opattr), [`start`](#start), [`apply`](#apply) |
| 491 | 462 | |
| 492 | ## `clause` ## {#clause} | |
| 463 | ## CITP ## {#citp} | |
| 464 | ||
| 465 | Constructor Based Induction Theorem Prover | |
| 466 | ||
| 467 | The sub-system provides a certain level of automatization for theorem proving. | |
| 468 | ||
| 469 | TODO TODO | |
| 470 | ||
| 471 | ||
| 472 | Related: [`:define`](#citp-def), [`:ctf-`](#citp-ctf-), [`:ctf`](#citp-ctf), [`:csp-`](#citp-csp-), [`:csp`](#citp-csp), [`:red`](#citp-red), [`:select`](#citp-select), [`:backward`](#citp-backward), [`:rule`](#citp-rule), [`:equation`](#citp-equation), [`:cp`](#citp-cp), [`:init`](#citp-init), [`:roll`](#citp-roll), [`:auto`](#citp-auto), [`:ind`](#citp-ind), [`:apply`](#citp-apply), [`:goal`](#citp-goal) | |
| 473 | ||
| 474 | ## `clause <term> .` ## {#clause} | |
| 493 | 475 | |
| 494 | 476 | (pignose) |
| 495 | 477 | |
| 516 | 498 | |
| 517 | 499 | Related: [`open`](#open) |
| 518 | 500 | |
| 501 | ## `commands` ## {#help} | |
| 502 | ||
| 503 | Print outs the list of main toplevel commands. | |
| 504 | ||
| 505 | ||
| 519 | 506 | ## comments ## {#comments} |
| 520 | 507 | |
| 521 | 508 | The interpreter accepts the following strings as start of a comment |
| 537 | 524 | |
| 538 | 525 | |
| 539 | 526 | |
| 540 | ## `ctrans [ <label-exp> ] <term> => <term> .` ## {#ctrans} | |
| 527 | ## `:cp { "[" <label> "]" | "(" <sentense> . ")" } >< { "[" <label> "]" | "(" <sentence> .")" }` ## {#citp-cp} | |
| 528 | ||
| 529 | TODO specify critical pair | |
| 530 | ||
| 531 | Related: [`citp`](#citp) | |
| 532 | ||
| 533 | ## `crule [ <label-exp> ] <term> => <term> if <term> .` ## {#crule} | |
| 534 | ||
| 535 | Synonym of 'ctrans' | |
| 536 | ||
| 537 | ||
| 538 | Related: [`rule`](#rule), [`ctrans`](#ctrans) | |
| 539 | ||
| 540 | ## `:csp { eq [ <label-exp>] <term> = <term> . ...}` ## {#citp-csp} | |
| 541 | ||
| 542 | TODO applies case splitting after general equations TODO | |
| 543 | ||
| 544 | Related: [`:csp-`](#citp-csp-), [`citp`](#citp) | |
| 545 | ||
| 546 | ## `:csp- { eq [ <label-exp>] <term> = <term> . ...}` ## {#citp-csp-} | |
| 547 | ||
| 548 | TODO | |
| 549 | ||
| 550 | Related: [`:csp`](#citp-csp), [`citp`](#citp) | |
| 551 | ||
| 552 | ## `:ctf { eq [ <label-exp> ] <term> = <term> .}` ## {#citp-ctf} | |
| 553 | ||
| 554 | TODO Applies case splitting after a set of boolean expressions. | |
| 555 | ||
| 556 | Related: [`:ctf-`](#citp-ctf-), [`citp`](#citp) | |
| 557 | ||
| 558 | ## `:ctf- { eq [ <label-exp> ] <term> = <term> .}` ## {#citp-ctf-} | |
| 559 | ||
| 560 | TODO | |
| 561 | ||
| 562 | Related: [`:ctf`](#citp-ctf), [`citp`](#citp) | |
| 563 | ||
| 564 | ## `ctrans [ <label-exp> ] <term> => <term> if <term> .` ## {#ctrans} | |
| 541 | 565 | |
| 542 | 566 | Defines a conditional transition. For details see [`trans`](#trans) |
| 543 | 567 | and [`ceq`](#ceq). |
| 545 | 569 | |
| 546 | 570 | Related: [`bctrans`](#bctrans), [`btrans`](#btrans), [`trans`](#trans) |
| 547 | 571 | |
| 548 | ## `db` ## {#db} | |
| 572 | ## `db reset` ## {#db} | |
| 549 | 573 | |
| 550 | 574 | (pignose) |
| 551 | 575 | |
| 552 | 576 | |
| 553 | ## `dbpred` ## {#dbpred} | |
| 577 | ## `:def <symbol> = { <ctf> | <csp>}` ## {#citp-def} | |
| 578 | ||
| 579 | Assigns a name to a specific case splitting (`ctf` or `csp`), | |
| 580 | so that it can be used as tactics in `:apply`. | |
| 581 | ||
| 582 | Related: [`citp`](#citp) | |
| 583 | ||
| 584 | ### Example ### | |
| 585 | ||
| 586 | ````` | |
| 587 | :def name-1 = ctf [ <Term> . ] | |
| 588 | :def name-2 = ctf-{ eq LHS = RHS . } | |
| 589 | :def name-3 = csp { eq lhs1 = rhs1 . eq lhs2 = rhs2 . } | |
| 590 | :def name-4 = csp-{ eq lhs3 = rhs3 . eq lhs4 = rhs4 . } | |
| 591 | :apply(SI TC name-1 name-2 name-3 name-4) | |
| 592 | ````` | |
| 593 | ||
| 594 | ||
| 595 | ## `demod` ## {#demod} | |
| 554 | 596 | |
| 555 | 597 | (pignose) |
| 556 | 598 | |
| 557 | 599 | |
| 558 | ## `demod` ## {#demod} | |
| 559 | ||
| 560 | (pignose) | |
| 561 | ||
| 600 | ## `:describe <something>` ## {#citp-describe} | |
| 601 | ||
| 602 | Similar to the `:show` command but with more details. Call `:describe ?` for | |
| 603 | the possible set of invocations. | |
| 604 | ||
| 605 | ||
| 606 | Related: [`:show`](#citp-show), [`citp`](#citp) | |
| 562 | 607 | |
| 563 | 608 | ## `describe <something>` ## {#describe} |
| 564 | 609 | |
| 565 | Similar to the `show` command but with more details. See `describe ?` for | |
| 610 | Similar to the `show` command but with more details. Call `describe ?` for | |
| 566 | 611 | the possible set of invocations. |
| 567 | 612 | |
| 568 | 613 | |
| 571 | 616 | ## `dirs` ## {#dirs} |
| 572 | 617 | |
| 573 | 618 | |
| 574 | ||
| 575 | ||
| 576 | ## `dpred` ## {#dpred} | |
| 577 | ||
| 578 | (pignose) | |
| 579 | 619 | |
| 580 | 620 | |
| 581 | 621 | ## `dribble` ## {#dribble} |
| 590 | 630 | to be on a line by itself without leading spaces. |
| 591 | 631 | |
| 592 | 632 | |
| 593 | ## `eq [ <op-exp> ]: <term> = <term> .` ## {#eq} | |
| 633 | ## `eq [ <label-exp> ] <term> = <term> .` ## {#eq} | |
| 594 | 634 | |
| 595 | 635 | Declares an axiom, or equation. |
| 596 | 636 | |
| 601 | 641 | In simple words, the objects determined by the terms must be |
| 602 | 642 | interpretable as of the same sort. |
| 603 | 643 | |
| 604 | The optional part `<op-exp>` serves two purposes, one is to give | |
| 644 | The optional part `<label-exp>` serves two purposes, one is to give | |
| 605 | 645 | an axiom an identifier, and one is to modify its behavior. The |
| 606 | `<op-exp>` is of the form: | |
| 646 | `<label-exp>` is of the form: | |
| 607 | 647 | |
| 608 | 648 | ` [ <modifier> <label> ] : ` |
| 609 | 649 | |
| 641 | 681 | |
| 642 | 682 | Related: [`bceq`](#bceq), [`beq`](#beq), [`ceq`](#ceq) |
| 643 | 683 | |
| 684 | ## `:equation` ## {#citp-equation} | |
| 685 | ||
| 686 | TODO | |
| 687 | ||
| 688 | Related: [`citp`](#citp) | |
| 689 | ||
| 644 | 690 | ## `exec limit` switch ## {#switch-exec-limit} |
| 645 | 691 | |
| 646 | 692 | Possible values: integers, default limit 4611686018427387903. |
| 659 | 705 | |
| 660 | 706 | Related: [`reduce`](#reduce) |
| 661 | 707 | |
| 662 | ## `exec!` ## {#execute-dash} | |
| 708 | ## `exec! [ in <mod-exp> : ] <term> .` ## {#execute-dash} | |
| 663 | 709 | |
| 664 | 710 | |
| 665 | 711 | exec! [in <Modexpr> :] <Term> . |
| 695 | 741 | |
| 696 | 742 | |
| 697 | 743 | |
| 698 | ## `flag` ## {#flag} | |
| 744 | ## `flag(<name>, { on | off })` ## {#flag} | |
| 699 | 745 | |
| 700 | 746 | (pignose) |
| 701 | 747 | |
| 714 | 760 | and save it to `pathname`. |
| 715 | 761 | |
| 716 | 762 | |
| 717 | ## `goal` ## {#goal} | |
| 763 | ## `:goal { <sentence> . ... }` ## {#citp-goal} | |
| 764 | ||
| 765 | TODO | |
| 766 | ||
| 767 | ## `goal <term> .` ## {#goal} | |
| 718 | 768 | |
| 719 | 769 | (pignose) |
| 720 | 770 | |
| 757 | 807 | |
| 758 | 808 | Related: [module expression](#moduleexpression), [`using`](#using), [`protecting`](#protecting), [`extending`](#extending) |
| 759 | 809 | |
| 810 | ## `:ind on <variable> ... .` ## {#citp-ind} | |
| 811 | ||
| 812 | Defines the variable for the induction tactic of CITP. | |
| 813 | ||
| 814 | Related: [`citp`](#citp) | |
| 815 | ||
| 816 | ## `:init { "[" <label> "]" | "(" <sentence> "")} "{" <variable> <- <term>; ... "}"` ## {#citp-init} | |
| 817 | ||
| 818 | TODO | |
| 819 | ||
| 820 | Related: [`citp`](#citp) | |
| 821 | ||
| 760 | 822 | ## `input <pathname>` ## {#input} |
| 761 | 823 | |
| 762 | 824 | Requests the system to read the file specified by the |
| 765 | 827 | a line that only contains (the literal) `eof`. |
| 766 | 828 | |
| 767 | 829 | |
| 768 | ## `inspect` ## {#inspect} | |
| 769 | ||
| 770 | ||
| 830 | ## `inspect <term>` ## {#inspect} | |
| 831 | ||
| 832 | Inspect the internal structure of <term>. | |
| 771 | 833 | |
| 772 | 834 | |
| 773 | 835 | ## instantiation of parameterized modules ## {#instantiation} |
| 829 | 891 | |
| 830 | 892 | |
| 831 | 893 | |
| 894 | ## `:is` ## {#citp-is} | |
| 895 | ||
| 896 | Boolean expression: `A :is B` where `A` is a term and | |
| 897 | `B` is a sort. Returns true if `A` is of sort `B`. | |
| 898 | ||
| 899 | ||
| 832 | 900 | ## `let <identifier> = <term> .` ## {#let} |
| 833 | 901 | |
| 834 | 902 | Using `let` one can define aliases, or context variables. Bindings |
| 840 | 908 | be a fully parsable expression. |
| 841 | 909 | |
| 842 | 910 | |
| 843 | ## `lex` ## {#lex} | |
| 911 | ## `lex (<op>, ..., <op>)` ## {#lex} | |
| 844 | 912 | |
| 845 | 913 | (pignose) |
| 846 | 914 | |
| 881 | 949 | Evaluates the following quoted lisp expression. (TODO ???) |
| 882 | 950 | |
| 883 | 951 | |
| 884 | ## `list` ## {#list} | |
| 952 | ## `list { axiom | sos | usable | flag | param | option | demod }` ## {#list} | |
| 885 | 953 | |
| 886 | 954 | (pignose) |
| 887 | 955 | |
| 948 | 1016 | |
| 949 | 1017 | `module` introduces a module without specified semantic type. |
| 950 | 1018 | |
| 951 | If `params` are given, it is a parameterized module. See `parameterized module` | |
| 952 | for more details. | |
| 1019 | If `params` are given, it is a parameterized module. | |
| 1020 | See [`parameterized module`](#parameterizedmodule) for more details. | |
| 953 | 1021 | |
| 954 | 1022 | If `principal_sort_spec` is given, it has to be of the form |
| 955 | 1023 | `principal-sort <sortname>` (or `p-sort <sortname>`). The principal |
| 989 | 1057 | once, it is assumed to be shared. |
| 990 | 1058 | |
| 991 | 1059 | |
| 992 | ## `names` ## {#names} | |
| 993 | ||
| 994 | ||
| 995 | show | |
| 996 | ||
| 1060 | ## `names <mod-exp>` . ## {#names} | |
| 1061 | ||
| 1062 | List up all the named objects in module <mod-exp>. | |
| 1063 | ||
| 1064 | ||
| 1065 | ## `no autoload <module-name>` ## {#no-autoload} | |
| 1066 | ||
| 1067 | Stop `autoload` of module with the name <module-name> . | |
| 1068 | Please refer to `autoload` command. | |
| 1069 | ||
| 1070 | ||
| 1071 | Related: [`autoload`](#autoload) | |
| 1072 | ||
| 1073 | ## `:normalize { on | off}` ## {#citp-normalize} | |
| 1074 | ||
| 1075 | Normalize the LHS of an instance of the axiom generated by :init command. | |
| 1076 | ||
| 1077 | Related: [`citp`](#citp) | |
| 997 | 1078 | |
| 998 | 1079 | ## on-the-fly declarations ## {#onthefly} |
| 999 | 1080 | |
| 1162 | 1243 | |
| 1163 | 1244 | Related: [operator attributes](#opattr) |
| 1164 | 1245 | |
| 1165 | ## `option` ## {#option} | |
| 1246 | ## `option { reset | = <name> }` ## {#option} | |
| 1166 | 1247 | |
| 1167 | 1248 | (pignose) |
| 1168 | 1249 | |
| 1169 | 1250 | |
| 1170 | ## `param` ## {#param} | |
| 1251 | ## `param(<name>, <value>)` ## {#param} | |
| 1171 | 1252 | |
| 1172 | 1253 | (pignose) |
| 1173 | 1254 | |
| 1272 | 1353 | ## `protecting ( <modexp> )` ## {#protecting} |
| 1273 | 1354 | |
| 1274 | 1355 | Imports the object specified by `modexp` into the current |
| 1275 | module, preserving all intended models as they are. See `module expression` | |
| 1276 | for format of `modexp`. | |
| 1356 | module, preserving all intended models as they are. | |
| 1357 | See [`module expression`](#moduleexpression) for format of `modexp`. | |
| 1277 | 1358 | |
| 1278 | 1359 | |
| 1279 | 1360 | Related: [`including`](#including), [`using`](#using), [`extending`](#extending) |
| 1287 | 1368 | |
| 1288 | 1369 | Related: [`require`](#require) |
| 1289 | 1370 | |
| 1290 | ## `pushd` ## {#pushd} | |
| 1291 | ||
| 1292 | ||
| 1293 | ||
| 1294 | ||
| 1295 | ## `pvar` ## {#pvar} | |
| 1371 | ## `pushd <directory>` ## {#pushd} | |
| 1372 | ||
| 1373 | ||
| 1374 | ||
| 1375 | ||
| 1376 | ## `pvar <var-name> : <sort-name>` ## {#pvar} | |
| 1296 | 1377 | |
| 1297 | 1378 | (pignose) |
| 1298 | 1379 | |
| 1380 | ||
| 1381 | Related: [`vars`](#var), [`var`](#var) | |
| 1299 | 1382 | |
| 1300 | 1383 | ## `pwd` ## {#pwd} |
| 1301 | 1384 | |
| 1337 | 1420 | |
| 1338 | 1421 | ### Example ### |
| 1339 | 1422 | |
| 1340 | `1:NzNat` `2:Nat` | |
| 1423 | `(1):NzNat` `(2):Nat` | |
| 1341 | 1424 | |
| 1342 | 1425 | ## `quiet` switch ## {#switch-quiet} |
| 1343 | 1426 | |
| 1352 | 1435 | |
| 1353 | 1436 | Leaves the CafeOBJ interpreter. |
| 1354 | 1437 | |
| 1438 | ||
| 1439 | ## `{ :red | :exec | :bred } [in <goal-name> :] <term> .` ## {#citp-red} | |
| 1440 | ||
| 1441 | reduce the term in specified goal <goal-name>. | |
| 1442 | ||
| 1443 | Related: [`citp`](#citp) | |
| 1355 | 1444 | |
| 1356 | 1445 | ## `reduce [ in <mod-exp> : ] <term> .` ## {#reduce} |
| 1357 | 1446 | |
| 1409 | 1498 | |
| 1410 | 1499 | Related: [`full reset`](#fullreset) |
| 1411 | 1500 | |
| 1412 | ## `resolve` ## {#resolve} | |
| 1501 | ## `resolve {. | <file-path> }` ## {#resolve} | |
| 1413 | 1502 | |
| 1414 | 1503 | (pignose) |
| 1415 | 1504 | |
| 1435 | 1524 | |
| 1436 | 1525 | Related: [`step switch`](#switch-step) |
| 1437 | 1526 | |
| 1438 | ## `rl` ## {#rl} | |
| 1439 | ||
| 1440 | ||
| 1441 | ||
| 1442 | ||
| 1443 | ## `rule` ## {#rule} | |
| 1444 | ||
| 1445 | ||
| 1446 | ||
| 1527 | ## `:roll back` ## {#citp-roll} | |
| 1528 | ||
| 1529 | TODO | |
| 1530 | ||
| 1531 | Related: [`citp`](#citp) | |
| 1532 | ||
| 1533 | ## `:rule` ## {#citp-rule} | |
| 1534 | ||
| 1535 | TODO | |
| 1536 | ||
| 1537 | Related: [`citp`](#citp) | |
| 1538 | ||
| 1539 | ## `rule [ <label-exp> ] <term> => <term> .` ## {#rule} | |
| 1540 | ||
| 1541 | Synonym of 'trans'. | |
| 1542 | ||
| 1543 | ||
| 1544 | Related: [`trans`](#trans) | |
| 1447 | 1545 | |
| 1448 | 1546 | ## `save <pathname>` ## {#save} |
| 1449 | 1547 | |
| 1456 | 1554 | |
| 1457 | 1555 | Related: [`save-system`](#save-system), [`restore`](#restore), [`input`](#input) |
| 1458 | 1556 | |
| 1459 | ## `save-option` ## {#save-option} | |
| 1557 | ## `save-option <name>` ## {#save-option} | |
| 1460 | 1558 | |
| 1461 | 1559 | (pignose) |
| 1462 | 1560 | |
| 1470 | 1568 | |
| 1471 | 1569 | Related: [`restore`](#restore), [`save`](#save), [`input`](#input) |
| 1472 | 1570 | |
| 1473 | ## `scase` ## {#scase} | |
| 1571 | ## `scase (<term>) in (<mod-exp>) as <name> { <decl> ..} : <term> .` ## {#scase} | |
| 1474 | 1572 | |
| 1475 | 1573 | |
| 1476 | 1574 | |
| 1518 | 1616 | `S =(n,m)=>* SS [if Pred1] suchThat Pred2 withStateEq Pred3` |
| 1519 | 1617 | |
| 1520 | 1618 | |
| 1619 | ## `:select <goal-name>` ## {#citp-select} | |
| 1620 | ||
| 1621 | Select a goal for further application of tactics. | |
| 1622 | ||
| 1623 | Related: [`citp`](#citp) | |
| 1624 | ||
| 1521 | 1625 | ## `select <mod_exp> . ` ## {#select} |
| 1522 | 1626 | |
| 1523 | 1627 | Selects a module given by the module expression `<mod_exp>` as the |
| 1528 | 1632 | |
| 1529 | 1633 | Related: [`module expression`](#moduleexpression), [`open`](#open) |
| 1530 | 1634 | |
| 1635 | ## `:set(<name>, { on | off | show })` ## {#citp-set} | |
| 1636 | ||
| 1637 | Set or show various flags of CITP CafeOBJ. | |
| 1638 | ||
| 1639 | ||
| 1531 | 1640 | ## `set <name> [option] <value>` ## {#set} |
| 1532 | 1641 | |
| 1533 | 1642 | Depending on the type of the switch, options and value specification varies. |
| 1541 | 1650 | |
| 1542 | 1651 | Related: [`switches`](#switches), [`show`](#show) |
| 1543 | 1652 | |
| 1653 | ## `:show <something>` ## {#citp-show} | |
| 1654 | ||
| 1655 | TODO | |
| 1656 | ||
| 1657 | Related: [`:describe`](#citp-describe), [`citp`](#citp) | |
| 1658 | ||
| 1544 | 1659 | ## `show <something>` ## {#show} |
| 1545 | 1660 | |
| 1546 | 1661 | The `show` command provides various ways to inspect all kind of objects |
| 1550 | 1665 | the `show` command are: |
| 1551 | 1666 | |
| 1552 | 1667 | - `show [ <modexp> ]` - describes the current modules of the one specified |
| 1553 | as argument | |
| 1668 | as argument | |
| 1554 | 1669 | - `show module tree [ <modexp> ]` - displays submodules of <modexp> in tree format |
| 1555 | 1670 | - `show switches` - lists all possible switches |
| 1556 | 1671 | - `show term [ tree ]` - displays a term, possible in tree format |
| 1557 | 1672 | |
| 1558 | See the entry for `switches` for a full list. | |
| 1673 | See the entry for [`switches`](#switches) for a full list. | |
| 1559 | 1674 | |
| 1560 | 1675 | |
| 1561 | 1676 | Related: [`describe`](#describe), [`switches`](#switches) |
| 1567 | 1682 | TODO no further information on what this changes |
| 1568 | 1683 | |
| 1569 | 1684 | |
| 1570 | ## `sigmatch` ## {#sigmatch} | |
| 1685 | ## `sigmatch (<mod-exp>) to (<mod-exp>)` ## {#sigmatch} | |
| 1571 | 1686 | |
| 1572 | 1687 | (pignose) |
| 1573 | 1688 | |
| 1615 | 1730 | `C < A`, `D < A`, `A < E`, `B < D`. |
| 1616 | 1731 | |
| 1617 | 1732 | |
| 1618 | ## `sos` ## {#sos} | |
| 1733 | ## `sos { = | + | - } { <clause> , ... }` ## {#sos} | |
| 1619 | 1734 | |
| 1620 | 1735 | (pignose) |
| 1621 | 1736 | |
| 1737 | ||
| 1738 | ## `:spoiler { on | off}` ## {#citp-spoiler} | |
| 1739 | ||
| 1740 | TODO | |
| 1741 | ||
| 1742 | Related: [`citp`](#citp) | |
| 1622 | 1743 | |
| 1623 | 1744 | ## `start <term> .` ## {#start} |
| 1624 | 1745 | |
| 1762 | 1883 | |
| 1763 | 1884 | Imports the object specified by `modexp` into the current |
| 1764 | 1885 | module without any restrictions on the models. |
| 1765 | See `module expression` for format of `modexp`. | |
| 1886 | See [`module expression`](#moduleexpression) for format of `modexp`. | |
| 1766 | 1887 | |
| 1767 | 1888 | |
| 1768 | 1889 | Related: [`protecting`](#protecting), [`including`](#including), [`extending`](#extending) |
| 1779 | 1900 | |
| 1780 | 1901 | |
| 1781 | 1902 | Related: [`on-the-fly`](#onthefly), [`qualified term`](#qualified), [`op`](#op) |
| 1903 | ||
| 1904 | ## `:verbose { on | off }` ## {#citp-verbose} | |
| 1905 | ||
| 1906 | Turns on verbose reporting of the CITP subsystem. | |
| 1907 | ||
| 1908 | Related: [`citp`](#citp) | |
| 1782 | 1909 | |
| 1783 | 1910 | ## `verbose` switch ## {#switch-verbose} |
| 1784 | 1911 | |
| 0 | ev (load "../../cafeobj/oldoc.lisp") | |
| 0 | 1 | ev (load "../../cafeobj/commands.lisp") |
| 1 | 2 | gendoc reference.md |
| 2 | 3 | quit |
| 47 | 47 | ;;; cafeobj-mode invoked, when visiting .mod files (assuming this file is |
| 48 | 48 | ;;; in your load-path): |
| 49 | 49 | ;;; |
| 50 | ;;; (autoload 'cafeobj-mode "cafeobj-mode" "CafeOBJ mode." t) | |
| 51 | ;;; (setq auto-mode-alist | |
| 52 | ;;; (cons '("\\.mod$" . cafeobj-mode) auto-mode-alist)) | |
| 50 | ;;; (autoload 'cafeobj-mode "cafeobj-mode" "CafeOBJ mode." t) | |
| 51 | ;;; (setq auto-mode-alist | |
| 52 | ;;; (cons '("\\.mod$" . cafeobj-mode) auto-mode-alist)) | |
| 53 | 53 | ;;; |
| 54 | 54 | ;;; and, also the following is handy for running CafeOBJ interpreter: |
| 55 | 55 | ;;; |
| 78 | 78 | ;;; prefix for major-mode commands. |
| 79 | 79 | ;;; You can customise the keybindings either by setting `choas-prefix-key' |
| 80 | 80 | ;;; or by putting the following in your .emacs |
| 81 | ;;; (setq cafeobj-mode-map (make-sparse-keymap)) | |
| 81 | ;;; (setq cafeobj-mode-map (make-sparse-keymap)) | |
| 82 | 82 | ;;; and |
| 83 | ;;; (define-key cafeobj-mode-map <your-key> <function>) | |
| 83 | ;;; (define-key cafeobj-mode-map <your-key> <function>) | |
| 84 | 84 | ;;; for all the functions you need. |
| 85 | 85 | ;;; |
| 86 | ;;; ABBRIVE-MODE: | |
| 86 | ;;; ABBREV-MODE: | |
| 87 | 87 | ;;; CafeOBJ mode provides a mode-specific abbrev table 'cafeobj-mode-abbrev-table', |
| 88 | 88 | ;;; and there defined some abbriviations already. |
| 89 | 89 | ;;; You can use abbrev by `M-x abbrev-mode' or putting the following in your |
| 97 | 97 | ;;; To edit the entire table, `M-x edit-abbrevs' and `M-x write-abbrev-file' |
| 98 | 98 | ;;; are handy. Here is an example of adding some extra abbreviations: |
| 99 | 99 | ;;; I want the following abbreviations: |
| 100 | ;;; "mod" -> "module" | |
| 100 | ;;; "mod" -> "module" | |
| 101 | 101 | ;;; "mod*" -> "module*" |
| 102 | 102 | ;;; "mod!" -> "module!" |
| 103 | ;;; "obj" -> "module!" | |
| 104 | ;;; "th" -> "module*" | |
| 103 | ;;; "obj" -> "module!" | |
| 104 | ;;; "th" -> "module*" | |
| 105 | 105 | ;;; For this, we can use `M-x edit-abbrevs' and adds the above definitions in |
| 106 | 106 | ;;; cafeobj-abbrev-table like this: |
| 107 | 107 | ;;; |
| 108 | 108 | ;;; (cafeobj-mode-abbrev-table) |
| 109 | 109 | ;;; |
| 110 | ;;; "mod" 0 "module" | |
| 111 | ;;; "m*" 0 "module* " | |
| 110 | ;;; "mod" 0 "module" | |
| 111 | ;;; "m*" 0 "module* " | |
| 112 | 112 | ;;; "m!" 0 "module! " |
| 113 | 113 | ;;; "obj" 0 "module!" |
| 114 | 114 | ;;; "th" 0 "module*" |
| 117 | 117 | ;;; : |
| 118 | 118 | ;;; After editting, type `C-c C-c'(M-x edit-abbrevs-redefine) to install |
| 119 | 119 | ;;; abbrev definitions as specified. |
| 120 | ;;; Then use `M-x write-abbrev-file' specifying ~/.abbrev_deffs to | |
| 120 | ;;; Then use `M-x write-abbrev-file' specifying ~/.abbrev_defs to | |
| 121 | 121 | ;;; the target file name, and adds a line in my .emacs |
| 122 | 122 | ;;; (read-abbrev-file "~/.abbrev_defs"). |
| 123 | 123 | ;;; See Emacs manual of Infos for detail. |
| 126 | 126 | ;;; You may want to customize the following variables, see the comment strings |
| 127 | 127 | ;;; for the descriptions of these variables. |
| 128 | 128 | ;;; |
| 129 | ;;; cafeobj-always-show | |
| 130 | ;;; cafeobj-mode-map | |
| 131 | ;;; cafeobj-prefix-key | |
| 132 | ;;; cafeobj-mode-hook | |
| 133 | ;;; cafeobj-default-application | |
| 134 | ;;; cafeobj-default-command-switches | |
| 129 | ;;; cafeobj-always-show | |
| 130 | ;;; cafeobj-mode-map | |
| 131 | ;;; cafeobj-prefix-key | |
| 132 | ;;; cafeobj-mode-hook | |
| 133 | ;;; cafeobj-default-application | |
| 134 | ;;; cafeobj-default-command-switches | |
| 135 | 135 | ;;; cafeobj-decl-keyword-face |
| 136 | 136 | ;;; cafeobj-keyword-face |
| 137 | 137 | ;;; cafeobj-command-face |
| 149 | 149 | (require 'comint) |
| 150 | 150 | (require 'custom) |
| 151 | 151 | (require 'font-lock) |
| 152 | (require 'abbrev) | |
| 153 | (require 'imenu) | |
| 152 | 154 | |
| 153 | 155 | (defgroup cafeobj nil |
| 154 | 156 | "CafeOBJ code editting." |
| 186 | 188 | "Command switches for `cafeobj-default-application'. |
| 187 | 189 | Should be a list of strings which will be given to the cafeobj process when star up." |
| 188 | 190 | :group 'cafeobj) |
| 191 | ||
| 192 | ;;; simple imenu support | |
| 193 | (defcustom cafeobj-imenu-generic-expression-alist | |
| 194 | '(("Modules" "^mod.* \\(\\w+\\b\\)" 1) | |
| 195 | ("Vars" "var.* \\(\\w+\\b\\):" 1) | |
| 196 | ) | |
| 197 | "Alist of regular expressions for the imode index. | |
| 198 | Each element form (submenu-name regexp index). | |
| 199 | Where submenu-name is the name of the submenu under which | |
| 200 | items matching regexp are placed. When submenu-name is nil | |
| 201 | the matching entries appear in the root imenu list. | |
| 202 | Regexp idex indicates which regexp text group defines the | |
| 203 | text entry. When the index is 0 the entire :text that matches | |
| 204 | regexp appers." | |
| 205 | :type '(repeat (list (choice :tag "Submenu Name" string (const nil)) | |
| 206 | regexp (integer :tag "Regexp index"))) | |
| 207 | :group 'cafeobj | |
| 208 | ) | |
| 209 | ||
| 210 | (add-hook 'cafeobj-mode-hook | |
| 211 | (lambda () | |
| 212 | (setq imenu-generic-expression cafeobj-imenu-generic-expression-alist))) | |
| 189 | 213 | |
| 190 | 214 | ;;; FACES for CafeOBJ/CafeOBJ-Process |
| 191 | 215 | |
| 205 | 229 | :group 'cafeobj-faces) |
| 206 | 230 | |
| 207 | 231 | (defface cafeobj-comment-face-2 |
| 208 | '((((class color) (background dark)) (:foreground "gray80")) | |
| 232 | '((((class color) (background dark)) (:foreground "honeydew3")) | |
| 209 | 233 | (((class color) (background light)) (:foreground "blue4")) |
| 210 | 234 | (((class grayscale) (background light)) |
| 211 | 235 | (:foreground "DimGray" :bold t :italic t)) |
| 352 | 376 | (defmacro cafeobj-define-key (fsf-key definition &optional xemacs-key) |
| 353 | 377 | `(define-key cafeobj-mode-map |
| 354 | 378 | ,(if xemacs-key |
| 355 | `(if cafeobj-xemacs-p ,xemacs-key ,fsf-key) | |
| 356 | fsf-key) | |
| 379 | `(if cafeobj-xemacs-p ,xemacs-key ,fsf-key) | |
| 380 | fsf-key) | |
| 357 | 381 | ,definition)) |
| 358 | 382 | |
| 359 | 383 | (defvar del-back-ch (car (append (where-is-internal 'delete-backward-char) |
| 360 | (where-is-internal 'backward-delete-char-untabify))) | |
| 384 | (where-is-internal 'backward-delete-char-untabify))) | |
| 361 | 385 | "Character generated by key bound to delete-backward-char.") |
| 362 | 386 | |
| 363 | 387 | (and (vectorp del-back-ch) (= (length del-back-ch) 1) |
| 451 | 475 | ;; (concat "^[ \t]*" (regexp-opt cafeobj-keywords-2 t t) "\\>") |
| 452 | 476 | (concat "^[ \t]*" (regexp-opt cafeobj-keywords-2 ) "\\>") |
| 453 | 477 | (concat "^[ \t]*\\(" |
| 454 | (regexp-opt cafeobj-keywords-2) | |
| 455 | "\\)\\>"))) | |
| 478 | (regexp-opt cafeobj-keywords-2) | |
| 479 | "\\)\\>"))) | |
| 456 | 480 | |
| 457 | 481 | |
| 458 | 482 | (defconst cafeobj-keyword-pat-3 |
| 510 | 534 | "require" |
| 511 | 535 | "provide" |
| 512 | 536 | "resolve" |
| 537 | "full" | |
| 538 | "reset" | |
| 513 | 539 | "option" |
| 514 | 540 | "db" |
| 515 | 541 | "sos" |
| 522 | 548 | "lex" |
| 523 | 549 | "name" |
| 524 | 550 | "names" |
| 551 | "look" | |
| 525 | 552 | "inspect" |
| 526 | 553 | "inspect-term" |
| 554 | ":goal" | |
| 555 | ":apply" | |
| 556 | ":auto" | |
| 557 | ":ind" | |
| 558 | ":init" | |
| 559 | ":cp" | |
| 560 | ":ctf" | |
| 561 | ":csp" | |
| 562 | ":show" | |
| 563 | ":describe" | |
| 564 | ":verbose" | |
| 565 | ":backward" | |
| 566 | ":equation" | |
| 567 | ":rule" | |
| 568 | ":select" | |
| 527 | 569 | ) |
| 528 | 570 | "CafeOBJ top-level commands") |
| 529 | 571 | |
| 543 | 585 | |
| 544 | 586 | (defconst cafeobj-top-key-pat |
| 545 | 587 | (concat "^\\<\\(" |
| 546 | (regexp-opt cafeobj-top-keywords) | |
| 547 | "\\)\\>")) | |
| 548 | ||
| 549 | ;(defconst cafeobj-top-decl-pat | |
| 550 | ; (concat "^[ \t]*\\(?:" | |
| 551 | ; "module\\*\\|mod\\*\\|" | |
| 552 | ; (regexp-opt '("module" "mod" "module!" "mod!" "view")) | |
| 553 | ; "\\>\\)")) | |
| 588 | (regexp-opt cafeobj-top-keywords) | |
| 589 | "\\)\\>")) | |
| 554 | 590 | |
| 555 | 591 | (defconst cafeobj-top-decl-pat |
| 556 | 592 | (concat "^[ \t]*\\(" |
| 557 | "module\\|module\\*\\|mod\\*\\|module\\|mod\\|module!\\|mod!\\|view\\|hwd:mod!\\|sys:mod!" | |
| 558 | "\\)\\>")) | |
| 593 | "module\\|module\\*\\|mod\\*\\|module\\|mod\\|module!\\|mod!\\|view\\|hwd:mod!\\|sys:mod!" | |
| 594 | "\\)\\>")) | |
| 559 | 595 | |
| 560 | 596 | (defun looking-at-cafeobj-top-decl () |
| 561 | (looking-at cafeobj-top-decl-pat) | |
| 562 | ) | |
| 597 | (looking-at cafeobj-top-decl-pat)) | |
| 563 | 598 | |
| 564 | 599 | (defconst cafeobj-block-start-pat |
| 565 | 600 | (concat "[ \t]*" |
| 566 | (regexp-opt '("signature" "axioms" "imports" "record" "class") | |
| 567 | t) | |
| 568 | "\\>")) | |
| 601 | (regexp-opt '("signature" "axioms" "imports" "record" "class") | |
| 602 | t) | |
| 603 | "\\>")) | |
| 569 | 604 | |
| 570 | 605 | (defun looking-at-cafeobj-block-start-pat () |
| 571 | 606 | (looking-at cafeobj-block-start-pat)) |
| 572 | 607 | |
| 573 | 608 | (defun looking-at-cafeobj-module-decl () |
| 574 | 609 | (looking-at (concat "^\\<\\(" |
| 575 | (regexp-opt '("module" "mod" "module*" "mod*" | |
| 576 | "module!" "mod!")) | |
| 577 | "\\)\\>"))) | |
| 610 | (regexp-opt '("module" "mod" "module*" "mod*" | |
| 611 | "module!" "mod!")) | |
| 612 | "\\)\\>"))) | |
| 578 | 613 | |
| 579 | 614 | (defun looking-at-cafeobj-view-decl () |
| 580 | 615 | (looking-at "^\\<view\\>")) |
| 621 | 656 | |
| 622 | 657 | (cond (cafeobj-xemacs-p |
| 623 | 658 | (setq cafeobj-mode-popup-menu |
| 624 | (purecopy '("CafeOBJ Interaction Menu" | |
| 625 | ["Evaluate This Declaration" | |
| 626 | cafeobj-send-decl t] | |
| 627 | ["Evaluate Current Line" cafeobj-send-line t] | |
| 628 | ["Evaluate Entire Buffer" cafeobj-send-buffer t] | |
| 629 | ["Evaluate Region" cafeobj-send-region | |
| 630 | (region-exists-p)] | |
| 631 | "---" | |
| 632 | ["Comment Out Region" comment-region (region-exists-p)] | |
| 633 | ["Indent Region" indent-region (region-exists-p)] | |
| 634 | ["Indent Line" cafeobj-indent-line t] | |
| 635 | ["Beginning of Declaration" | |
| 636 | cafeobj-beginning-of-decl t] | |
| 637 | ))) | |
| 659 | (purecopy '("CafeOBJ Interaction Menu" | |
| 660 | ["Evaluate This Declaration" | |
| 661 | cafeobj-send-decl t] | |
| 662 | ["Evaluate Current Line" cafeobj-send-line t] | |
| 663 | ["Evaluate Entire Buffer" cafeobj-send-buffer t] | |
| 664 | ["Evaluate Region" cafeobj-send-region | |
| 665 | (region-exists-p)] | |
| 666 | "---" | |
| 667 | ["Comment Out Region" comment-region (region-exists-p)] | |
| 668 | ["Indent Region" indent-region (region-exists-p)] | |
| 669 | ["Indent Line" cafeobj-indent-line t] | |
| 670 | ["Beginning of Declaration" | |
| 671 | cafeobj-beginning-of-decl t] | |
| 672 | ))) | |
| 638 | 673 | (setq cafeobj-mode-menubar-menu |
| 639 | (purecopy (cons "CafeOBJ" (cdr cafeobj-mode-popup-menu))))) | |
| 674 | (purecopy (cons "CafeOBJ" (cdr cafeobj-mode-popup-menu))))) | |
| 640 | 675 | (t ;; |
| 641 | 676 | (setq cafeobj-mode-menu (make-sparse-keymap "CafeOBJ")) |
| 642 | (define-key cafeobj-mode-menu [choas-send-line] | |
| 643 | '("Evaluate Current Line" . cafeobj-send-current-line)) | |
| 677 | (define-key cafeobj-mode-menu [cafeobj-send-line] | |
| 678 | '("Evaluate Current Line" . cafeobj-send-line)) | |
| 644 | 679 | (define-key cafeobj-mode-menu [cafeobj-send-region] |
| 645 | '("Evaluate Cafeobj-Region" . cafeobj-send-region)) | |
| 680 | '("Evaluate Cafeobj-Region" . cafeobj-send-region)) | |
| 646 | 681 | (define-key cafeobj-mode-menu [cafeobj-send-proc] |
| 647 | '("Evaluate This Declaration" . cafeobj-send-decl)) | |
| 682 | '("Evaluate This Declaration" . cafeobj-send-decl)) | |
| 648 | 683 | (define-key cafeobj-mode-menu [cafeobj-send-buffer] |
| 649 | '("Send Buffer" . cafeobj-send-buffer)) | |
| 684 | '("Send Buffer" . cafeobj-send-buffer)) | |
| 650 | 685 | (define-key cafeobj-mode-menu [cafeobj-beginning-of-decl] |
| 651 | '("Beginning Of Proc" . cafeobj-beginning-of-decl)) | |
| 686 | '("Beginning Of Proc" . cafeobj-beginning-of-decl)) | |
| 652 | 687 | (define-key cafeobj-mode-menu [comment-region] |
| 653 | '("Comment Out Region" . comment-region)) | |
| 688 | '("Comment Out Region" . comment-region)) | |
| 654 | 689 | (define-key cafeobj-mode-menu [indent-region] |
| 655 | '("Indent Region" . indent-region)) | |
| 690 | '("Indent Region" . indent-region)) | |
| 656 | 691 | (define-key cafeobj-mode-menu [cafeobj-indent-line] |
| 657 | '("Indent Line" . cafeobj-indent-line)) | |
| 692 | '("Indent Line" . cafeobj-indent-line)) | |
| 658 | 693 | (define-key cafeobj-mode-menu [cafeobj-beginning-of-decl] |
| 659 | '("Beginning of Declaration" . cafeobj-beginning-of-decl)) | |
| 694 | '("Beginning of Declaration" . cafeobj-beginning-of-decl)) | |
| 660 | 695 | )) |
| 661 | 696 | |
| 662 | 697 | ;;; ------------ |
| 665 | 700 | |
| 666 | 701 | (defvar cafeobj-mode-abbrev-table nil |
| 667 | 702 | "Abbrev table in use in CafeOBJ mode.") |
| 703 | ||
| 704 | ;;; se use extended abbriv | |
| 705 | (autoload 'expand-abbrev-hook "expand") | |
| 706 | ||
| 668 | 707 | ;;; some default abbreviations define here |
| 669 | 708 | (if cafeobj-mode-abbrev-table |
| 670 | 709 | nil |
| 671 | (define-abbrev-table 'cafeobj-mode-abbrev-table | |
| 672 | '(("btrns" "btrans" nil 0) | |
| 673 | ("bcq" "bceq" nil 0) | |
| 674 | ("compat" "compatibility" nil 0) | |
| 675 | ("psort" "principal-sort" nil 0) | |
| 676 | ("req" "require" nil 0) | |
| 677 | ("sh" "show" nil 0) | |
| 678 | ("verb" "verbose" nil 0) | |
| 679 | ("reg" "regularize" nil 0) | |
| 680 | ("import" "imports" nil 0) | |
| 681 | ("cq" "ceq" nil 0) | |
| 682 | ("red" "reduce" nil 0) | |
| 683 | ("strat" "strategy" nil 0) | |
| 684 | ("us" "using" nil 0) | |
| 685 | ("btrn" "btrans" nil 0) | |
| 686 | ("btr" "btrans" nil 0) | |
| 687 | ("reconst" "reconstruct" nil 0) | |
| 688 | ("chk" "check" nil 0) | |
| 689 | ("trns" "trans" nil 0) | |
| 690 | ("swit" "swithces" nil 0) | |
| 691 | ("bq" "beq" nil 0) | |
| 692 | ("desc" "describe" nil 0) | |
| 693 | ("bctr" "bctrans" nil 0) | |
| 694 | ("incl" "include" nil 0) | |
| 695 | ("bctrn" "bctrans" nil 0) | |
| 696 | ("ex" "extending" nil 0) | |
| 697 | ;; ("axs" "axioms" nil 0) | |
| 698 | ("pr" "protecting" nil 0) | |
| 699 | ("bctrns" "bctrans" nil 0) | |
| 700 | ("pat" "pattern" nil 0) | |
| 701 | ("recon" "reconstruct" nil 0) | |
| 702 | ("prov" "provide" nil 0) | |
| 703 | ("sel" "select" nil 0) | |
| 704 | ("sig" "signature" nil 0) | |
| 705 | ("sign" "signature" nil 1) | |
| 706 | ("cond" "conditions" nil 0) | |
| 707 | ("imp" "imports" nil 0) | |
| 708 | ("comp" "compatibility" nil 0) | |
| 709 | ("swi" "switch" nil 0) | |
| 710 | ("reconstr" "reconstruct" nil 0) | |
| 711 | )) | |
| 712 | ) | |
| 710 | (define-abbrev-table 'cafeobj-mode-abbrev-table | |
| 711 | '(;; top level declaration | |
| 712 | ("mod" ["module {\n\n}\n" 5 () nil] expand-abbrev-hook 0) | |
| 713 | ("pmod" ["module () {\n\n}\n" 8 () nil] expand-abbrev-hook 0) | |
| 714 | ("vw" ["view {\n\n}\n" 5 () nil] expand-abbrev-hook 0) | |
| 715 | ("mk" ["make ()" 3 () nil] expand-abbrev-hook 0) | |
| 716 | ;; module constructs | |
| 717 | ("ps" "pricipal-sort" nil 0) | |
| 718 | ;; imports | |
| 719 | ("imp" ["imports {\n\n}\n" 3 () nil] expand-abbrev-hook 0) | |
| 720 | ("pr" ["protecting()" 1 () nil] expand-abbrev-hook 0) | |
| 721 | ("pa" ["protecting as ()" 3 () nil] expand-abbrev-hook 0) | |
| 722 | ("ex" ["extending()" 1 () nil] expand-abbrev-hook 0) | |
| 723 | ("ea" ["extending as ()" 2 () nil] expand-abbrev-hook 0) | |
| 724 | ("us" ["using()" 1 () nil] expand-abbrev-hook 0) | |
| 725 | ("ua" ["using as ()" 2 () nil] expand-abbrev-hook 0) | |
| 726 | ("inc" ["including()" 1 () nil] expand-abbrev-hook 0) | |
| 727 | ("ias" ["including as ()" 2 () nil] expand-abbrev-hook 0) | |
| 728 | ;; signature | |
| 729 | ("sig" ["signature {\n\n}\n" 3 () nil] expand-abbrev-hook 0) | |
| 730 | ;; sort declarations | |
| 731 | ("[" ["[]" 1 () nil] expand-abbrev-hook 0) | |
| 732 | ("*[" ["*[]*" 2 () nil] expand-abbrev-hook 0) | |
| 733 | ;; operator declaration | |
| 734 | ("ope" ["op : -> ." 10 () nil] expand-abbrev-hook 0) | |
| 735 | ("opt" ["op : -> {} ." 12 () nil] expand-abbrev-hook 0) | |
| 736 | ("ops" ["ops : -> ." 9 () nil] expand-abbrev-hook 0) | |
| 737 | ("pred" ["pred : ." 4 () nil] expand-abbrev-hook 0) | |
| 738 | ;; operator attributes | |
| 739 | ("str" ["strat: ()" 1 () nil] expand-abbrev-hook 0) | |
| 740 | ("ctr" "ctor" nil 0) | |
| 741 | ("ra" "r-assoc" nil 0) | |
| 742 | ("la" "l-assoc" nil 0) | |
| 743 | ("pre" "prec:" nil 0) | |
| 744 | ("ass" "assoc" nil 0) | |
| 745 | ("com" "comm" nil 0) | |
| 746 | ;; axiom | |
| 747 | ("axi" ["axioms {\n\n}\n" 3 () nil] expand-abbrev-hook 0) | |
| 748 | ("bt" ["btrans => ." 7 () nil] expand-abbrev-hook 0) | |
| 749 | ("bct"["bctrans => if ." 10 () nil] expand-abbrev-hook 0) | |
| 750 | ("ctr" ["ctrans => if ." 10 () nil] expand-abbrev-hook 0) | |
| 751 | ("tr" ["trans => ." 7 () nil] expand-abbrev-hook 0) | |
| 752 | ("eq" ["eq = ." 7 () nil] expand-abbrev-hook 0) | |
| 753 | ("cq" ["ceq = if ." 10 () nil] expand-abbrev-hook 0) | |
| 754 | ("bq" ["beq = ." 7 () nil] expand-abbrev-hook 0) | |
| 755 | ("bcq" ["bceq = if ." 10 () nil] expand-abbrev-hook 0) | |
| 756 | ("var" ["var : " 3 () nil] expand-abbrev-hook 0) | |
| 757 | ("vars" ["vars : " 3 () nil] expand-abbrev-hook 0) | |
| 758 | ;; commands | |
| 759 | ("ch" "check" nil 0) | |
| 760 | ("comp" "compatibility " nil 0) | |
| 761 | ("reg" "regularity " nil 0) | |
| 762 | ("red" ["reduce ." 2 () nil] expand-abbrev-hook 0) | |
| 763 | ("rin" ["reduce in : ." 5 () nil] expand-abbrev-hook 0) | |
| 764 | ("exe" ["execute ." 2 () nil] expand-abbrev-hook 0) | |
| 765 | ("ein" ["execute in : ." 5 () nil] expand-abbrev-hook 0) | |
| 766 | ("par" ["parse ." 2 () nil] expand-abbrev-hook 0) | |
| 767 | ("parse" ["parse ." 2 () nil] expand-abbrev-hook 0) | |
| 768 | ("pin" ["parse in : ." 5 () nil] expand-abbrev-hook 0) | |
| 769 | ("sh" "show" nil 0) | |
| 770 | ("des" "describe " nil 0) | |
| 771 | ("regu" "regualize " nil 0) | |
| 772 | ("verb" "verbose" nil 0) | |
| 773 | ("sw" "switch" nil 0) | |
| 774 | ("sws" "switches" nil 0) | |
| 775 | ("req" "require" nil 0) | |
| 776 | ("prov" "provide" nil 0) | |
| 777 | ("sel" ["select ." 2 () nil] expand-abbrev-hook 0) | |
| 778 | ;; CITP | |
| 779 | (":goal" [":goal {}" 1 () nil] expand-abbrev-hook 0) | |
| 780 | (":go" [":goal {}" 1 () nil] expand-abbrev-hook 0) | |
| 781 | (":apply" [":apply ()" 1 () nil] expand-abbrev-hook 0) | |
| 782 | (":app" [":apply ()" 1 () nil] expand-abbrev-hook 0) | |
| 783 | (":ind" [":ind on ()" 1 () nil] expand-abbrev-hook 0) | |
| 784 | (":ini" [":init () by { ;}" 9 () nil] expand-abbrev-hook 0) | |
| 785 | (":inil" [":init [] by { ;}" 9 () nil] expand-abbrev-hook 0) | |
| 786 | (":cp" [":cp () >< ()" 7 () nil] expand-abbrev-hook 0) | |
| 787 | (":cpl" [":cp [] >< []" 7 () nil] expand-abbrev-hook 0) | |
| 788 | (":eq" ":equation" nil 0) | |
| 789 | (":rl" ":rule" nil 0) | |
| 790 | (":bk" ":backward" nil 0) | |
| 791 | (":vb" ":verbose" nil 0) | |
| 792 | (":norm" ":normalize" nil 0) | |
| 793 | (":ctf" [":ctf{}" 1 () nil] expand-abbrev-hook 0) | |
| 794 | (":csp" [":csp{}" 1 () nil] expand-abbrev-hook 0) | |
| 795 | (":sh" ":show" nil 0) | |
| 796 | (":des" ":describe" nil 0) | |
| 797 | )) | |
| 798 | ) | |
| 713 | 799 | |
| 714 | 800 | |
| 715 | 801 | (defvar cafeobj-mode-syntax-table nil |
| 719 | 805 | () |
| 720 | 806 | (setq cafeobj-mode-syntax-table (make-syntax-table)) |
| 721 | 807 | (mapc (function |
| 722 | (lambda (x) (modify-syntax-entry | |
| 723 | (car x) (cdr x) cafeobj-mode-syntax-table))) | |
| 724 | '(( ?\( . "()" ) ( ?\) . ")(" ) | |
| 725 | ( ?\[ . "(]" ) ( ?\] . ")[" ) | |
| 726 | ( ?\{ . "(}" ) ( ?\} . "){" ) | |
| 727 | ;; underscore etc. is word class | |
| 728 | ( ?\_ . "w" ) | |
| 729 | ( ?\# . "w" ) | |
| 730 | ( ?\! . "w" ) | |
| 731 | ( ?\$ . "w" ) | |
| 732 | ( ?\% . "w" ) | |
| 733 | ( ?\" . "\"" ) ; double quote is string quote too | |
| 734 | ( ?\n . ">")) | |
| 735 | )) | |
| 808 | (lambda (x) (modify-syntax-entry | |
| 809 | (car x) (cdr x) cafeobj-mode-syntax-table))) | |
| 810 | '((?\( . "()" ) ( ?\) . ")(" ) | |
| 811 | ;; ( ?\[ . "(]" ) ( ?\] . ")[" ) | |
| 812 | (?\{ . "(}" ) ( ?\} . "){" ) | |
| 813 | (?\[ . "w") (?\] . "w") | |
| 814 | (?\* . "w") | |
| 815 | ;; underscore etc. is word class | |
| 816 | ( ?\_ . "w" ) | |
| 817 | ( ?\# . "w" ) | |
| 818 | ( ?\! . "w" ) | |
| 819 | ( ?\$ . "w" ) | |
| 820 | ( ?\% . "w" ) | |
| 821 | ( ?\: . "w") | |
| 822 | ( ?\" . "\"" ) ; double quote is string quote too | |
| 823 | ( ?\n . ">")) | |
| 824 | )) | |
| 825 | (defvar mode-popup-menu) ;only for XEmacs | |
| 736 | 826 | |
| 737 | 827 | (defun cafeobj-mode () |
| 738 | 828 | "Major mode for editing CafeOBJ programs. |
| 751 | 841 | (setq local-abbrev-table cafeobj-mode-abbrev-table) |
| 752 | 842 | ;; settting menu. |
| 753 | 843 | (if cafeobj-xemacs-p |
| 754 | (setq mode-popup-menu | |
| 755 | cafeobj-mode-popup-menu) | |
| 844 | (setq mode-popup-menu | |
| 845 | cafeobj-mode-popup-menu) | |
| 756 | 846 | (progn |
| 757 | (define-key cafeobj-mode-map [menu-bar cafeobj-mode] | |
| 758 | (cons "CafeOBJ" cafeobj-mode-menu)))) | |
| 847 | (define-key cafeobj-mode-map [menu-bar cafeobj-mode] | |
| 848 | (cons "CafeOBJ" cafeobj-mode-menu)))) | |
| 759 | 849 | ;; |
| 760 | 850 | (set (make-local-variable 'cafeobj-process) nil) |
| 761 | 851 | (set (make-local-variable 'cafeobj-process-buffer) nil) |
| 762 | 852 | (make-local-variable 'cafeobj-default-command-switches) |
| 763 | 853 | ;; |
| 764 | 854 | (cond (cafeobj-xemacs-p |
| 765 | (make-local-variable 'font-lock-defaults)) | |
| 766 | (t (set (make-local-variable 'font-lock-keywords) | |
| 767 | cafeobj-font-lock-keywords))) | |
| 855 | (make-local-variable 'font-lock-defaults)) | |
| 856 | (t (set (make-local-variable 'font-lock-keywords) | |
| 857 | cafeobj-font-lock-keywords))) | |
| 768 | 858 | ;; |
| 769 | 859 | (make-local-variable 'font-lock-defaults) |
| 770 | 860 | (setq font-lock-defaults '(cafeobj-font-lock-keywords t)) |
| 789 | 879 | (save-excursion |
| 790 | 880 | (goto-char (point-min)) |
| 791 | 881 | (if (looking-at "#![ \t]*\\([^ \t]*\\)[ \t]\\(.*[ \t]\\)-f") |
| 792 | (progn | |
| 793 | (set (make-local-variable 'cafeobj-application-name) | |
| 794 | (buffer-substring (match-beginning 1) | |
| 795 | (match-end 1))) | |
| 796 | (if (match-beginning 2) | |
| 797 | (progn | |
| 798 | (goto-char (match-beginning 2)) | |
| 799 | (set (make-local-variable 'cafeobj-default-command-switches) nil) | |
| 800 | (while (< (point) (match-end 2)) | |
| 801 | (setq s (read (current-buffer))) | |
| 802 | (if (<= (point) (match-end 2)) | |
| 803 | (setq cafeobj-default-command-switches | |
| 804 | (append cafeobj-default-command-switches | |
| 805 | (list (prin1-to-string s))))))))) | |
| 806 | ;; if this fails, look for the #!/bin/csh ... exec hack | |
| 807 | (while (eq (following-char) ?#) | |
| 808 | (forward-line 1)) | |
| 809 | (or (bobp) | |
| 810 | (forward-char -1)) | |
| 811 | (if (eq (preceding-char) ?\\) | |
| 812 | (progn | |
| 813 | (forward-char 1) | |
| 814 | (if (looking-at "exec[ \t]+\\([^ \t]*\\)[ \t]\\(.*[ \t]\\)*-f") | |
| 815 | (progn | |
| 816 | (set (make-local-variable 'cafeobj-application-name) | |
| 817 | (buffer-substring (match-beginning 1) | |
| 818 | (match-end 1))) | |
| 819 | (if (match-beginning 2) | |
| 820 | (progn | |
| 821 | (goto-char (match-beginning 2)) | |
| 822 | (set (make-local-variable | |
| 823 | 'cafeobj-default-command-switches) | |
| 824 | nil) | |
| 825 | (while (< (point) (match-end 2)) | |
| 826 | (setq s (read (current-buffer))) | |
| 827 | (if (<= (point) (match-end 2)) | |
| 828 | (setq cafeobj-default-command-switches | |
| 829 | (append cafeobj-default-command-switches | |
| 830 | (list (prin1-to-string s))))))))) | |
| 831 | ))))) | |
| 882 | (progn | |
| 883 | (set (make-local-variable 'cafeobj-application-name) | |
| 884 | (buffer-substring (match-beginning 1) | |
| 885 | (match-end 1))) | |
| 886 | (if (match-beginning 2) | |
| 887 | (progn | |
| 888 | (goto-char (match-beginning 2)) | |
| 889 | (set (make-local-variable 'cafeobj-default-command-switches) nil) | |
| 890 | (while (< (point) (match-end 2)) | |
| 891 | (setq s (read (current-buffer))) | |
| 892 | (if (<= (point) (match-end 2)) | |
| 893 | (setq cafeobj-default-command-switches | |
| 894 | (append cafeobj-default-command-switches | |
| 895 | (list (prin1-to-string s))))))))) | |
| 896 | ;; if this fails, look for the #!/bin/csh ... exec hack | |
| 897 | (while (eq (following-char) ?#) | |
| 898 | (forward-line 1)) | |
| 899 | (or (bobp) | |
| 900 | (forward-char -1)) | |
| 901 | (if (eq (preceding-char) ?\\) | |
| 902 | (progn | |
| 903 | (forward-char 1) | |
| 904 | (if (looking-at "exec[ \t]+\\([^ \t]*\\)[ \t]\\(.*[ \t]\\)*-f") | |
| 905 | (progn | |
| 906 | (set (make-local-variable 'cafeobj-application-name) | |
| 907 | (buffer-substring (match-beginning 1) | |
| 908 | (match-end 1))) | |
| 909 | (if (match-beginning 2) | |
| 910 | (progn | |
| 911 | (goto-char (match-beginning 2)) | |
| 912 | (set (make-local-variable | |
| 913 | 'cafeobj-default-command-switches) | |
| 914 | nil) | |
| 915 | (while (< (point) (match-end 2)) | |
| 916 | (setq s (read (current-buffer))) | |
| 917 | (if (<= (point) (match-end 2)) | |
| 918 | (setq cafeobj-default-command-switches | |
| 919 | (append cafeobj-default-command-switches | |
| 920 | (list (prin1-to-string s))))))))) | |
| 921 | ))))) | |
| 832 | 922 | ;; |
| 833 | 923 | ;; (if (and (featurep 'menubar) |
| 834 | ;; current-menubar) | |
| 835 | ;; (progn | |
| 836 | ;; ;; make a local copy of the menubar, so our modes don't | |
| 837 | ;; ;; change the global menubar | |
| 838 | ;; (set-buffer-menubar current-menubar) | |
| 839 | ;; (add-submenu nil cafeobj-mode-menubar-menu))) | |
| 924 | ;; current-menubar) | |
| 925 | ;; (progn | |
| 926 | ;; ;; make a local copy of the menubar, so our modes don't | |
| 927 | ;; ;; change the global menubar | |
| 928 | ;; (set-buffer-menubar current-menubar) | |
| 929 | ;; (add-submenu nil cafeobj-mode-menubar-menu))) | |
| 840 | 930 | ;; |
| 841 | 931 | (run-hooks 'cafeobj-mode-hook))) |
| 842 | 932 | |
| 851 | 941 | (setq cafeobj-mode-map (make-sparse-keymap)) |
| 852 | 942 | ;; |
| 853 | 943 | (let ((map (if cafeobj-prefix-key |
| 854 | (make-sparse-keymap) | |
| 855 | cafeobj-mode-map))) | |
| 944 | (make-sparse-keymap) | |
| 945 | cafeobj-mode-map))) | |
| 856 | 946 | ;; indentation |
| 857 | 947 | (define-key cafeobj-mode-map [?}] 'cafeobj-electric-brace) |
| 858 | 948 | ;; communication |
| 859 | (define-key map "i" 'cafeobj-send-line) | |
| 949 | (define-key map "l" 'cafeobj-send-line) | |
| 860 | 950 | (define-key map "e" 'cafeobj-send-decl) |
| 861 | 951 | (define-key map "r" 'cafeobj-send-region) |
| 862 | (define-key map "l" 'cafeobj-send-buffer) | |
| 952 | (define-key map "b" 'cafeobj-send-buffer) | |
| 863 | 953 | (define-key map "[" 'cafeobj-beginning-of-decl) |
| 864 | 954 | (define-key map "]" 'cafeobj-end-of-decl) |
| 865 | 955 | (define-key map "q" 'cafeobj-kill-process) |
| 867 | 957 | (define-key map "h" 'cafeobj-hide-process-buffer) |
| 868 | 958 | ;; |
| 869 | 959 | (if cafeobj-prefix-key |
| 870 | (define-key cafeobj-mode-map cafeobj-prefix-key map)) | |
| 960 | (define-key cafeobj-mode-map cafeobj-prefix-key map)) | |
| 871 | 961 | )) |
| 872 | 962 | |
| 873 | 963 | ;;; ---------------- |
| 887 | 977 | (interactive "P") |
| 888 | 978 | (let (insertpos) |
| 889 | 979 | (if (and (not arg) |
| 890 | (eolp) | |
| 891 | (or (save-excursion | |
| 892 | (skip-chars-backward " \t") | |
| 893 | (bolp)) | |
| 894 | (if cafeobj-auto-newline | |
| 895 | (progn (cafeobj-indent-line) (newline) t) | |
| 896 | nil))) | |
| 897 | (progn | |
| 898 | ;; (insert last-command-char) | |
| 899 | (insert last-command-event) | |
| 900 | (cafeobj-indent-line) | |
| 901 | (if cafeobj-auto-newline | |
| 902 | (progn | |
| 903 | (newline) | |
| 904 | ;; (newline) may have done auto-fill | |
| 905 | (setq insertpos (- (point) 2)) | |
| 906 | (cafeobj-indent-line))) | |
| 907 | (save-excursion | |
| 908 | (if insertpos (goto-char (1+ insertpos))) | |
| 909 | (delete-char -1)))) | |
| 980 | (eolp) | |
| 981 | (or (save-excursion | |
| 982 | (skip-chars-backward " \t") | |
| 983 | (bolp)) | |
| 984 | (if cafeobj-auto-newline | |
| 985 | (progn (cafeobj-indent-line) (newline) t) | |
| 986 | nil))) | |
| 987 | (progn | |
| 988 | ;; (insert last-command-char) | |
| 989 | (insert last-command-event) | |
| 990 | (cafeobj-indent-line) | |
| 991 | (if cafeobj-auto-newline | |
| 992 | (progn | |
| 993 | (newline) | |
| 994 | ;; (newline) may have done auto-fill | |
| 995 | (setq insertpos (- (point) 2)) | |
| 996 | (cafeobj-indent-line))) | |
| 997 | (save-excursion | |
| 998 | (if insertpos (goto-char (1+ insertpos))) | |
| 999 | (delete-char -1)))) | |
| 910 | 1000 | (if insertpos |
| 911 | (save-excursion | |
| 912 | (goto-char insertpos) | |
| 913 | (self-insert-command (prefix-numeric-value arg))) | |
| 914 | (self-insert-command (prefix-numeric-value arg))))) | |
| 1001 | (save-excursion | |
| 1002 | (goto-char insertpos) | |
| 1003 | (self-insert-command (prefix-numeric-value arg))) | |
| 1004 | (self-insert-command (prefix-numeric-value arg))))) | |
| 915 | 1005 | |
| 916 | 1006 | (defun cafeobj-beginning-of-block (&optional arg) |
| 917 | 1007 | "Move backward to the beginning of a CafeOBJ block structure. |
| 921 | 1011 | (interactive "P") |
| 922 | 1012 | (or arg (setq arg 1)) |
| 923 | 1013 | (let ((found nil) |
| 924 | (ret t)) | |
| 1014 | (ret t)) | |
| 925 | 1015 | (if (and (< arg 0) |
| 926 | (looking-at-cafeobj-block-start-pat)) | |
| 927 | (forward-char 1)) | |
| 1016 | (looking-at-cafeobj-block-start-pat)) | |
| 1017 | (forward-char 1)) | |
| 928 | 1018 | (while (< arg 0) |
| 929 | 1019 | (if (re-search-forward cafeobj-block-start-pat nil t) |
| 930 | (setq arg (1+ arg) | |
| 931 | found t) | |
| 932 | (setq ret nil | |
| 933 | arg 0))) | |
| 1020 | (setq arg (1+ arg) | |
| 1021 | found t) | |
| 1022 | (setq ret nil | |
| 1023 | arg 0))) | |
| 934 | 1024 | (if found |
| 935 | (beginning-of-line)) | |
| 1025 | (beginning-of-line)) | |
| 936 | 1026 | (while (> arg 0) |
| 937 | 1027 | (if (re-search-backward cafeobj-block-start-pat nil t) |
| 938 | (setq arg (1- arg)) | |
| 939 | (setq ret nil | |
| 940 | arg 0))) | |
| 1028 | (setq arg (1- arg)) | |
| 1029 | (setq ret nil | |
| 1030 | arg 0))) | |
| 941 | 1031 | ret)) |
| 942 | 1032 | |
| 943 | 1033 | (defun cafeobj-beginning-of-decl (&optional arg) |
| 948 | 1038 | (interactive "P") |
| 949 | 1039 | (or arg (setq arg 1)) |
| 950 | 1040 | (let ((found nil) |
| 951 | (ret t)) | |
| 1041 | (ret t)) | |
| 952 | 1042 | (if (and (< arg 0) |
| 953 | (looking-at-cafeobj-top-decl)) | |
| 954 | (forward-char 1)) | |
| 1043 | (looking-at-cafeobj-top-decl)) | |
| 1044 | (forward-char 1)) | |
| 955 | 1045 | (while (< arg 0) |
| 956 | 1046 | (if (re-search-forward cafeobj-top-decl-pat nil t) |
| 957 | (setq arg (1+ arg) | |
| 958 | found t) | |
| 959 | (setq ret nil | |
| 960 | arg 0))) | |
| 1047 | (setq arg (1+ arg) | |
| 1048 | found t) | |
| 1049 | (setq ret nil | |
| 1050 | arg 0))) | |
| 961 | 1051 | (if found |
| 962 | (beginning-of-line)) | |
| 1052 | (beginning-of-line)) | |
| 963 | 1053 | (while (> arg 0) |
| 964 | 1054 | (if (re-search-backward cafeobj-top-decl-pat nil t) |
| 965 | (setq arg (1- arg)) | |
| 966 | (setq ret nil | |
| 967 | arg 0))) | |
| 1055 | (setq arg (1- arg)) | |
| 1056 | (setq ret nil | |
| 1057 | arg 0))) | |
| 968 | 1058 | ret)) |
| 969 | 1059 | |
| 970 | 1060 | (defun cafeobj-end-of-decl (&optional arg) |
| 977 | 1067 | (or arg |
| 978 | 1068 | (setq arg 1)) |
| 979 | 1069 | (let ((found nil) |
| 980 | (ret t)) | |
| 1070 | (ret t)) | |
| 981 | 1071 | (if (and (< arg 0) |
| 982 | (not (bolp)) | |
| 983 | (save-excursion | |
| 984 | (beginning-of-line) | |
| 985 | (eq (following-char) ?}))) | |
| 986 | (forward-char -1)) | |
| 1072 | (not (bolp)) | |
| 1073 | (save-excursion | |
| 1074 | (beginning-of-line) | |
| 1075 | (eq (following-char) ?}))) | |
| 1076 | (forward-char -1)) | |
| 987 | 1077 | (while (> arg 0) |
| 988 | 1078 | (if (re-search-forward "^}" nil t) |
| 989 | (setq arg (1- arg) | |
| 990 | found t) | |
| 991 | (setq ret nil | |
| 992 | arg 0))) | |
| 1079 | (setq arg (1- arg) | |
| 1080 | found t) | |
| 1081 | (setq ret nil | |
| 1082 | arg 0))) | |
| 993 | 1083 | (while (< arg 0) |
| 994 | 1084 | (if (re-search-backward "^}" nil t) |
| 995 | (setq arg (1+ arg) | |
| 996 | found t) | |
| 997 | (setq ret nil | |
| 998 | arg 0))) | |
| 1085 | (setq arg (1+ arg) | |
| 1086 | found t) | |
| 1087 | (setq ret nil | |
| 1088 | arg 0))) | |
| 999 | 1089 | (if found |
| 1000 | (end-of-line)) | |
| 1090 | (end-of-line)) | |
| 1001 | 1091 | ret)) |
| 1002 | 1092 | |
| 1003 | 1093 | (defun cafeobj-outline-level () |
| 1008 | 1098 | (defun cafeobj-inside-parens-p () |
| 1009 | 1099 | (condition-case () |
| 1010 | 1100 | (save-excursion |
| 1011 | (save-restriction | |
| 1012 | (narrow-to-region (point) | |
| 1013 | (progn (cafeobj-beginning-of-decl) (point))) | |
| 1014 | (goto-char (point-max)) | |
| 1015 | (= (char-after (or (scan-lists (point) -1 1) (point-min))) ?\())) | |
| 1101 | (save-restriction | |
| 1102 | (narrow-to-region (point) | |
| 1103 | (progn (cafeobj-beginning-of-decl) (point))) | |
| 1104 | (goto-char (point-max)) | |
| 1105 | (= (char-after (or (scan-lists (point) -1 1) (point-min))) ?\())) | |
| 1016 | 1106 | (error nil))) |
| 1017 | 1107 | |
| 1018 | 1108 | (defun cafeobj-indent-command (&optional whole-exp) |
| 1030 | 1120 | ;; If arg, always indent this line as CafeOBJ |
| 1031 | 1121 | ;; and shift remaining lines of expression the same amount. |
| 1032 | 1122 | (let ((shift-amt (cafeobj-indent-line)) |
| 1033 | beg end) | |
| 1034 | (save-excursion | |
| 1035 | (if cafeobj-tab-always-indent | |
| 1036 | (beginning-of-line)) | |
| 1037 | ;; Find beginning of following line. | |
| 1038 | (save-excursion | |
| 1039 | (forward-line 1) (setq beg (point))) | |
| 1040 | ;; Find first beginning-of-sexp for sexp extending past this line. | |
| 1041 | (while (< (point) beg) | |
| 1042 | (forward-sexp 1) | |
| 1043 | (setq end (point)) | |
| 1044 | (skip-chars-forward " \t\n"))) | |
| 1045 | (if (> end beg) | |
| 1046 | (indent-code-rigidly beg end shift-amt "#"))) | |
| 1123 | beg end) | |
| 1124 | (save-excursion | |
| 1125 | (if cafeobj-tab-always-indent | |
| 1126 | (beginning-of-line)) | |
| 1127 | ;; Find beginning of following line. | |
| 1128 | (save-excursion | |
| 1129 | (forward-line 1) (setq beg (point))) | |
| 1130 | ;; Find first beginning-of-sexp for sexp extending past this line. | |
| 1131 | (while (< (point) beg) | |
| 1132 | (forward-sexp 1) | |
| 1133 | (setq end (point)) | |
| 1134 | (skip-chars-forward " \t\n"))) | |
| 1135 | (if (> end beg) | |
| 1136 | (indent-code-rigidly beg end shift-amt "#"))) | |
| 1047 | 1137 | (if (and (not cafeobj-tab-always-indent) |
| 1048 | (save-excursion | |
| 1049 | (skip-chars-backward " \t") | |
| 1050 | (not (bolp)))) | |
| 1051 | (insert-tab) | |
| 1138 | (save-excursion | |
| 1139 | (skip-chars-backward " \t") | |
| 1140 | (not (bolp)))) | |
| 1141 | (insert-tab) | |
| 1052 | 1142 | (cafeobj-indent-line)))) |
| 1053 | 1143 | |
| 1054 | 1144 | (defun cafeobj-indent-line () |
| 1055 | 1145 | "Indent current line as CafeOBJ code. |
| 1056 | 1146 | Return the amount the indentation changed by." |
| 1057 | 1147 | (let ((indent (calculate-cafeobj-indent nil)) |
| 1058 | beg shift-amt | |
| 1059 | (case-fold-search nil) | |
| 1060 | (pos (- (point-max) (point)))) | |
| 1148 | beg shift-amt | |
| 1149 | (case-fold-search nil) | |
| 1150 | (pos (- (point-max) (point)))) | |
| 1061 | 1151 | (beginning-of-line) |
| 1062 | 1152 | (setq beg (point)) |
| 1063 | 1153 | (cond ((eq indent nil) |
| 1064 | (setq indent (current-indentation))) | |
| 1065 | ((eq indent t) | |
| 1066 | (setq indent (current-indentation))) | |
| 1067 | (t | |
| 1068 | (skip-chars-forward " \t") | |
| 1069 | (if (listp indent) (setq indent (car indent))) | |
| 1070 | (cond ((= (following-char) ?}) | |
| 1071 | (setq indent (- indent cafeobj-indent-level))) | |
| 1072 | ((= (following-char) ?{) | |
| 1073 | (setq indent (+ indent cafeobj-brace-offset)))))) | |
| 1154 | (setq indent (current-indentation))) | |
| 1155 | ((eq indent t) | |
| 1156 | (setq indent (current-indentation))) | |
| 1157 | (t | |
| 1158 | (skip-chars-forward " \t") | |
| 1159 | (if (listp indent) (setq indent (car indent))) | |
| 1160 | (cond ((= (following-char) ?}) | |
| 1161 | (setq indent (- indent cafeobj-indent-level))) | |
| 1162 | ((= (following-char) ?{) | |
| 1163 | (setq indent (+ indent cafeobj-brace-offset)))))) | |
| 1074 | 1164 | (skip-chars-forward " \t") |
| 1075 | 1165 | (setq shift-amt (- indent (current-column))) |
| 1076 | 1166 | (if (zerop shift-amt) |
| 1077 | (if (> (- (point-max) pos) (point)) | |
| 1078 | (goto-char (- (point-max) pos))) | |
| 1167 | (if (> (- (point-max) pos) (point)) | |
| 1168 | (goto-char (- (point-max) pos))) | |
| 1079 | 1169 | (delete-region beg (point)) |
| 1080 | 1170 | (indent-to indent) |
| 1081 | 1171 | ;; If initial point was within line's indentation, |
| 1082 | 1172 | ;; position after the indentation. Else stay at same point in text. |
| 1083 | 1173 | (if (> (- (point-max) pos) (point)) |
| 1084 | (goto-char (- (point-max) pos)))) | |
| 1174 | (goto-char (- (point-max) pos)))) | |
| 1085 | 1175 | shift-amt)) |
| 1086 | 1176 | |
| 1087 | 1177 | (defun calculate-cafeobj-indent (&optional parse-start) |
| 1091 | 1181 | (save-excursion |
| 1092 | 1182 | (beginning-of-line) |
| 1093 | 1183 | (let ((indent-point (point)) |
| 1094 | (case-fold-search nil) | |
| 1095 | state | |
| 1096 | containing-sexp) | |
| 1184 | (case-fold-search nil) | |
| 1185 | state | |
| 1186 | containing-sexp) | |
| 1097 | 1187 | (if parse-start |
| 1098 | (goto-char parse-start) | |
| 1099 | (cafeobj-beginning-of-decl)) | |
| 1188 | (goto-char parse-start) | |
| 1189 | (cafeobj-beginning-of-decl)) | |
| 1100 | 1190 | (while (< (point) indent-point) |
| 1101 | (setq parse-start (point)) | |
| 1102 | (setq state (parse-partial-sexp (point) indent-point 0)) | |
| 1103 | (setq containing-sexp (car (cdr state)))) | |
| 1191 | (setq parse-start (point)) | |
| 1192 | (setq state (parse-partial-sexp (point) indent-point 0)) | |
| 1193 | (setq containing-sexp (car (cdr state)))) | |
| 1104 | 1194 | ;; |
| 1105 | 1195 | (cond ((or (nth 3 state) (nth 4 state)) |
| 1106 | ;; return nil or t if should not change this line | |
| 1107 | (nth 4 state)) ; t if inside a comment, else nil. | |
| 1108 | ;; | |
| 1109 | ((null containing-sexp) ; we are at top-level | |
| 1110 | ;; -- TOP-LEVEL------------------------------------------------ | |
| 1111 | ;; Line is at top level. May be module/view declaration or | |
| 1112 | ;; top-level commands. | |
| 1113 | (goto-char indent-point) ; start from original pos. | |
| 1114 | (skip-chars-forward " \t") | |
| 1115 | (cond ((= (following-char) ?{) 0) | |
| 1116 | ((looking-at-cafeobj-top-decl) 0) | |
| 1117 | ((looking-at-cafeobj-comment-pat) (current-column)) | |
| 1118 | (t | |
| 1119 | (cafeobj-backward-to-noncomment (or parse-start (point-min))) | |
| 1120 | ;; Look at previous line that's at column 0 | |
| 1121 | ;; to determine whether we are in top-level decl. | |
| 1122 | (let ((basic-indent | |
| 1123 | (save-excursion | |
| 1124 | (re-search-backward "^[^ \^L\t\n]" nil 'move) | |
| 1125 | (if (and (looking-at-cafeobj-top-decl) | |
| 1126 | (not (progn | |
| 1127 | (condition-case nil | |
| 1128 | (progn | |
| 1129 | (search-forward "\{" parse-start) | |
| 1130 | (forward-list)) | |
| 1131 | (error nil)) | |
| 1132 | (looking-at "\}")))) | |
| 1133 | cafeobj-psort-indent | |
| 1134 | 0)))) | |
| 1135 | basic-indent)))) | |
| 1136 | ;; NON TOPLEVEL ---------------------------------------------- | |
| 1137 | ((and (/= (char-after containing-sexp) ?{) | |
| 1138 | (< (car state) 2)) | |
| 1139 | ;; indent to just after the surrounding open. | |
| 1140 | (goto-char (+ 2 containing-sexp)) | |
| 1141 | (current-column)) | |
| 1142 | ;; WITHIN A BRACE -------------------------------------------- | |
| 1143 | (t | |
| 1144 | (goto-char indent-point) | |
| 1145 | (if (and (not (is-cafeobj-beginning-of-statement)) | |
| 1146 | (progn (cafeobj-backward-to-noncomment containing-sexp) | |
| 1147 | (not (memq (preceding-char) | |
| 1148 | '(0 ?\, ?\} ?\{ ?\. ?\] ?\))))) | |
| 1149 | ;; don't treat a line with a close-brace | |
| 1150 | ;; as a continuation. It is probably the | |
| 1151 | ;; end of a block. | |
| 1152 | (save-excursion | |
| 1153 | (goto-char indent-point) | |
| 1154 | (skip-chars-forward " \t") | |
| 1155 | (not (= (following-char) ?}))) | |
| 1156 | ) | |
| 1157 | ;; This line is continuation of preceding line's statement; | |
| 1158 | ;; indent cafeobj-continued-statement-offset more than the | |
| 1159 | ;; previous line of the statement. | |
| 1160 | (progn | |
| 1161 | (cafeobj-backward-to-start-of-continued-exp containing-sexp) | |
| 1162 | (+ cafeobj-continued-statement-offset (current-column) | |
| 1163 | (if (save-excursion (goto-char indent-point) | |
| 1164 | (skip-chars-forward " \t") | |
| 1165 | (eq (following-char) ?{)) | |
| 1166 | cafeobj-continued-brace-offset | |
| 1167 | 0))) | |
| 1168 | ;; This line starts a new statement. | |
| 1169 | ;; if we are looking at a comment line, leave it as is. | |
| 1170 | (if (progn | |
| 1171 | (goto-char indent-point) | |
| 1172 | (skip-chars-forward " \t") | |
| 1173 | (looking-at-cafeobj-comment-pat)) | |
| 1174 | (current-column) | |
| 1175 | (progn | |
| 1176 | ;; Position following last unclosed open-brace. | |
| 1177 | (goto-char containing-sexp) | |
| 1178 | ;; Is line first statement after an open-brace? | |
| 1179 | (or | |
| 1180 | ;; If no, find that first statement and indent like it. | |
| 1181 | (save-excursion | |
| 1182 | (forward-char 1) | |
| 1183 | (while (progn (skip-chars-forward " \t\n") | |
| 1184 | (looking-at "--[ \t].*\\|\*\*[ \t].*")) | |
| 1185 | (forward-line 1)) | |
| 1186 | ;; The first following code counts | |
| 1187 | ;; if it is before the line we want to indent. | |
| 1188 | (skip-chars-forward " \t\n") | |
| 1189 | (and (< (point) indent-point) | |
| 1190 | (- (current-column) | |
| 1191 | ;; If prev stmt starts with open-brace, that | |
| 1192 | ;; open brace was offset by cafeobj-brace-offset. | |
| 1193 | ;; Compensate to get the column where | |
| 1194 | ;; an ordinary statement would start. | |
| 1195 | (if (= (following-char) ?\{) | |
| 1196 | cafeobj-brace-offset | |
| 1197 | 0)) | |
| 1198 | )) | |
| 1199 | ;; If no previous statement, | |
| 1200 | ;; indent it relative to line brace is on. | |
| 1201 | ;; For open brace in column zero, don't let statement | |
| 1202 | ;; start there too. If cafeobj-indent-level is zero, | |
| 1203 | ;; use cafeobj-brace-offset + | |
| 1204 | ;; cafeobj-continued-statement-offset instead. | |
| 1205 | ;; For open-braces not the first thing in a line, | |
| 1206 | ;; add in cafeobj-brace-imaginary-offset. | |
| 1207 | (+ (if (and (bolp) (zerop cafeobj-indent-level)) | |
| 1208 | (+ cafeobj-brace-offset | |
| 1209 | cafeobj-continued-statement-offset) | |
| 1210 | cafeobj-indent-level) | |
| 1211 | ;; Move back over whitespace before the openbrace. | |
| 1212 | ;; If openbrace is not first nonwhite thing on the line, | |
| 1213 | ;; add the cafeobj-brace-imaginary-offset. | |
| 1214 | (progn (skip-chars-backward " \t") | |
| 1215 | (if (bolp) | |
| 1216 | 0 | |
| 1217 | cafeobj-brace-imaginary-offset)) | |
| 1218 | ;; If the openbrace is preceded by a parenthesized exp, | |
| 1219 | ;; move to the beginning of that; | |
| 1220 | ;; possibly a different line | |
| 1221 | (progn | |
| 1222 | (if (memq (preceding-char) '(?\) \])) | |
| 1223 | (forward-sexp -1)) | |
| 1224 | ;; Get initial indentation of the line we are on. | |
| 1225 | (current-indentation)))))))))))) | |
| 1196 | ;; return nil or t if should not change this line | |
| 1197 | (nth 4 state)) ; t if inside a comment, else nil. | |
| 1198 | ;; | |
| 1199 | ((null containing-sexp) ; we are at top-level | |
| 1200 | ;; -- TOP-LEVEL------------------------------------------------ | |
| 1201 | ;; Line is at top level. May be module/view declaration or | |
| 1202 | ;; top-level commands. | |
| 1203 | (goto-char indent-point) ; start from original pos. | |
| 1204 | (skip-chars-forward " \t") | |
| 1205 | (cond ((= (following-char) ?{) 0) | |
| 1206 | ((looking-at-cafeobj-top-decl) 0) | |
| 1207 | ((looking-at-cafeobj-comment-pat) (current-column)) | |
| 1208 | (t | |
| 1209 | (cafeobj-backward-to-noncomment (or parse-start (point-min))) | |
| 1210 | ;; Look at previous line that's at column 0 | |
| 1211 | ;; to determine whether we are in top-level decl. | |
| 1212 | (let ((basic-indent | |
| 1213 | (save-excursion | |
| 1214 | (re-search-backward "^[^ \^L\t\n]" nil 'move) | |
| 1215 | (if (and (looking-at-cafeobj-top-decl) | |
| 1216 | (not (progn | |
| 1217 | (condition-case nil | |
| 1218 | (progn | |
| 1219 | (search-forward "\{" parse-start) | |
| 1220 | (forward-list)) | |
| 1221 | (error nil)) | |
| 1222 | (looking-at "\}")))) | |
| 1223 | cafeobj-psort-indent | |
| 1224 | 0)))) | |
| 1225 | basic-indent)))) | |
| 1226 | ;; NON TOPLEVEL ---------------------------------------------- | |
| 1227 | ((and (/= (char-after containing-sexp) ?{) | |
| 1228 | (< (car state) 2)) | |
| 1229 | ;; indent to just after the surrounding open. | |
| 1230 | (goto-char (+ 2 containing-sexp)) | |
| 1231 | (current-column)) | |
| 1232 | ;; WITHIN A BRACE -------------------------------------------- | |
| 1233 | (t | |
| 1234 | (goto-char indent-point) | |
| 1235 | (if (and (not (is-cafeobj-beginning-of-statement)) | |
| 1236 | (progn (cafeobj-backward-to-noncomment containing-sexp) | |
| 1237 | (not (memq (preceding-char) | |
| 1238 | '(0 ?\, ?\} ?\{ ?\. ?\] ?\))))) | |
| 1239 | ;; don't treat a line with a close-brace | |
| 1240 | ;; as a continuation. It is probably the | |
| 1241 | ;; end of a block. | |
| 1242 | (save-excursion | |
| 1243 | (goto-char indent-point) | |
| 1244 | (skip-chars-forward " \t") | |
| 1245 | (not (= (following-char) ?}))) | |
| 1246 | ) | |
| 1247 | ;; This line is continuation of preceding line's statement; | |
| 1248 | ;; indent cafeobj-continued-statement-offset more than the | |
| 1249 | ;; previous line of the statement. | |
| 1250 | (progn | |
| 1251 | (cafeobj-backward-to-start-of-continued-exp containing-sexp) | |
| 1252 | (+ cafeobj-continued-statement-offset (current-column) | |
| 1253 | (if (save-excursion (goto-char indent-point) | |
| 1254 | (skip-chars-forward " \t") | |
| 1255 | (eq (following-char) ?{)) | |
| 1256 | cafeobj-continued-brace-offset | |
| 1257 | 0))) | |
| 1258 | ;; This line starts a new statement. | |
| 1259 | ;; if we are looking at a comment line, leave it as is. | |
| 1260 | (if (progn | |
| 1261 | (goto-char indent-point) | |
| 1262 | (skip-chars-forward " \t") | |
| 1263 | (looking-at-cafeobj-comment-pat)) | |
| 1264 | (current-column) | |
| 1265 | (progn | |
| 1266 | ;; Position following last unclosed open-brace. | |
| 1267 | (goto-char containing-sexp) | |
| 1268 | ;; Is line first statement after an open-brace? | |
| 1269 | (or | |
| 1270 | ;; If no, find that first statement and indent like it. | |
| 1271 | (save-excursion | |
| 1272 | (forward-char 1) | |
| 1273 | (while (progn (skip-chars-forward " \t\n") | |
| 1274 | (looking-at "--[ \t].*\\|\*\*[ \t].*")) | |
| 1275 | (forward-line 1)) | |
| 1276 | ;; The first following code counts | |
| 1277 | ;; if it is before the line we want to indent. | |
| 1278 | (skip-chars-forward " \t\n") | |
| 1279 | (and (< (point) indent-point) | |
| 1280 | (- (current-column) | |
| 1281 | ;; If prev stmt starts with open-brace, that | |
| 1282 | ;; open brace was offset by cafeobj-brace-offset. | |
| 1283 | ;; Compensate to get the column where | |
| 1284 | ;; an ordinary statement would start. | |
| 1285 | (if (= (following-char) ?\{) | |
| 1286 | cafeobj-brace-offset | |
| 1287 | 0)) | |
| 1288 | )) | |
| 1289 | ;; If no previous statement, | |
| 1290 | ;; indent it relative to line brace is on. | |
| 1291 | ;; For open brace in column zero, don't let statement | |
| 1292 | ;; start there too. If cafeobj-indent-level is zero, | |
| 1293 | ;; use cafeobj-brace-offset + | |
| 1294 | ;; cafeobj-continued-statement-offset instead. | |
| 1295 | ;; For open-braces not the first thing in a line, | |
| 1296 | ;; add in cafeobj-brace-imaginary-offset. | |
| 1297 | (+ (if (and (bolp) (zerop cafeobj-indent-level)) | |
| 1298 | (+ cafeobj-brace-offset | |
| 1299 | cafeobj-continued-statement-offset) | |
| 1300 | cafeobj-indent-level) | |
| 1301 | ;; Move back over whitespace before the openbrace. | |
| 1302 | ;; If openbrace is not first nonwhite thing on the line, | |
| 1303 | ;; add the cafeobj-brace-imaginary-offset. | |
| 1304 | (progn (skip-chars-backward " \t") | |
| 1305 | (if (bolp) | |
| 1306 | 0 | |
| 1307 | cafeobj-brace-imaginary-offset)) | |
| 1308 | ;; If the openbrace is preceded by a parenthesized exp, | |
| 1309 | ;; move to the beginning of that; | |
| 1310 | ;; possibly a different line | |
| 1311 | (progn | |
| 1312 | (if (memq (preceding-char) '(?\) \])) | |
| 1313 | (forward-sexp -1)) | |
| 1314 | ;; Get initial indentation of the line we are on. | |
| 1315 | (current-indentation)))))))))))) | |
| 1226 | 1316 | |
| 1227 | 1317 | (defun is-cafeobj-beginning-of-statement () |
| 1228 | 1318 | (save-excursion |
| 1229 | 1319 | (beginning-of-line) |
| 1230 | 1320 | ;; (skip-chars-forward " \t") |
| 1231 | 1321 | (or (looking-at-cafeobj-keyword-pat) |
| 1232 | (looking-at-cafeobj-command-pat)))) | |
| 1322 | (looking-at-cafeobj-command-pat)))) | |
| 1233 | 1323 | |
| 1234 | 1324 | (defun cafeobj-backward-to-noncomment (lim) |
| 1235 | 1325 | (let (stop) |
| 1236 | 1326 | (while (not stop) |
| 1237 | 1327 | (skip-chars-backward " \t\n\f" lim) |
| 1238 | 1328 | (setq stop (or (<= (point) lim) |
| 1239 | (save-excursion | |
| 1240 | (beginning-of-line) | |
| 1241 | (skip-chars-forward " \t") | |
| 1242 | (not (looking-at-cafeobj-comment-pat))))) | |
| 1329 | (save-excursion | |
| 1330 | (beginning-of-line) | |
| 1331 | (skip-chars-forward " \t") | |
| 1332 | (not (looking-at-cafeobj-comment-pat))))) | |
| 1243 | 1333 | (or stop (beginning-of-line))))) |
| 1244 | 1334 | |
| 1245 | 1335 | (defun cafeobj-backward-to-start-of-continued-exp (lim) |
| 1249 | 1339 | (if (<= (point) lim) |
| 1250 | 1340 | (goto-char (1+ lim))) |
| 1251 | 1341 | (skip-chars-forward " \t")) |
| 1252 | ||
| 1253 | 1342 | |
| 1254 | 1343 | |
| 1255 | 1344 | |
| 1359 | 1448 | nil) |
| 1360 | 1449 | "*If non-nil, is regexp used to track drive changes." |
| 1361 | 1450 | :type '(choice regexp |
| 1362 | (const nil)) | |
| 1451 | (const nil)) | |
| 1363 | 1452 | :group 'cafeobj-directories) |
| 1364 | 1453 | |
| 1365 | 1454 | (defcustom cafeobj-cd-regexp "cd" |
| 1385 | 1474 | "List of directories saved by pushd in this buffer's CafeOBJ. |
| 1386 | 1475 | Thus, this does not include the CafeOBJ's current directory.") |
| 1387 | 1476 | |
| 1477 | (defvar cafeobj-dirstack-query nil) | |
| 1478 | ||
| 1388 | 1479 | (defvar cafeobj-dirtrackp t |
| 1389 | 1480 | "Non-nil in a CafeOBJ buffer means directory tracking is enabled.") |
| 1390 | 1481 | |
| 1395 | 1486 | |
| 1396 | 1487 | (cond ((not cafeobj-process-mode-map) |
| 1397 | 1488 | (setq cafeobj-process-mode-map |
| 1398 | (nconc (make-sparse-keymap) comint-mode-map)) | |
| 1489 | (nconc (make-sparse-keymap) comint-mode-map)) | |
| 1399 | 1490 | (define-key cafeobj-process-mode-map |
| 1400 | "\C-c\C-f" 'cafeobj-forward-command) | |
| 1491 | "\C-c\C-f" 'cafeobj-forward-command) | |
| 1401 | 1492 | (define-key cafeobj-process-mode-map |
| 1402 | "\C-c\C-b" 'cafeobj-backward-command) | |
| 1493 | "\C-c\C-b" 'cafeobj-backward-command) | |
| 1403 | 1494 | (define-key cafeobj-process-mode-map |
| 1404 | "\t" 'comint-dynamic-complete) | |
| 1495 | "\t" 'comint-dynamic-complete) | |
| 1405 | 1496 | (define-key cafeobj-process-mode-map |
| 1406 | "\M-?" 'comint-dynamic-list-filename-completions) | |
| 1497 | "\M-?" 'comint-dynamic-list-filename-completions) | |
| 1498 | (define-key cafeobj-process-mode-map | |
| 1499 | "\C-c\C-g" 'cafeobj-put-esc-esc) | |
| 1407 | 1500 | (define-key cafeobj-process-mode-map [menu-bar completion] |
| 1408 | (cons "Complete" | |
| 1409 | (copy-keymap (lookup-key comint-mode-map [menu-bar completion])))) | |
| 1501 | (cons "Complete" | |
| 1502 | (copy-keymap (lookup-key comint-mode-map [menu-bar completion])))) | |
| 1410 | 1503 | (define-key-after (lookup-key cafeobj-process-mode-map |
| 1411 | [menu-bar completion]) | |
| 1412 | [complete-env-variable] '("Complete Env. Variable Name" . | |
| 1413 | cafeobj-dynamic-complete-environment-variable) | |
| 1414 | 'complete-file) | |
| 1504 | [menu-bar completion]) | |
| 1505 | [complete-env-variable] '("Complete Env. Variable Name" . | |
| 1506 | cafeobj-dynamic-complete-environment-variable) | |
| 1507 | 'complete-file) | |
| 1415 | 1508 | (define-key-after (lookup-key cafeobj-process-mode-map [menu-bar completion]) |
| 1416 | [expand-directory] '("Expand Directory Reference" . | |
| 1417 | cafeobj-replace-by-expanded-directory) | |
| 1418 | 'complete-expand) | |
| 1509 | [expand-directory] '("Expand Directory Reference" . | |
| 1510 | cafeobj-replace-by-expanded-directory) | |
| 1511 | 'complete-expand) | |
| 1419 | 1512 | (unless (featurep 'infodock) |
| 1420 | (define-key cafeobj-process-mode-map "\M-\C-m" 'cafeobj-resync-dirs)) | |
| 1513 | (define-key cafeobj-process-mode-map "\M-\C-m" 'cafeobj-resync-dirs)) | |
| 1421 | 1514 | )) |
| 1422 | 1515 | |
| 1423 | 1516 | (defcustom cafeobj-process-mode-hook nil |
| 1501 | 1594 | (setq cafeobj-process-font-lock-keywords |
| 1502 | 1595 | (append |
| 1503 | 1596 | (list '(eval . (cons cafeobj-prompt-pattern |
| 1504 | cafeobj-prompt-face)) | |
| 1505 | '("\\[Error\\]:" . cafeobj-error-face) | |
| 1506 | '("\\[Warning\\]:" . cafeobj-warning-face) | |
| 1507 | '("^\\[Properties .*$" . cafeobj-process-keyword-face) | |
| 1508 | '("^\\[selected .*$" . cafeobj-comment-face-2) | |
| 1509 | '("^\\* kept .*$" . cafeobj-comment-face-1) | |
| 1510 | '("^\\*\\* success$" . cafeobj-message-3-face) | |
| 1511 | '("^\\*\\* fail$" . cafeobj-message-3-face) | |
| 1512 | '("^\\*\\* found .*$" . cafeobj-message-3-face) | |
| 1513 | '("^\\*\\* ok, .*$" . cafeobj-message-3-face) | |
| 1514 | '("\\<\\(trying .*\\)\\>:" 0 cafeobj-message-2-face) | |
| 1515 | '("^\\*\\* check .*:" . cafeobj-message-2-face) | |
| 1516 | '("^\\*\\* Fail.*$" . cafeobj-message-3-face) | |
| 1517 | '("^\\*\\* fail!$" . cafeobj-message-3-face) | |
| 1518 | '("^\\*\\* Predicate .*$". cafeobj-message-3-face) | |
| 1519 | '("^\\*\\* PigNose .*$" . cafeobj-message-2-face) | |
| 1520 | '("^\\*\\* Search .*$" . cafeobj-process-keyword-face) | |
| 1521 | '("^\\(-- reduce in .* :\\) " 1 cafeobj-message-1-face) | |
| 1522 | '("^\\(-- behavioural reduce in .* :\\) " 1 cafeobj-message-1-face) | |
| 1523 | '("^\\(-- cbred in .* :\\)" 1 cafeobj-message-1-face) | |
| 1524 | '("^\\(#[0-9]+\\)(" 1 cafeobj-comment-face-1) | |
| 1525 | ;; '("\\<done.$" . cafeobj-message-2-face) | |
| 1526 | '("^\\(case #.*:\\) " 1 cafeobj-message-1-face) | |
| 1527 | '("^| .*|$" . cafeobj-message-2-face) | |
| 1528 | '("** __+$" . cafeobj-message-1-face) | |
| 1529 | '("^\\*\\*.*$" . cafeobj-comment-face-1) | |
| 1530 | '("^\\*\\* USABLE " . cafeobj-process-keyword-face) | |
| 1531 | '("^\\*\\* SOS " . cafeobj-process-keyword-face) | |
| 1532 | '("^\\*\\* PASSIVE " . cafeobj-process-keyword-face) | |
| 1533 | '("^\\*\\* Starting PigNose " . cafeobj-process-keyword-face) | |
| 1534 | '("^\\*\\* DEMODULATORS " . cafeobj-process-keyword-face) | |
| 1535 | '("^\\*\\* PROOF " . cafeobj-process-keyword-face) | |
| 1536 | '("^___+$" . cafeobj-message-2-face) | |
| 1537 | '("^---+$" . cafeobj-message-2-face) | |
| 1538 | '("^--.*$" . cafeobj-comment-face-2) | |
| 1539 | '("^adding axiom:" . cafeobj-comment-face-2) | |
| 1540 | '("^goal:" . cafeobj-message-1-face) | |
| 1541 | '("^hypo:" . cafeobj-comment-face-2) | |
| 1542 | '("^ax:" . cafeobj-message-1-face) | |
| 1543 | '("^+.*$" . cafeobj-message-2-face) | |
| 1544 | '("^==.*$" . cafeobj-message-2-face) | |
| 1545 | '("[ \t]\\([+-][^ \t\n>]+\\)" 1 cafeobj-option-face) | |
| 1546 | ;; '("^[^\n]+.*$" . cafeobj-output-face) | |
| 1547 | ) | |
| 1597 | cafeobj-prompt-face)) | |
| 1598 | '("\\[Error\\]:" . cafeobj-error-face) | |
| 1599 | '("\\[Warning\\]:" . cafeobj-warning-face) | |
| 1600 | '("^\\[Properties .*$" . cafeobj-process-keyword-face) | |
| 1601 | '("^\\[selected .*$" . cafeobj-comment-face-2) | |
| 1602 | '("^\\* kept .*$" . cafeobj-comment-face-1) | |
| 1603 | '("^\\*\\* success$" . cafeobj-message-3-face) | |
| 1604 | '("^\\*\\* fail$" . cafeobj-message-3-face) | |
| 1605 | '("^\\*\\* found .*$" . cafeobj-message-3-face) | |
| 1606 | '("^\\*\\* ok, .*$" . cafeobj-message-3-face) | |
| 1607 | '("\\<\\(trying .*\\)\\>:" 0 cafeobj-message-2-face) | |
| 1608 | '("^\\*\\* check .*:" . cafeobj-message-2-face) | |
| 1609 | '("^\\*\\* Fail.*$" . cafeobj-message-3-face) | |
| 1610 | '("^\\*\\* fail!$" . cafeobj-message-3-face) | |
| 1611 | '("^\\*\\* Predicate .*$". cafeobj-message-3-face) | |
| 1612 | '("^\\*\\* PigNose .*$" . cafeobj-message-2-face) | |
| 1613 | '("^\\*\\* Search .*$" . cafeobj-process-keyword-face) | |
| 1614 | ;; reduction | |
| 1615 | '("^\\(-- reduce in .* :\\) " 1 cafeobj-message-1-face) | |
| 1616 | '("^\\(-- behavioural reduce in .* :\\) " 1 cafeobj-message-1-face) | |
| 1617 | '("^\\(-- cbred in .* :\\)" 1 cafeobj-message-1-face) | |
| 1618 | '("^\\(#[0-9]+\\)(" 1 cafeobj-comment-face-1) | |
| 1619 | ;; CITP | |
| 1620 | '("^\\[.+\\].*$" . cafeobj-message-1-face) | |
| 1621 | ;; '("\\<done.$" . cafeobj-message-2-face) | |
| 1622 | '("^\\(case #.*:\\) " 1 cafeobj-message-1-face) | |
| 1623 | '("^| .*|$" . cafeobj-message-2-face) | |
| 1624 | '("** __+$" . cafeobj-message-1-face) | |
| 1625 | ;; '("^\\*\\*.*$" . cafeobj-comment-face-1) | |
| 1626 | '("^\\*\\* USABLE " . cafeobj-process-keyword-face) | |
| 1627 | '("^\\*\\* SOS " . cafeobj-process-keyword-face) | |
| 1628 | '("^\\*\\* PASSIVE " . cafeobj-process-keyword-face) | |
| 1629 | '("^\\*\\* Starting PigNose " . cafeobj-process-keyword-face) | |
| 1630 | '("^\\*\\* DEMODULATORS " . cafeobj-process-keyword-face) | |
| 1631 | '("^\\*\\* PROOF " . cafeobj-process-keyword-face) | |
| 1632 | '("^___+$" . cafeobj-message-2-face) | |
| 1633 | '("^---+$" . cafeobj-message-2-face) | |
| 1634 | '("^adding axiom:" . cafeobj-comment-face-2) | |
| 1635 | '("^goal:" . cafeobj-message-1-face) | |
| 1636 | '("^hypo:" . cafeobj-comment-face-2) | |
| 1637 | '("^ax:" . cafeobj-message-1-face) | |
| 1638 | '("^==.*$" . cafeobj-message-2-face) | |
| 1639 | '("[ \t]\\([+-][^ \t\n>]+\\)" 1 cafeobj-option-face) | |
| 1640 | ;; '("^[^\n]+.*$" . cafeobj-output-face) | |
| 1641 | ) | |
| 1548 | 1642 | cafeobj-font-lock-keywords))) |
| 1549 | 1643 | |
| 1550 | 1644 | (put 'cafeobj-process-mode 'font-lock-defaults |
| 1599 | 1693 | (setq cafeobj-process (get-buffer-process cafeobj-process-buffer)) |
| 1600 | 1694 | (save-excursion |
| 1601 | 1695 | (set-buffer cafeobj-process-buffer) |
| 1602 | (cafeobj-process-mode) | |
| 1603 | )) | |
| 1696 | (cafeobj-process-mode))) | |
| 1697 | ||
| 1698 | (defcustom cafeobj-logo-file "/usr/local/share/doc/cafeobj/cafeobj-logo-small.png" | |
| 1699 | "CafeOBJ's logo file displayed at start up time of the interpreter." | |
| 1700 | :type 'string | |
| 1701 | :group 'cafeobj) | |
| 1702 | ||
| 1703 | (defun cafeobj-startup-message (&optional x y) | |
| 1704 | "Insert startup message in current buffer." | |
| 1705 | (erase-buffer) | |
| 1706 | (when (and (display-graphic-p) | |
| 1707 | (file-exists-p cafeobj-logo-file)) | |
| 1708 | (let* ((img (create-image cafeobj-logo-file)) | |
| 1709 | (img-size (image-size img)) | |
| 1710 | (char-per-pixel (/ (* 1.0 (window-width)) (window-pixel-width)))) | |
| 1711 | (goto-char (point-min)) | |
| 1712 | (insert " \n") | |
| 1713 | (insert-image img) | |
| 1714 | (while (not (eobp)) | |
| 1715 | (insert (make-string (truncate (* (/ (max (- (window-pixel-width) | |
| 1716 | (or x (car img-size))) | |
| 1717 | 0) | |
| 1718 | 2) | |
| 1719 | char-per-pixel)) | |
| 1720 | ?\ )) | |
| 1721 | (forward-line 1)))) | |
| 1722 | (goto-char (point-max)) | |
| 1723 | (insert (make-string 2 ?\n)) | |
| 1724 | (set-buffer-modified-p t)) | |
| 1604 | 1725 | |
| 1605 | 1726 | (defun cafeobj (&rest ignore) |
| 1606 | 1727 | (interactive) |
| 1607 | 1728 | (if (and cafeobj-process |
| 1608 | (eq (process-status cafeobj-process) 'run)) | |
| 1729 | (eq (process-status cafeobj-process) 'run)) | |
| 1609 | 1730 | (switch-to-buffer cafeobj-process-buffer) |
| 1610 | 1731 | (progn |
| 1611 | 1732 | (switch-to-buffer (get-buffer-create (concat "*" cafeobj-application-name "*"))) |
| 1612 | (cafeobj-start-process cafeobj-application-name cafeobj-default-application) | |
| 1613 | ))) | |
| 1733 | ;; show cafeobj logo | |
| 1734 | (cafeobj-startup-message) | |
| 1735 | ;; start the process | |
| 1736 | (cafeobj-start-process cafeobj-application-name cafeobj-default-application)))) | |
| 1614 | 1737 | |
| 1615 | 1738 | (defun cafeobj-kill-process () |
| 1616 | 1739 | "Kill chaos subprocess and its buffer." |
| 1633 | 1756 | If `cafeobj-process' is nil or dead, start a new process first." |
| 1634 | 1757 | (interactive) |
| 1635 | 1758 | (let ((start (save-excursion (beginning-of-line) (point))) |
| 1636 | (end (save-excursion (end-of-line) (point)))) | |
| 1759 | (end (save-excursion (end-of-line) (point)))) | |
| 1637 | 1760 | (or (and cafeobj-process |
| 1638 | (eq (process-status cafeobj-process) 'run)) | |
| 1639 | (cafeobj-start-process cafeobj-application-name cafeobj-default-application)) | |
| 1761 | (eq (process-status cafeobj-process) 'run)) | |
| 1762 | (cafeobj-start-process cafeobj-application-name cafeobj-default-application)) | |
| 1640 | 1763 | (comint-simple-send cafeobj-process (buffer-substring start end)) |
| 1641 | 1764 | (forward-line 1) |
| 1642 | 1765 | (if cafeobj-always-show |
| 1643 | (display-buffer cafeobj-process-buffer)))) | |
| 1766 | (display-buffer cafeobj-process-buffer)))) | |
| 1644 | 1767 | |
| 1645 | 1768 | (defun cafeobj-send-region (start end) |
| 1646 | 1769 | "Send region to chaos subprocess." |
| 1647 | 1770 | (interactive "r") |
| 1648 | (or (and cafeobj-process | |
| 1649 | (comint-check-proc cafeobj-process-buffer)) | |
| 1650 | (cafeobj-start-process cafeobj-application-name cafeobj-default-application)) | |
| 1651 | (comint-simple-send cafeobj-process | |
| 1652 | (concat (buffer-substring start end) "\n")) | |
| 1653 | (if cafeobj-always-show | |
| 1654 | (display-buffer cafeobj-process-buffer))) | |
| 1771 | (when (and start end) | |
| 1772 | (or (and cafeobj-process | |
| 1773 | (comint-check-proc cafeobj-process-buffer)) | |
| 1774 | (cafeobj-start-process cafeobj-application-name cafeobj-default-application)) | |
| 1775 | (comint-simple-send cafeobj-process | |
| 1776 | (concat (buffer-substring start end) "\n")) | |
| 1777 | (if cafeobj-always-show | |
| 1778 | (display-buffer cafeobj-process-buffer)))) | |
| 1655 | 1779 | |
| 1656 | 1780 | (defun cafeobj-send-decl () |
| 1657 | 1781 | "Send proc around point to chaos subprocess." |
| 1663 | 1787 | (cafeobj-end-of-decl) |
| 1664 | 1788 | (setq end (point))) |
| 1665 | 1789 | (or (and cafeobj-process |
| 1666 | (comint-check-proc cafeobj-process-buffer)) | |
| 1667 | (cafeobj-start-process cafeobj-application-name cafeobj-default-application)) | |
| 1790 | (comint-check-proc cafeobj-process-buffer)) | |
| 1791 | (cafeobj-start-process cafeobj-application-name cafeobj-default-application)) | |
| 1668 | 1792 | (comint-simple-send cafeobj-process |
| 1669 | (concat (buffer-substring beg end) "\n")) | |
| 1793 | (concat (buffer-substring beg end) "\n")) | |
| 1670 | 1794 | (if cafeobj-always-show |
| 1671 | (display-buffer cafeobj-process-buffer)))) | |
| 1795 | (display-buffer cafeobj-process-buffer)))) | |
| 1672 | 1796 | |
| 1673 | 1797 | (defun cafeobj-send-buffer () |
| 1674 | 1798 | "Send whole buffer to chaos subprocess." |
| 1675 | 1799 | (interactive) |
| 1676 | 1800 | (or (and cafeobj-process |
| 1677 | (comint-check-proc cafeobj-process-buffer)) | |
| 1801 | (comint-check-proc cafeobj-process-buffer)) | |
| 1678 | 1802 | (cafeobj-start-process cafeobj-application-name cafeobj-default-application)) |
| 1679 | 1803 | (if (buffer-modified-p) |
| 1680 | 1804 | (comint-simple-send cafeobj-process |
| 1681 | (concat | |
| 1682 | (buffer-substring (point-min) (point-max)) | |
| 1683 | "\n")) | |
| 1805 | (concat | |
| 1806 | (buffer-substring (point-min) (point-max)) | |
| 1807 | "\n")) | |
| 1684 | 1808 | (comint-simple-send cafeobj-process |
| 1685 | (concat "input " | |
| 1686 | (buffer-file-name) | |
| 1687 | "\n"))) | |
| 1809 | (concat "input " | |
| 1810 | (buffer-file-name) | |
| 1811 | "\n"))) | |
| 1688 | 1812 | (if cafeobj-always-show |
| 1689 | 1813 | (display-buffer cafeobj-process-buffer))) |
| 1690 | 1814 | |
| 1755 | 1879 | (if cafeobj-dirtrackp |
| 1756 | 1880 | ;; We fail gracefully if we think the command will fail in the shell. |
| 1757 | 1881 | (condition-case chdir-failure |
| 1758 | (let ((start (progn (string-match "^[; \t]*" str) ; skip whitespace | |
| 1759 | (match-end 0))) | |
| 1760 | end cmd arg1) | |
| 1761 | (while (string-match cafeobj-command-regexp str start) | |
| 1762 | (setq end (match-end 0) | |
| 1763 | cmd (comint-arguments (substring str start end) 0 0) | |
| 1764 | arg1 (comint-arguments (substring str start end) 1 1)) | |
| 1765 | (cond ((string-match (concat "\\`\\(" cafeobj-popd-regexp | |
| 1766 | "\\)\\($\\|[ \t]\\)") | |
| 1767 | cmd) | |
| 1768 | (cafeobj-process-popd (comint-substitute-in-file-name arg1))) | |
| 1769 | ((string-match (concat "\\`\\(" cafeobj-pushd-regexp | |
| 1770 | "\\)\\($\\|[ \t]\\)") | |
| 1771 | cmd) | |
| 1772 | (cafeobj-process-pushd (comint-substitute-in-file-name arg1))) | |
| 1773 | ((string-match (concat "\\`\\(" cafeobj-cd-regexp | |
| 1774 | "\\)\\($\\|[ \t]\\)") | |
| 1775 | cmd) | |
| 1776 | (cafeobj-process-cd (comint-substitute-in-file-name arg1))) | |
| 1777 | ((and cafeobj-chdrive-regexp | |
| 1778 | (string-match (concat "\\`\\(" cafeobj-chdrive-regexp | |
| 1779 | "\\)\\($\\|[ \t]\\)") | |
| 1780 | cmd)) | |
| 1781 | (cafeobj-process-cd (comint-substitute-in-file-name cmd)))) | |
| 1782 | (setq start (progn (string-match "[; \t]*" str end) ; skip again | |
| 1783 | (match-end 0))))) | |
| 1882 | (let ((start (progn (string-match "^[; \t]*" str) ; skip whitespace | |
| 1883 | (match-end 0))) | |
| 1884 | end cmd arg1) | |
| 1885 | (while (string-match cafeobj-command-regexp str start) | |
| 1886 | (setq end (match-end 0) | |
| 1887 | cmd (comint-arguments (substring str start end) 0 0) | |
| 1888 | arg1 (comint-arguments (substring str start end) 1 1)) | |
| 1889 | (cond ((string-match (concat "\\`\\(" cafeobj-popd-regexp | |
| 1890 | "\\)\\($\\|[ \t]\\)") | |
| 1891 | cmd) | |
| 1892 | (cafeobj-process-popd (comint-substitute-in-file-name arg1))) | |
| 1893 | ((string-match (concat "\\`\\(" cafeobj-pushd-regexp | |
| 1894 | "\\)\\($\\|[ \t]\\)") | |
| 1895 | cmd) | |
| 1896 | (cafeobj-process-pushd (comint-substitute-in-file-name arg1))) | |
| 1897 | ((string-match (concat "\\`\\(" cafeobj-cd-regexp | |
| 1898 | "\\)\\($\\|[ \t]\\)") | |
| 1899 | cmd) | |
| 1900 | (cafeobj-process-cd (comint-substitute-in-file-name arg1))) | |
| 1901 | ((and cafeobj-chdrive-regexp | |
| 1902 | (string-match (concat "\\`\\(" cafeobj-chdrive-regexp | |
| 1903 | "\\)\\($\\|[ \t]\\)") | |
| 1904 | cmd)) | |
| 1905 | (cafeobj-process-cd (comint-substitute-in-file-name cmd)))) | |
| 1906 | (setq start (progn (string-match "[; \t]*" str end) ; skip again | |
| 1907 | (match-end 0))))) | |
| 1784 | 1908 | (error "Couldn't cd")))) |
| 1785 | 1909 | |
| 1786 | 1910 | |
| 1788 | 1912 | (defun cafeobj-cd-1 (dir dirstack) |
| 1789 | 1913 | (if cafeobj-dirtrackp |
| 1790 | 1914 | (setq list-buffers-directory (file-name-as-directory |
| 1791 | (expand-file-name dir)))) | |
| 1915 | (expand-file-name dir)))) | |
| 1792 | 1916 | (condition-case nil |
| 1793 | 1917 | (progn (if (file-name-absolute-p dir) |
| 1794 | 1918 | ;;(cd-absolute (concat comint-file-name-prefix dir)) |
| 1795 | (cd-absolute dir) | |
| 1796 | (cd dir)) | |
| 1919 | (cd-absolute dir) | |
| 1920 | (cd dir)) | |
| 1797 | 1921 | (setq cafeobj-dirstack dirstack) |
| 1798 | 1922 | (cafeobj-dirstack-message)) |
| 1799 | 1923 | (file-error (message "Couldn't cd.")))) |
| 1802 | 1926 | (defun cafeobj-process-popd (arg) |
| 1803 | 1927 | (let ((num (or (cafeobj-extract-num arg) 0))) |
| 1804 | 1928 | (cond ((and num (= num 0) cafeobj-dirstack) |
| 1805 | (cafeobj-cd-1 (car cafeobj-dirstack) (cdr cafeobj-dirstack))) | |
| 1806 | ((and num (> num 0) (<= num (length cafeobj-dirstack))) | |
| 1807 | (let* ((ds (cons nil cafeobj-dirstack)) | |
| 1808 | (cell (nthcdr (1- num) ds))) | |
| 1809 | (rplacd cell (cdr (cdr cell))) | |
| 1810 | (setq cafeobj-dirstack (cdr ds)) | |
| 1811 | (cafeobj-dirstack-message))) | |
| 1812 | (t | |
| 1813 | (error "Couldn't popd"))))) | |
| 1929 | (cafeobj-cd-1 (car cafeobj-dirstack) (cdr cafeobj-dirstack))) | |
| 1930 | ((and num (> num 0) (<= num (length cafeobj-dirstack))) | |
| 1931 | (let* ((ds (cons nil cafeobj-dirstack)) | |
| 1932 | (cell (nthcdr (1- num) ds))) | |
| 1933 | (rplacd cell (cdr (cdr cell))) | |
| 1934 | (setq cafeobj-dirstack (cdr ds)) | |
| 1935 | (cafeobj-dirstack-message))) | |
| 1936 | (t | |
| 1937 | (error "Couldn't popd"))))) | |
| 1814 | 1938 | |
| 1815 | 1939 | ;; Return DIR prefixed with comint-file-name-prefix as appropriate. |
| 1816 | 1940 | (defun cafeobj-prefixed-directory-name (dir) |
| 1817 | 1941 | (if (= (length comint-file-name-prefix) 0) |
| 1818 | 1942 | dir |
| 1819 | 1943 | (if (file-name-absolute-p dir) |
| 1820 | ;; The name is absolute, so prepend the prefix. | |
| 1821 | (concat comint-file-name-prefix dir) | |
| 1944 | ;; The name is absolute, so prepend the prefix. | |
| 1945 | (concat comint-file-name-prefix dir) | |
| 1822 | 1946 | ;; For relative name we assume default-directory already has the prefix. |
| 1823 | 1947 | (expand-file-name dir)))) |
| 1824 | 1948 | |
| 1825 | 1949 | ;;; cd [dir] |
| 1826 | 1950 | (defun cafeobj-process-cd (arg) |
| 1827 | 1951 | (let ((new-dir (cond ((zerop (length arg)) (concat comint-file-name-prefix |
| 1828 | "~")) | |
| 1829 | ((string-equal "-" arg) cafeobj-last-dir) | |
| 1830 | (t (cafeobj-prefixed-directory-name arg))))) | |
| 1952 | "~")) | |
| 1953 | ((string-equal "-" arg) cafeobj-last-dir) | |
| 1954 | (t (cafeobj-prefixed-directory-name arg))))) | |
| 1831 | 1955 | (setq cafeobj-last-dir default-directory) |
| 1832 | 1956 | (cafeobj-cd-1 new-dir cafeobj-dirstack))) |
| 1833 | 1957 | |
| 1835 | 1959 | (defun cafeobj-process-pushd (arg) |
| 1836 | 1960 | (let ((num (cafeobj-extract-num arg))) |
| 1837 | 1961 | (cond ((zerop (length arg)) |
| 1838 | ;; no arg -- swap pwd and car of stack unless cafeobj-pushd-tohome | |
| 1839 | (cond (cafeobj-pushd-tohome | |
| 1840 | (cafeobj-process-pushd (concat comint-file-name-prefix "~"))) | |
| 1841 | (cafeobj-dirstack | |
| 1842 | (let ((old default-directory)) | |
| 1843 | (cafeobj-cd-1 (car cafeobj-dirstack) | |
| 1844 | (cons old (cdr cafeobj-dirstack))))) | |
| 1845 | (t | |
| 1846 | (message "Directory stack empty.")))) | |
| 1847 | ((numberp num) | |
| 1848 | ;; pushd +n | |
| 1849 | (cond ((> num (length cafeobj-dirstack)) | |
| 1850 | (message "Directory stack not that deep.")) | |
| 1851 | ((= num 0) | |
| 1852 | (error (message "Couldn't cd."))) | |
| 1853 | (cafeobj-pushd-dextract | |
| 1854 | (let ((dir (nth (1- num) cafeobj-dirstack))) | |
| 1855 | (cafeobj-process-popd arg) | |
| 1856 | (cafeobj-process-pushd default-directory) | |
| 1857 | (cafeobj-cd-1 dir cafeobj-dirstack))) | |
| 1858 | (t | |
| 1859 | (let* ((ds (cons default-directory cafeobj-dirstack)) | |
| 1860 | (dslen (length ds)) | |
| 1861 | (front (nthcdr num ds)) | |
| 1862 | (back (reverse (nthcdr (- dslen num) (reverse ds)))) | |
| 1863 | (new-ds (append front back))) | |
| 1864 | (cafeobj-cd-1 (car new-ds) (cdr new-ds)))))) | |
| 1865 | (t | |
| 1866 | ;; pushd <dir> | |
| 1867 | (let ((old-wd default-directory)) | |
| 1962 | ;; no arg -- swap pwd and car of stack unless cafeobj-pushd-tohome | |
| 1963 | (cond (cafeobj-pushd-tohome | |
| 1964 | (cafeobj-process-pushd (concat comint-file-name-prefix "~"))) | |
| 1965 | (cafeobj-dirstack | |
| 1966 | (let ((old default-directory)) | |
| 1967 | (cafeobj-cd-1 (car cafeobj-dirstack) | |
| 1968 | (cons old (cdr cafeobj-dirstack))))) | |
| 1969 | (t | |
| 1970 | (message "Directory stack empty.")))) | |
| 1971 | ((numberp num) | |
| 1972 | ;; pushd +n | |
| 1973 | (cond ((> num (length cafeobj-dirstack)) | |
| 1974 | (message "Directory stack not that deep.")) | |
| 1975 | ((= num 0) | |
| 1976 | (error (message "Couldn't cd."))) | |
| 1977 | (cafeobj-pushd-dextract | |
| 1978 | (let ((dir (nth (1- num) cafeobj-dirstack))) | |
| 1979 | (cafeobj-process-popd arg) | |
| 1980 | (cafeobj-process-pushd default-directory) | |
| 1981 | (cafeobj-cd-1 dir cafeobj-dirstack))) | |
| 1982 | (t | |
| 1983 | (let* ((ds (cons default-directory cafeobj-dirstack)) | |
| 1984 | (dslen (length ds)) | |
| 1985 | (front (nthcdr num ds)) | |
| 1986 | (back (reverse (nthcdr (- dslen num) (reverse ds)))) | |
| 1987 | (new-ds (append front back))) | |
| 1988 | (cafeobj-cd-1 (car new-ds) (cdr new-ds)))))) | |
| 1989 | (t | |
| 1990 | ;; pushd <dir> | |
| 1991 | (let ((old-wd default-directory)) | |
| 1868 | 1992 | (cafeobj-cd-1 (cafeobj-prefixed-directory-name arg) |
| 1869 | 1993 | (if (or (null cafeobj-pushd-dunique) |
| 1870 | 1994 | (not (member old-wd cafeobj-dirstack))) |
| 1891 | 2015 | "Do normal `cd' to DIR, and set `list-buffers-directory'." |
| 1892 | 2016 | (if cafeobj-dirtrackp |
| 1893 | 2017 | (setq list-buffers-directory (file-name-as-directory |
| 1894 | (expand-file-name dir)))) | |
| 2018 | (expand-file-name dir)))) | |
| 1895 | 2019 | (cd dir)) |
| 1896 | 2020 | |
| 1897 | 2021 | (defun cafeobj-resync-dirs () |
| 1906 | 2030 | command again." |
| 1907 | 2031 | (interactive) |
| 1908 | 2032 | (let* ((proc (get-buffer-process (current-buffer))) |
| 1909 | (pmark (process-mark proc))) | |
| 2033 | (pmark (process-mark proc))) | |
| 1910 | 2034 | (goto-char pmark) |
| 1911 | 2035 | (insert cafeobj-dirstack-query) (insert "\n") |
| 1912 | 2036 | (sit-for 0) ; force redisplay |
| 1917 | 2041 | ;; This extra newline prevents the user's pending input from spoofing us. |
| 1918 | 2042 | (insert "\n") (backward-char 1) |
| 1919 | 2043 | (while (not (looking-at ".+\n")) |
| 1920 | (accept-process-output proc) | |
| 1921 | (goto-char pt) | |
| 1922 | ;; kludge to cope with shells that have "stty echo" turned on. | |
| 1923 | ;; of course this will lose if there is only one dir on the stack | |
| 1924 | ;; and it is named "dirs"... -jwz | |
| 1925 | (if (looking-at "^dirs\r?\n") (delete-region (point) (match-end 0))) | |
| 1926 | )) | |
| 2044 | (accept-process-output proc) | |
| 2045 | (goto-char pt) | |
| 2046 | ;; kludge to cope with shells that have "stty echo" turned on. | |
| 2047 | ;; of course this will lose if there is only one dir on the stack | |
| 2048 | ;; and it is named "dirs"... -jwz | |
| 2049 | (if (looking-at "^dirs\r?\n") (delete-region (point) (match-end 0))) | |
| 2050 | )) | |
| 1927 | 2051 | (goto-char pmark) (delete-char 1) ; remove the extra newline |
| 1928 | 2052 | ;; That's the dirlist. grab it & parse it. |
| 1929 | 2053 | (let* ((dl (buffer-substring (match-beginning 0) (1- (match-end 0)))) |
| 1930 | (dl-len (length dl)) | |
| 1931 | (ds '()) ; new dir stack | |
| 1932 | (i 0)) | |
| 2054 | (dl-len (length dl)) | |
| 2055 | (ds '()) ; new dir stack | |
| 2056 | (i 0)) | |
| 1933 | 2057 | (while (< i dl-len) |
| 1934 | ;; regexp = optional whitespace, (non-whitespace), optional whitespace | |
| 1935 | (string-match "\\s *\\(\\S +\\)\\s *" dl i) ; pick off next dir | |
| 1936 | (setq ds (cons (concat comint-file-name-prefix | |
| 1937 | (substring dl (match-beginning 1) | |
| 1938 | (match-end 1))) | |
| 1939 | ds)) | |
| 1940 | (setq i (match-end 0))) | |
| 2058 | ;; regexp = optional whitespace, (non-whitespace), optional whitespace | |
| 2059 | (string-match "\\s *\\(\\S +\\)\\s *" dl i) ; pick off next dir | |
| 2060 | (setq ds (cons (concat comint-file-name-prefix | |
| 2061 | (substring dl (match-beginning 1) | |
| 2062 | (match-end 1))) | |
| 2063 | ds)) | |
| 2064 | (setq i (match-end 0))) | |
| 1941 | 2065 | (let ((ds (reverse ds))) |
| 1942 | 2066 | (cafeobj-cd-1 (car ds) (cdr ds)))))) |
| 1943 | 2067 | |
| 1960 | 2084 | (let* ((msg "") |
| 1961 | 2085 | (ds (cons default-directory cafeobj-dirstack)) |
| 1962 | 2086 | (home (if cafeobj-xemacs-p |
| 1963 | (format "^%s\\(/\\|$\\)" | |
| 1964 | (regexp-quote (user-home-directory))) | |
| 1965 | abbreviated-home-dir)) | |
| 2087 | (format "^%s\\(/\\|$\\)" | |
| 2088 | (regexp-quote (user-home-directory))) | |
| 2089 | abbreviated-home-dir)) | |
| 1966 | 2090 | (prefix (and comint-file-name-prefix |
| 1967 | ;; XEmacs addition: don't turn "/foo" into "foo" !! | |
| 1968 | (not (= 0 (length comint-file-name-prefix))) | |
| 2091 | ;; XEmacs addition: don't turn "/foo" into "foo" !! | |
| 2092 | (not (= 0 (length comint-file-name-prefix))) | |
| 1969 | 2093 | (format "^%s\\(/\\|$\\)" |
| 1970 | 2094 | (regexp-quote comint-file-name-prefix))))) |
| 1971 | 2095 | (while ds |
| 1972 | 2096 | (let ((dir (car ds))) |
| 1973 | (if (string-match home dir) | |
| 1974 | (setq dir (concat "~/" (substring dir (match-end 0))))) | |
| 1975 | ;; Strip off comint-file-name-prefix if present. | |
| 1976 | (and prefix (string-match prefix dir) | |
| 1977 | (setq dir (substring dir (match-end 0))) | |
| 2097 | (if (string-match home dir) | |
| 2098 | (setq dir (concat "~/" (substring dir (match-end 0))))) | |
| 2099 | ;; Strip off comint-file-name-prefix if present. | |
| 2100 | (and prefix (string-match prefix dir) | |
| 2101 | (setq dir (substring dir (match-end 0))) | |
| 1978 | 2102 | (setcar ds dir) |
| 1979 | 2103 | ) |
| 1980 | (setq msg (concat msg dir " ")) | |
| 1981 | (setq ds (cdr ds)))) | |
| 2104 | (setq msg (concat msg dir " ")) | |
| 2105 | (setq ds (cdr ds)))) | |
| 1982 | 2106 | (run-hooks 'cafeobj-dirstack-message-hook) |
| 1983 | 2107 | (message "%s" msg))) |
| 1984 | 2108 | |
| 1986 | 2110 | (defun cafeobj-snarf-envar (var) |
| 1987 | 2111 | "Return as a string the shell's value of environment variable VAR." |
| 1988 | 2112 | (let* ((cmd (format "printenv '%s'\n" var)) |
| 1989 | (proc (get-buffer-process (current-buffer))) | |
| 1990 | (pmark (process-mark proc))) | |
| 2113 | (proc (get-buffer-process (current-buffer))) | |
| 2114 | (pmark (process-mark proc))) | |
| 1991 | 2115 | (goto-char pmark) |
| 1992 | 2116 | (insert cmd) |
| 1993 | (sit-for 0) ; force redisplay | |
| 2117 | (sit-for 0) ; force redisplay | |
| 1994 | 2118 | (comint-send-string proc cmd) |
| 1995 | 2119 | (set-marker pmark (point)) |
| 1996 | (let ((pt (point))) ; wait for 1 line | |
| 2120 | (let ((pt (point))) ; wait for 1 line | |
| 1997 | 2121 | ;; This extra newline prevents the user's pending input from spoofing us. |
| 1998 | 2122 | (insert "\n") (backward-char 1) |
| 1999 | 2123 | (while (not (looking-at ".+\n")) |
| 2000 | (accept-process-output proc) | |
| 2001 | (goto-char pt))) | |
| 2002 | (goto-char pmark) (delete-char 1) ; remove the extra newline | |
| 2124 | (accept-process-output proc) | |
| 2125 | (goto-char pt))) | |
| 2126 | (goto-char pmark) (delete-char 1) ; remove the extra newline | |
| 2003 | 2127 | (buffer-substring (match-beginning 0) (1- (match-end 0))))) |
| 2004 | 2128 | |
| 2005 | 2129 | (defun cafeobj-copy-environment-variable (variable) |
| 2019 | 2143 | (interactive "p") |
| 2020 | 2144 | (let ((limit (save-excursion (end-of-line nil) (point)))) |
| 2021 | 2145 | (if (re-search-forward (concat cafeobj-command-regexp "\\([;&|][\t ]*\\)+") |
| 2022 | limit 'move arg) | |
| 2023 | (skip-syntax-backward " ")))) | |
| 2146 | limit 'move arg) | |
| 2147 | (skip-syntax-backward " ")))) | |
| 2024 | 2148 | |
| 2025 | 2149 | |
| 2026 | 2150 | (defun cafeobj-backward-command (&optional arg) |
| 2029 | 2153 | (interactive "p") |
| 2030 | 2154 | (let ((limit (save-excursion (comint-bol nil) (point)))) |
| 2031 | 2155 | (if (> limit (point)) |
| 2032 | (save-excursion (beginning-of-line) (setq limit (point)))) | |
| 2156 | (save-excursion (beginning-of-line) (setq limit (point)))) | |
| 2033 | 2157 | (skip-syntax-backward " " limit) |
| 2034 | 2158 | (if (re-search-backward |
| 2035 | (format "[;&|]+[\t ]*\\(%s\\)" cafeobj-command-regexp) limit 'move arg) | |
| 2036 | (progn (goto-char (match-beginning 1)) | |
| 2037 | (skip-chars-forward ";&|"))))) | |
| 2038 | ||
| 2159 | (format "[;&|]+[\t ]*\\(%s\\)" cafeobj-command-regexp) limit 'move arg) | |
| 2160 | (progn (goto-char (match-beginning 1)) | |
| 2161 | (skip-chars-forward ";&|"))))) | |
| 2162 | ||
| 2163 | (defvar esc-esc "") | |
| 2164 | ||
| 2165 | (defun cafeobj-put-esc-esc () | |
| 2166 | "send EscEsc to CafeOBJ process. This makes the interpeter | |
| 2167 | to cancel current input." | |
| 2168 | (interactive) | |
| 2169 | (let* ((proc (get-buffer-process (current-buffer))) | |
| 2170 | (pmark (process-mark proc))) | |
| 2171 | (goto-char pmark) | |
| 2172 | (comint-send-string proc esc-esc) | |
| 2173 | (comint-send-string proc "\n") | |
| 2174 | (set-marker pmark (point)))) | |
| 2039 | 2175 | |
| 2040 | 2176 | (defun cafeobj-dynamic-complete-command () |
| 2041 | 2177 | "Dynamically complete the command at point. |
| 2048 | 2184 | (interactive) |
| 2049 | 2185 | (let ((filename (comint-match-partial-filename))) |
| 2050 | 2186 | (if (and filename |
| 2051 | (save-match-data (not (string-match "[~/]" filename))) | |
| 2052 | (eq (match-beginning 0) | |
| 2053 | (save-excursion (cafeobj-backward-command 1) (point)))) | |
| 2054 | (prog2 (message "Completing command name...") | |
| 2055 | (cafeobj-dynamic-complete-as-command))))) | |
| 2187 | (save-match-data (not (string-match "[~/]" filename))) | |
| 2188 | (eq (match-beginning 0) | |
| 2189 | (save-excursion (cafeobj-backward-command 1) (point)))) | |
| 2190 | (prog2 (message "Completing command name...") | |
| 2191 | (cafeobj-dynamic-complete-as-command))))) | |
| 2056 | 2192 | |
| 2057 | 2193 | |
| 2058 | 2194 | (defun cafeobj-dynamic-complete-as-command () |
| 2059 | 2195 | "Dynamically complete at point as a command. |
| 2060 | 2196 | See `cafeobj-dynamic-complete-filename'. Returns t if successful." |
| 2061 | 2197 | (let* ((filename (or (comint-match-partial-filename) "")) |
| 2062 | (pathnondir (file-name-nondirectory filename)) | |
| 2063 | (paths (cdr (reverse exec-path))) | |
| 2064 | (cwd (file-name-as-directory (expand-file-name default-directory))) | |
| 2065 | (ignored-extensions | |
| 2066 | (and comint-completion-fignore | |
| 2067 | (mapconcat (function (lambda (x) (concat (regexp-quote x) "$"))) | |
| 2068 | comint-completion-fignore "\\|"))) | |
| 2069 | (path "") (comps-in-path ()) (file "") (filepath "") (completions ())) | |
| 2198 | (pathnondir (file-name-nondirectory filename)) | |
| 2199 | (paths (cdr (reverse exec-path))) | |
| 2200 | (cwd (file-name-as-directory (expand-file-name default-directory))) | |
| 2201 | (ignored-extensions | |
| 2202 | (and comint-completion-fignore | |
| 2203 | (mapconcat (function (lambda (x) (concat (regexp-quote x) "$"))) | |
| 2204 | comint-completion-fignore "\\|"))) | |
| 2205 | (path "") (comps-in-path ()) (file "") (filepath "") (completions ())) | |
| 2070 | 2206 | ;; Go thru each path in the search path, finding completions. |
| 2071 | 2207 | (while paths |
| 2072 | 2208 | (setq path (file-name-as-directory (comint-directory (or (car paths) "."))) |
| 2073 | comps-in-path (and (file-accessible-directory-p path) | |
| 2074 | (file-name-all-completions pathnondir path))) | |
| 2209 | comps-in-path (and (file-accessible-directory-p path) | |
| 2210 | (file-name-all-completions pathnondir path))) | |
| 2075 | 2211 | ;; Go thru each completion found, to see whether it should be used. |
| 2076 | 2212 | (while comps-in-path |
| 2077 | (setq file (car comps-in-path) | |
| 2078 | filepath (concat path file)) | |
| 2079 | (if (and (not (member file completions)) | |
| 2080 | (not (and ignored-extensions | |
| 2081 | (string-match ignored-extensions file))) | |
| 2082 | (or (string-equal path cwd) | |
| 2083 | (not (file-directory-p filepath))) | |
| 2084 | ) | |
| 2085 | (setq completions (cons file completions))) | |
| 2086 | (setq comps-in-path (cdr comps-in-path))) | |
| 2213 | (setq file (car comps-in-path) | |
| 2214 | filepath (concat path file)) | |
| 2215 | (if (and (not (member file completions)) | |
| 2216 | (not (and ignored-extensions | |
| 2217 | (string-match ignored-extensions file))) | |
| 2218 | (or (string-equal path cwd) | |
| 2219 | (not (file-directory-p filepath))) | |
| 2220 | ) | |
| 2221 | (setq completions (cons file completions))) | |
| 2222 | (setq comps-in-path (cdr comps-in-path))) | |
| 2087 | 2223 | (setq paths (cdr paths))) |
| 2088 | 2224 | ;; OK, we've got a list of completions. |
| 2089 | 2225 | (let ((success (let ((comint-completion-addsuffix nil)) |
| 2090 | (comint-dynamic-simple-complete pathnondir completions)))) | |
| 2226 | (comint-dynamic-simple-complete pathnondir completions)))) | |
| 2091 | 2227 | (if (and (memq success '(sole shortest)) comint-completion-addsuffix |
| 2092 | (not (file-directory-p (comint-match-partial-filename)))) | |
| 2093 | (insert " ")) | |
| 2228 | (not (file-directory-p (comint-match-partial-filename)))) | |
| 2229 | (insert " ")) | |
| 2094 | 2230 | success))) |
| 2095 | 2231 | |
| 2096 | 2232 | (defun cafeobj-dynamic-complete-filename () |
| 2099 | 2235 | filename argument." |
| 2100 | 2236 | (interactive) |
| 2101 | 2237 | (let ((opoint (point)) |
| 2102 | (beg (comint-line-beginning-position))) | |
| 2238 | (beg (comint-line-beginning-position))) | |
| 2103 | 2239 | (when (save-excursion |
| 2104 | (goto-char (if (re-search-backward "[;|&]" beg t) | |
| 2105 | (match-end 0) | |
| 2106 | beg)) | |
| 2107 | (re-search-forward "[^ \t][ \t]" opoint t)) | |
| 2240 | (goto-char (if (re-search-backward "[;|&]" beg t) | |
| 2241 | (match-end 0) | |
| 2242 | beg)) | |
| 2243 | (re-search-forward "[^ \t][ \t]" opoint t)) | |
| 2108 | 2244 | (comint-dynamic-complete-as-filename)))) |
| 2109 | 2245 | |
| 2110 | 2246 | (defun cafeobj-match-partial-variable () |
| 2112 | 2248 | (save-excursion |
| 2113 | 2249 | (let ((limit (point))) |
| 2114 | 2250 | (if (re-search-backward "[^A-Za-z0-9_{}]" nil 'move) |
| 2115 | (or (looking-at "\\$") (forward-char 1))) | |
| 2251 | (or (looking-at "\\$") (forward-char 1))) | |
| 2116 | 2252 | ;; Anchor the search forwards. |
| 2117 | 2253 | (if (or (eolp) (looking-at "[^A-Za-z0-9_{}$]")) |
| 2118 | nil | |
| 2119 | (re-search-forward "\\$?{?[A-Za-z0-9_]*}?" limit) | |
| 2120 | (buffer-substring (match-beginning 0) (match-end 0)))))) | |
| 2254 | nil | |
| 2255 | (re-search-forward "\\$?{?[A-Za-z0-9_]*}?" limit) | |
| 2256 | (buffer-substring (match-beginning 0) (match-end 0)))))) | |
| 2121 | 2257 | |
| 2122 | 2258 | |
| 2123 | 2259 | (defun cafeobj-dynamic-complete-environment-variable () |
| 2137 | 2273 | (interactive) |
| 2138 | 2274 | (let ((variable (cafeobj-match-partial-variable))) |
| 2139 | 2275 | (if (and variable (string-match "^\\$" variable)) |
| 2140 | (prog2 (message "Completing variable name...") | |
| 2141 | (cafeobj-dynamic-complete-as-environment-variable))))) | |
| 2276 | (prog2 (message "Completing variable name...") | |
| 2277 | (cafeobj-dynamic-complete-as-environment-variable))))) | |
| 2142 | 2278 | |
| 2143 | 2279 | |
| 2144 | 2280 | (defun cafeobj-dynamic-complete-as-environment-variable () |
| 2146 | 2282 | Used by `cafeobj-dynamic-complete-environment-variable'. |
| 2147 | 2283 | Uses `comint-dynamic-simple-complete'." |
| 2148 | 2284 | (let* ((var (or (cafeobj-match-partial-variable) "")) |
| 2149 | (variable (substring var (or (string-match "[^$({]\\|$" var) 0))) | |
| 2150 | (variables (mapcar (function (lambda (x) | |
| 2151 | (substring x 0 (string-match "=" x)))) | |
| 2152 | process-environment)) | |
| 2153 | (addsuffix comint-completion-addsuffix) | |
| 2154 | (comint-completion-addsuffix nil) | |
| 2155 | (success (comint-dynamic-simple-complete variable variables))) | |
| 2285 | (variable (substring var (or (string-match "[^$({]\\|$" var) 0))) | |
| 2286 | (variables (mapcar (function (lambda (x) | |
| 2287 | (substring x 0 (string-match "=" x)))) | |
| 2288 | process-environment)) | |
| 2289 | (addsuffix comint-completion-addsuffix) | |
| 2290 | (comint-completion-addsuffix nil) | |
| 2291 | (success (comint-dynamic-simple-complete variable variables))) | |
| 2156 | 2292 | (if (memq success '(sole shortest)) |
| 2157 | (let* ((var (cafeobj-match-partial-variable)) | |
| 2158 | (variable (substring var (string-match "[^$({]" var))) | |
| 2159 | (protection (cond ((string-match "{" var) "}") | |
| 2160 | ((string-match "(" var) ")") | |
| 2161 | (t ""))) | |
| 2162 | (suffix (cond ((null addsuffix) "") | |
| 2163 | ((file-directory-p | |
| 2164 | (comint-directory (getenv variable))) "/") | |
| 2165 | (t " ")))) | |
| 2166 | (insert protection suffix))) | |
| 2293 | (let* ((var (cafeobj-match-partial-variable)) | |
| 2294 | (variable (substring var (string-match "[^$({]" var))) | |
| 2295 | (protection (cond ((string-match "{" var) "}") | |
| 2296 | ((string-match "(" var) ")") | |
| 2297 | (t ""))) | |
| 2298 | (suffix (cond ((null addsuffix) "") | |
| 2299 | ((file-directory-p | |
| 2300 | (comint-directory (getenv variable))) "/") | |
| 2301 | (t " ")))) | |
| 2302 | (insert protection suffix))) | |
| 2167 | 2303 | success)) |
| 2168 | 2304 | |
| 2169 | 2305 | |
| 2176 | 2312 | (interactive) |
| 2177 | 2313 | (if (comint-match-partial-filename) |
| 2178 | 2314 | (save-excursion |
| 2179 | (goto-char (match-beginning 0)) | |
| 2180 | (let ((stack (cons default-directory cafeobj-dirstack)) | |
| 2181 | (index (cond ((looking-at "=-/?") | |
| 2182 | (length cafeobj-dirstack)) | |
| 2183 | ((looking-at "=\\([0-9]+\\)") | |
| 2184 | (string-to-number | |
| 2185 | (buffer-substring | |
| 2186 | (match-beginning 1) (match-end 1))))))) | |
| 2187 | (cond ((null index) | |
| 2188 | nil) | |
| 2189 | ((>= index (length stack)) | |
| 2190 | (error "Directory stack not that deep.")) | |
| 2191 | (t | |
| 2192 | (replace-match (file-name-as-directory (nth index stack)) t t) | |
| 2193 | (message "Directory item: %d" index) | |
| 2194 | t)))))) | |
| 2315 | (goto-char (match-beginning 0)) | |
| 2316 | (let ((stack (cons default-directory cafeobj-dirstack)) | |
| 2317 | (index (cond ((looking-at "=-/?") | |
| 2318 | (length cafeobj-dirstack)) | |
| 2319 | ((looking-at "=\\([0-9]+\\)") | |
| 2320 | (string-to-number | |
| 2321 | (buffer-substring | |
| 2322 | (match-beginning 1) (match-end 1))))))) | |
| 2323 | (cond ((null index) | |
| 2324 | nil) | |
| 2325 | ((>= index (length stack)) | |
| 2326 | (error "Directory stack not that deep.")) | |
| 2327 | (t | |
| 2328 | (replace-match (file-name-as-directory (nth index stack)) t t) | |
| 2329 | (message "Directory item: %d" index) | |
| 2330 | t)))))) | |
| 2195 | 2331 | |
| 2196 | 2332 | |
| 2197 | 2333 | |
| 2205 | 2341 | (defcustom cafeobj-glyph-directory "/usr/local/cafeobj-1.4/icons" |
| 2206 | 2342 | "Directory where CafeOBJ logos and icons are located." |
| 2207 | 2343 | :type '(choice (const :tag "autodetect" nil) |
| 2208 | directory) | |
| 2344 | directory) | |
| 2209 | 2345 | :group 'cafeobj) |
| 2210 | 2346 | |
| 2211 | 2347 | (defvar cafeobj-xmas-logo-color-alist |
| 2226 | 2362 | (defcustom cafeobj-xmas-logo-color-style 'moss |
| 2227 | 2363 | "*Color styles used for the CafeOBJ logo." |
| 2228 | 2364 | :type '(choice (const flame) (const pine) (const moss) |
| 2229 | (const irish) (const sky) (const tin) | |
| 2230 | (const velvet) (const grape) (const labia) | |
| 2231 | (const berry) (const neutral) (const september)) | |
| 2365 | (const irish) (const sky) (const tin) | |
| 2366 | (const velvet) (const grape) (const labia) | |
| 2367 | (const berry) (const neutral) (const september)) | |
| 2232 | 2368 | :group 'cafeobj-xmas) |
| 2233 | 2369 | |
| 2234 | 2370 | (defvar cafeobj-xmas-logo-colors |
| 2245 | 2381 | ;; (erase-buffer) |
| 2246 | 2382 | ;; (cond |
| 2247 | 2383 | ;; ((and (console-on-window-system-p) |
| 2248 | ;; (or (featurep 'xpm) | |
| 2249 | ;; (featurep 'xbm))) | |
| 2384 | ;; (or (featurep 'xpm) | |
| 2385 | ;; (featurep 'xbm))) | |
| 2250 | 2386 | ;; (let* ((logo-xpm (expand-file-name "cafe-logo.xpm" cafeobj-glyph-directory)) |
| 2251 | ;; (logo-xbm (expand-file-name "cafe-logo.xbm" cafeobj-glyph-directory)) | |
| 2252 | ;; (glyph (make-glyph | |
| 2253 | ;; (cond ((featurep 'xpm) | |
| 2254 | ;; `[xpm | |
| 2255 | ;; :file ,logo-xpm | |
| 2256 | ;; :color-symbols | |
| 2257 | ;; (("thing" . ,(car cafeobj-xmas-logo-colors)) | |
| 2258 | ;; ("shadow" . ,(cadr cafeobj-xmas-logo-colors)) | |
| 2259 | ;; ("background" . ,(face-background 'default)))]) | |
| 2260 | ;; ((featurep 'xbm) | |
| 2261 | ;; `[xbm :file ,logo-xbm]) | |
| 2262 | ;; (t [nothing])))) | |
| 2263 | ;; (char-per-pixel | |
| 2264 | ;; (/ (* 1.0 (window-width)) (window-pixel-width))) | |
| 2265 | ;; ) | |
| 2387 | ;; (logo-xbm (expand-file-name "cafe-logo.xbm" cafeobj-glyph-directory)) | |
| 2388 | ;; (glyph (make-glyph | |
| 2389 | ;; (cond ((featurep 'xpm) | |
| 2390 | ;; `[xpm | |
| 2391 | ;; :file ,logo-xpm | |
| 2392 | ;; :color-symbols | |
| 2393 | ;; (("thing" . ,(car cafeobj-xmas-logo-colors)) | |
| 2394 | ;; ("shadow" . ,(cadr cafeobj-xmas-logo-colors)) | |
| 2395 | ;; ("background" . ,(face-background 'default)))]) | |
| 2396 | ;; ((featurep 'xbm) | |
| 2397 | ;; `[xbm :file ,logo-xbm]) | |
| 2398 | ;; (t [nothing])))) | |
| 2399 | ;; (char-per-pixel | |
| 2400 | ;; (/ (* 1.0 (window-width)) (window-pixel-width))) | |
| 2401 | ;; ) | |
| 2266 | 2402 | ;; (insert " ") |
| 2267 | 2403 | ;; (set-extent-begin-glyph (make-extent (point) (point)) glyph) |
| 2268 | 2404 | ;; (goto-char (point-min)) |
| 2269 | 2405 | ;; (while (not (eobp)) |
| 2270 | ;; (insert (make-string (truncate | |
| 2271 | ;; (* (/ (max (- (window-pixel-width) | |
| 2272 | ;; (or x | |
| 2273 | ;; (car cafeobj-xpm-size))) | |
| 2274 | ;; 0) | |
| 2275 | ;; 2) | |
| 2276 | ;; char-per-pixel)) | |
| 2277 | ;; ?\ )) | |
| 2278 | ;; (forward-line 1)) | |
| 2406 | ;; (insert (make-string (truncate | |
| 2407 | ;; (* (/ (max (- (window-pixel-width) | |
| 2408 | ;; (or x | |
| 2409 | ;; (car cafeobj-xpm-size))) | |
| 2410 | ;; 0) | |
| 2411 | ;; 2) | |
| 2412 | ;; char-per-pixel)) | |
| 2413 | ;; ?\ )) | |
| 2414 | ;; (forward-line 1)) | |
| 2279 | 2415 | ;; ))) |
| 2280 | 2416 | ;; ;; |
| 2281 | 2417 | ;; (goto-char (point-max)) |
| 0 | 0 | -- |
| 1 | -- Copyright (c) 2000-2014, Toshimi Sawada. All rights reserved. | |
| 1 | -- Copyright (c) 2000-2015, Toshimi Sawada. All rights reserved. | |
| 2 | 2 | -- |
| 3 | 3 | -- Redistribution and use in source and binary forms, with or without |
| 4 | 4 | -- modification, are permitted provided that the following conditions |
Binary diff not shown
Binary diff not shown
| 0 | 0 | ** |
| 1 | ** Copyright (c) 2000-2014, Toshimi Sawada. All rights reserved. | |
| 1 | ** Copyright (c) 2000-2015, Toshimi Sawada. All rights reserved. | |
| 2 | 2 | ** |
| 3 | 3 | ** Redistribution and use in source and binary forms, with or without |
| 4 | 4 | ** modification, are permitted provided that the following conditions |
| 0 | 0 | ** |
| 1 | ** Copyright (c) 2000-2014, Toshimi Sawada. All rights reserved. | |
| 1 | ** Copyright (c) 2000-2015, Toshimi Sawada. All rights reserved. | |
| 2 | 2 | ** |
| 3 | 3 | ** Redistribution and use in source and binary forms, with or without |
| 4 | 4 | ** modification, are permitted provided that the following conditions |
| 0 | 0 | ** |
| 1 | ** Copyright (c) 2000-2014, Toshimi Sawada. All rights reserved. | |
| 1 | ** Copyright (c) 2000-2015, Toshimi Sawada. All rights reserved. | |
| 2 | 2 | ** |
| 3 | 3 | ** Redistribution and use in source and binary forms, with or without |
| 4 | 4 | ** modification, are permitted provided that the following conditions |
| 1 | 1 | ** MODULE BASE-BOOL |
| 2 | 2 | ** |
| 3 | 3 | ** |
| 4 | ** Copyright (c) 2000-2014, Toshimi Sawada. All rights reserved. | |
| 4 | ** Copyright (c) 2000-2015, Toshimi Sawada. All rights reserved. | |
| 5 | 5 | ** |
| 6 | 6 | ** Redistribution and use in source and binary forms, with or without |
| 7 | 7 | ** modification, are permitted provided that the following conditions |
| 2 | 2 | ** module: library |
| 3 | 3 | ** file: bool.mod |
| 4 | 4 | ** |
| 5 | ** Copyright (c) 2000-2014, Toshimi Sawada. All rights reserved. | |
| 5 | ** Copyright (c) 2000-2015, Toshimi Sawada. All rights reserved. | |
| 6 | 6 | ** |
| 7 | 7 | ** Redistribution and use in source and binary forms, with or without |
| 8 | 8 | ** modification, are permitted provided that the following conditions |
| 0 | 0 | ** |
| 1 | ** Copyright (c) 2000-2014, Toshimi Sawada. All rights reserved. | |
| 1 | ** Copyright (c) 2000-2015, Toshimi Sawada. All rights reserved. | |
| 2 | 2 | ** |
| 3 | 3 | ** Redistribution and use in source and binary forms, with or without |
| 4 | 4 | ** modification, are permitted provided that the following conditions |
| 2 | 2 | ** module: library |
| 3 | 3 | ** file: eql.mod |
| 4 | 4 | ** |
| 5 | ** Copyright (c) 2000-2014, Toshimi Sawada. All rights reserved. | |
| 5 | ** Copyright (c) 2000-2015, Toshimi Sawada. All rights reserved. | |
| 6 | 6 | ** |
| 7 | 7 | ** Redistribution and use in source and binary forms, with or without |
| 8 | 8 | ** modification, are permitted provided that the following conditions |
| 0 | 0 | ** |
| 1 | ** Copyright (c) 2000-2014, Toshimi Sawada. All rights reserved. | |
| 1 | ** Copyright (c) 2000-2015, Toshimi Sawada. All rights reserved. | |
| 2 | 2 | ** |
| 3 | 3 | ** Redistribution and use in source and binary forms, with or without |
| 4 | 4 | ** modification, are permitted provided that the following conditions |
| 2 | 2 | ** module: PigNose |
| 3 | 3 | ** file: fopl.mod |
| 4 | 4 | ** |
| 5 | ** Copyright (c) 2000-2014, Toshimi Sawada. All rights reserved. | |
| 5 | ** Copyright (c) 2000-2015, Toshimi Sawada. All rights reserved. | |
| 6 | 6 | ** |
| 7 | 7 | ** Redistribution and use in source and binary forms, with or without |
| 8 | 8 | ** modification, are permitted provided that the following conditions |
| 2 | 2 | ** module: library |
| 3 | 3 | ** file: identical.mod |
| 4 | 4 | ** |
| 5 | ** Copyright (c) 2000-2014, Toshimi Sawada. All rights reserved. | |
| 5 | ** Copyright (c) 2000-2015, Toshimi Sawada. All rights reserved. | |
| 6 | 6 | ** |
| 7 | 7 | ** Redistribution and use in source and binary forms, with or without |
| 8 | 8 | ** modification, are permitted provided that the following conditions |
| 0 | 0 | ** |
| 1 | ** Copyright (c) 2000-2014, Toshimi Sawada. All rights reserved. | |
| 1 | ** Copyright (c) 2000-2015, Toshimi Sawada. All rights reserved. | |
| 2 | 2 | ** |
| 3 | 3 | ** Redistribution and use in source and binary forms, with or without |
| 4 | 4 | ** modification, are permitted provided that the following conditions |
| 32 | 32 | protecting (INT-VALUE) |
| 33 | 33 | } |
| 34 | 34 | signature { |
| 35 | pred _ divides _ : NzInt Int { demod prec: 41 } | |
| 36 | op _ rem _ : Int NzInt -> Int { demod prec: 41 } | |
| 37 | op _ quo _ : Int NzInt -> Int { demod prec: 41 } | |
| 38 | op _ + _ : Int Int -> Int { idr: 0 demod prec: 41 } | |
| 39 | op _ * _ : Int Int -> Int { demod prec: 41 } | |
| 40 | pred _ < _ : Int Int { demod prec: 41 } | |
| 41 | pred _ <= _ : Int Int { demod prec: 41 } | |
| 42 | pred _ > _ : Int Int { demod prec: 41 } | |
| 43 | pred _ >= _ : Int Int { demod prec: 41 } | |
| 35 | pred _ divides _ : NzInt Int { demod prec: 51 } | |
| 36 | op _ rem _ : Int NzInt -> Int { demod prec: 31 } | |
| 37 | op _ quo _ : Int NzInt -> Int { demod prec: 31 } | |
| 38 | op _ + _ : Int Int -> Int { assoc comm idr: 0 demod prec: 33 } | |
| 39 | op _ * _ : Int Int -> Int { assoc comm idr: 1 demod prec: 31 } | |
| 40 | pred _ < _ : Int Int { demod prec: 51 } | |
| 41 | pred _ <= _ : Int Int { demod prec: 51 } | |
| 42 | pred _ > _ : Int Int { demod prec: 51 } | |
| 43 | pred _ >= _ : Int Int { demod prec: 51 } | |
| 44 | 44 | op s _ : Int -> Int { strat: (0 1) demod prec: 15 } |
| 45 | 45 | op _ - _ : Int Int -> Int { strat: (0 1 2) demod prec: 33 r-assoc } |
| 46 | 46 | op - _ : Int -> Int { demod prec: 15 } |
| 0 | 0 | ** |
| 1 | 1 | ** CafeOBJ MetaLevel Core |
| 2 | 2 | ** |
| 3 | ** Copyright (c) 2000-2014, Toshimi Sawada. All rights reserved. | |
| 3 | ** Copyright (c) 2000-2015, Toshimi Sawada. All rights reserved. | |
| 4 | 4 | ** |
| 5 | 5 | ** Redistribution and use in source and binary forms, with or without |
| 6 | 6 | ** modification, are permitted provided that the following conditions |
| 0 | 0 | ** |
| 1 | ** Copyright (c) 2000-2014, Toshimi Sawada. All rights reserved. | |
| 1 | ** Copyright (c) 2000-2015, Toshimi Sawada. All rights reserved. | |
| 2 | 2 | ** |
| 3 | 3 | ** Redistribution and use in source and binary forms, with or without |
| 4 | 4 | ** modification, are permitted provided that the following conditions |
| 33 | 33 | } |
| 34 | 34 | signature { |
| 35 | 35 | op s _ : Nat -> NzNat { demod prec: 15 } |
| 36 | pred _ >= _ : Nat Nat { demod prec: 41 } | |
| 37 | pred _ > _ : Nat Nat { demod prec: 41 } | |
| 38 | pred _ <= _ : Nat Nat { demod prec: 41 } | |
| 39 | pred _ < _ : Nat Nat { demod prec: 41 } | |
| 40 | op _ * _ : Nat Nat -> Nat { strat: (2 0 1) demod prec: 41 } | |
| 41 | op _ + _ : Nat Nat -> Nat { idr: 0 demod prec: 41 } | |
| 36 | pred _ >= _ : Nat Nat { demod prec: 51 } | |
| 37 | pred _ > _ : Nat Nat { demod prec: 51 } | |
| 38 | pred _ <= _ : Nat Nat { demod prec: 51 } | |
| 39 | pred _ < _ : Nat Nat { demod prec: 51 } | |
| 40 | op _ * _ : Nat Nat -> Nat { assoc comm idr: 1 demod prec: 31 } | |
| 41 | op _ + _ : Nat Nat -> Nat { assoc comm idr: 0 demod prec: 33 } | |
| 42 | 42 | op sd : Nat Nat -> Nat { comm demod prec: 0 } |
| 43 | op _ quo _ : Nat NzNat -> Nat { demod prec: 41 } | |
| 43 | op _ quo _ : Nat NzNat -> Nat { demod prec: 31 } | |
| 44 | 44 | op _ rem _ : Nat NzNat -> Nat { demod prec: 31 l-assoc } |
| 45 | 45 | pred _ divides _ : NzNat Nat { demod prec: 51 } |
| 46 | 46 | op p _ : NzNat -> Nat { demod prec: 15 } |
| 3 | 3 | ** module: library |
| 4 | 4 | ** file: ntruth.cafe |
| 5 | 5 | ** |
| 6 | ** Copyright (c) 2000-2014, Toshimi Sawada. All rights reserved. | |
| 6 | ** Copyright (c) 2000-2015, Toshimi Sawada. All rights reserved. | |
| 7 | 7 | ** |
| 8 | 8 | ** Redistribution and use in source and binary forms, with or without |
| 9 | 9 | ** modification, are permitted provided that the following conditions |
| 1 | 1 | ** NZNAT |
| 2 | 2 | ** |
| 3 | 3 | ** |
| 4 | ** Copyright (c) 2000-2014, Toshimi Sawada. All rights reserved. | |
| 4 | ** Copyright (c) 2000-2015, Toshimi Sawada. All rights reserved. | |
| 5 | 5 | ** |
| 6 | 6 | ** Redistribution and use in source and binary forms, with or without |
| 7 | 7 | ** modification, are permitted provided that the following conditions |
| 0 | 0 | ** |
| 1 | ** Copyright (c) 2000-2014, Toshimi Sawada. All rights reserved. | |
| 1 | ** Copyright (c) 2000-2015, Toshimi Sawada. All rights reserved. | |
| 2 | 2 | ** |
| 3 | 3 | ** Redistribution and use in source and binary forms, with or without |
| 4 | 4 | ** modification, are permitted provided that the following conditions |
| 0 | 0 | ** |
| 1 | ** Copyright (c) 2000-2014, Toshimi Sawada. All rights reserved. | |
| 1 | ** Copyright (c) 2000-2015, Toshimi Sawada. All rights reserved. | |
| 2 | 2 | ** |
| 3 | 3 | ** Redistribution and use in source and binary forms, with or without |
| 4 | 4 | ** modification, are permitted provided that the following conditions |
| 39 | 39 | pred _ > _ : Rat Rat { demod prec: 41 } |
| 40 | 40 | pred _ <= _ : Rat Rat { demod prec: 41 } |
| 41 | 41 | pred _ < _ : Rat Rat { demod prec: 41 } |
| 42 | op _ * _ : Rat Rat -> Rat { demod prec: 41 } | |
| 43 | op _ + _ : Rat Rat -> Rat { idr: 0 demod prec: 41 } | |
| 42 | op _ * _ : Rat Rat -> Rat { assoc comm idr: 1 demod prec: 41 } | |
| 43 | op _ + _ : Rat Rat -> Rat { assoc comm idr: 0 demod prec: 41 } | |
| 44 | 44 | op _ rem _ : Rat NzRat -> Rat { demod prec: 41 } |
| 45 | 45 | op _ / _ : Rat NzRat -> Rat { demod prec: 31 l-assoc } |
| 46 | 46 | op _ / _ : NzRat NzRat -> NzRat { demod prec: 31 l-assoc } |
| 2 | 2 | ** module: library |
| 3 | 3 | ** file: rwl.mod |
| 4 | 4 | ** |
| 5 | ** Copyright (c) 2000-2014, Toshimi Sawada. All rights reserved. | |
| 5 | ** Copyright (c) 2000-2015, Toshimi Sawada. All rights reserved. | |
| 6 | 6 | ** |
| 7 | 7 | ** Redistribution and use in source and binary forms, with or without |
| 8 | 8 | ** modification, are permitted provided that the following conditions |
| 0 | 0 | ** |
| 1 | ** Copyright (c) 2000-2014, Toshimi Sawada. All rights reserved. | |
| 1 | ** Copyright (c) 2000-2015, Toshimi Sawada. All rights reserved. | |
| 2 | 2 | ** |
| 3 | 3 | ** Redistribution and use in source and binary forms, with or without |
| 4 | 4 | ** modification, are permitted provided that the following conditions |
| 0 | 0 | ** |
| 1 | 1 | ** MODULE BOOL |
| 2 | 2 | ** |
| 3 | ** Copyright (c) 2000-2014, Toshimi Sawada. All rights reserved. | |
| 3 | ** Copyright (c) 2000-2015, Toshimi Sawada. All rights reserved. | |
| 4 | 4 | ** |
| 5 | 5 | ** Redistribution and use in source and binary forms, with or without |
| 6 | 6 | ** modification, are permitted provided that the following conditions |
| 2 | 2 | ** module: library |
| 3 | 3 | ** file: truth.mod |
| 4 | 4 | ** |
| 5 | ** Copyright (c) 2000-2014, Toshimi Sawada. All rights reserved. | |
| 5 | ** Copyright (c) 2000-2015, Toshimi Sawada. All rights reserved. | |
| 6 | 6 | ** |
| 7 | 7 | ** Redistribution and use in source and binary forms, with or without |
| 8 | 8 | ** modification, are permitted provided that the following conditions |
| 6 | 6 | * NOTE : DO NOT MODIFY THIS FILE ULESS YOU REALLY KNOW WHAT YOU ARE DOING!. |
| 7 | 7 | ||# |
| 8 | 8 | ;;; |
| 9 | ;;; Copyright (c) 2000-2014, Toshimi Sawada. All rights reserved. | |
| 9 | ;;; Copyright (c) 2000-2015, Toshimi Sawada. All rights reserved. | |
| 10 | 10 | ;;; |
| 11 | 11 | ;;; Redistribution and use in source and binary forms, with or without |
| 12 | 12 | ;;; modification, are permitted provided that the following conditions |
| 36 | 36 | (eval-when (:execute :load-toplevel) |
| 37 | 37 | ;;; system standard prelude. |
| 38 | 38 | (setq *include-bool* t) |
| 39 | (setf *last-module* nil | |
| 40 | *current-module* nil) | |
| 39 | (setf *current-module* nil) | |
| 41 | 40 | (setf *print-circle* nil) |
| 42 | 41 | (setf *print-pretty* nil) |
| 43 | 42 | (install-prelude) |
| 53 | 52 | ("FLOAT" . "float") |
| 54 | 53 | ("CHARACTER" . "character") |
| 55 | 54 | ("FOPL-CLAUSE" . "fopl") |
| 56 | ("PROPC" . "propc") | |
| 55 | ;; ("PROPC" . "propc") | |
| 57 | 56 | ("STRING" . "string") |
| 58 | 57 | ("2TUPLE" . "2tuple") |
| 59 | 58 | ("3TUPLE" . "3tuple") |
| 60 | 59 | ("4TUPLE" . "4tuple") |
| 61 | 60 | ("EQL" . "eql") |
| 62 | ("AVPAIR" . "reobject") | |
| 63 | ("RECORD-STRUCTURE" . "reobject") | |
| 64 | ("OBJECT-ID" . "reobject") | |
| 65 | ("OBJECT" . "reobject") | |
| 66 | ("STATE-CONFIGURATION" . "reobject") | |
| 67 | ("ACZ-CONFIGURATION" . "reobject") | |
| 68 | 61 | ("QID" . "qid") |
| 69 | 62 | ("META-LEVEL" . "metalevel") |
| 70 | 63 | )) |
| 0 | 0 | ;;;-*- Mode:LISP; Package: COMMON-LISP-USER; Base:10; Syntax:Common-Lisp -*- |
| 1 | 1 | ;;; |
| 2 | ;;; Copyright (c) 2000-2014, Toshimi Sawada. All rights reserved. | |
| 2 | ;;; Copyright (c) 2000-2015, Toshimi Sawada. All rights reserved. | |
| 3 | 3 | ;;; |
| 4 | 4 | ;;; Redistribution and use in source and binary forms, with or without |
| 5 | 5 | ;;; modification, are permitted provided that the following conditions |
| 33 | 33 | (eval-when (:execute :load-toplevel) |
| 34 | 34 | (unless (find-package :common-lisp) |
| 35 | 35 | (rename-package :lisp :common-lisp |
| 36 | (union '("CL" "LISP") | |
| 37 | (package-nicknames (find-package :lisp)) :test #'string=))) | |
| 36 | (union '("CL" "LISP") | |
| 37 | (package-nicknames (find-package :lisp)) :test #'string=))) | |
| 38 | 38 | (unless (find-package :common-lisp-user) |
| 39 | 39 | (rename-package :user :common-lisp-user |
| 40 | (union '("CL-USER" "USER") | |
| 41 | (package-nicknames (find-package :user)) :test #'string=))) | |
| 40 | (union '("CL-USER" "USER") | |
| 41 | (package-nicknames (find-package :user)) :test #'string=))) | |
| 42 | 42 | ) |
| 43 | 43 | |
| 44 | 44 | #+LUCID (in-package "user") |
| 61 | 61 | #+clisp |
| 62 | 62 | (eval-when (:execute :load-toplevel) |
| 63 | 63 | (setq *chaos-root* (namestring (car (directory (concatenate 'string |
| 64 | *chaos-root* "/")))))) | |
| 64 | *chaos-root* "/")))))) | |
| 65 | 65 | |
| 66 | 66 | (defvar chaos::*cafeobj-install-dir*) |
| 67 | 67 | #-(or microsoft (and ccl (not :openmcl))) |
| 116 | 116 | (chaos::set-cafeobj-standard-library-path) |
| 117 | 117 | (setq *chaos-new* t) |
| 118 | 118 | (ext:save-lisp path |
| 119 | :purify t | |
| 120 | :init-function 'chaos::cafeobj-top-level | |
| 121 | :print-herald nil | |
| 122 | ) | |
| 119 | :purify t | |
| 120 | :init-function 'chaos::cafeobj-top-level | |
| 121 | :print-herald nil | |
| 122 | ) | |
| 123 | 123 | ) |
| 124 | 124 | |
| 125 | 125 | #+SBCL |
| 128 | 128 | (chaos::set-cafeobj-standard-library-path) |
| 129 | 129 | (setq *chaos-new* t) |
| 130 | 130 | (sb-ext:save-lisp-and-die path |
| 131 | :toplevel 'chaos::cafeobj-top-level | |
| 132 | :purify t | |
| 133 | :executable t | |
| 134 | :save-runtime-options t | |
| 135 | ) | |
| 131 | :toplevel 'chaos::cafeobj-top-level | |
| 132 | :purify t | |
| 133 | :executable t | |
| 134 | :save-runtime-options t | |
| 135 | ) | |
| 136 | 136 | ) |
| 137 | 137 | |
| 138 | 138 | |
| 142 | 142 | (chaos::set-cafeobj-standard-library-path) |
| 143 | 143 | (setq *chaos-new* t) |
| 144 | 144 | (disksave path |
| 145 | :full-gc t | |
| 146 | :restart-function 'chaos::cafeobj-top-level)) | |
| 145 | :full-gc t | |
| 146 | :restart-function 'chaos::cafeobj-top-level)) | |
| 147 | 147 | |
| 148 | 148 | #+(and ccl (not :openmcl)) |
| 149 | 149 | (defun make-exec-image (path) |
| 174 | 174 | #|| |
| 175 | 175 | (setq excl:*restart-init-function* |
| 176 | 176 | #'(lambda () |
| 177 | (excl:use-background-streams) | |
| 178 | (excl:start-emacs-lisp-interface t))) | |
| 177 | (excl:use-background-streams) | |
| 178 | (excl:start-emacs-lisp-interface t))) | |
| 179 | 179 | ||# |
| 180 | 180 | (setq excl:*print-startup-message* nil) |
| 181 | 181 | (setq excl::.dump-lisp-suppress-allegro-cl-banner. t) |
| 195 | 195 | |
| 196 | 196 | (defun make-cafeobj (&optional chaos-root) |
| 197 | 197 | (format t "~%** making CafeOBJ (~a)" (or chaos-root |
| 198 | *chaos-root*)) | |
| 198 | *chaos-root*)) | |
| 199 | 199 | (when chaos-root |
| 200 | 200 | (setf *chaos-root* chaos-root)) |
| 201 | 201 | ;; (mk::operate-on-system :chaosx :compile) |
| 206 | 206 | (asdf:oos 'asdf:load-op 'chaosx) |
| 207 | 207 | (make-exec-image |
| 208 | 208 | (concatenate 'string *chaos-root* |
| 209 | #+GCL "/dumps/gcl/@gcl_dump@" | |
| 210 | #+microsoft "/dumps/dxl/cafeobj.dxl" | |
| 211 | #+(and unix Allegro) "/dumps/acl/@acl_dump@" | |
| 212 | #+CMU "/dumps/cmu/@cmu_dump@" | |
| 213 | #+SBCL "/dumps/sbcl/@sbcl_dump@" | |
| 214 | #+CLISP "/dumps/clisp/@clisp_dump@" | |
| 215 | #+:openmcl "/dumps/ccl/@ccl_dump@" | |
| 216 | ;; patch by t-seino@jaist.ac.jp | |
| 217 | ;; patch by sawada@sra.co.jp | |
| 218 | #+(and CCL (not :openmcl)) ":dumps:ccl:cafeobj.exe" | |
| 219 | )) | |
| 209 | #+GCL "/dumps/gcl/@gcl_dump@" | |
| 210 | #+microsoft "/dumps/dxl/cafeobj.dxl" | |
| 211 | #+(and unix Allegro) "/dumps/acl/@acl_dump@" | |
| 212 | #+CMU "/dumps/cmu/@cmu_dump@" | |
| 213 | #+SBCL "/dumps/sbcl/@sbcl_dump@" | |
| 214 | #+CLISP "/dumps/clisp/@clisp_dump@" | |
| 215 | #+:openmcl "/dumps/ccl/@ccl_dump@" | |
| 216 | ;; patch by t-seino@jaist.ac.jp | |
| 217 | ;; patch by sawada@sra.co.jp | |
| 218 | #+(and CCL (not :openmcl)) ":dumps:ccl:cafeobj.exe" | |
| 219 | )) | |
| 220 | 220 | ) |
| 221 | 221 | |
| 222 | 222 | (eval-when (:execute :load-toplevel) |
| 0 | 0 | ;;; |
| 1 | ;;; Copyright (c) 2000-2014, Toshimi Sawada. All rights reserved. | |
| 1 | ;;; Copyright (c) 2000-2015, Toshimi Sawada. All rights reserved. | |
| 2 | 2 | ;;; |
| 3 | 3 | ;;; Redistribution and use in source and binary forms, with or without |
| 4 | 4 | ;;; modification, are permitted provided that the following conditions |
| 2 | 2 | # make-release-tarballs |
| 3 | 3 | # create release tarballs for CafeOBJ |
| 4 | 4 | # |
| 5 | # Copyright (c) 2014, Norbert Preining. All rights reserved. | |
| 5 | # Copyright (c) 2014-2015, Norbert Preining. All rights reserved. | |
| 6 | 6 | # |
| 7 | 7 | # Redistribution and use in source and binary forms, with or without |
| 8 | 8 | # modification, are permitted provided that the following conditions |
| 2 | 2 | # make-source-tarball |
| 3 | 3 | # create a source release tarball for CafeOBJ |
| 4 | 4 | # |
| 5 | # Copyright (c) 2014, Norbert Preining. All rights reserved. | |
| 5 | # Copyright (c) 2014-2015, Norbert Preining. All rights reserved. | |
| 6 | 6 | # |
| 7 | 7 | # Redistribution and use in source and binary forms, with or without |
| 8 | 8 | # modification, are permitted provided that the following conditions |
| 0 | 0 | ;;; -*- Mode: LISP; Syntax: Common-lisp; Base: 10; Lowercase: T; -*- |
| 1 | 1 | ;;; |
| 2 | 2 | ;;; |
| 3 | ;;; Copyright (c) 2000-2014, Toshimi Sawada. All rights reserved. | |
| 3 | ;;; Copyright (c) 2000-2015, Toshimi Sawada. All rights reserved. | |
| 4 | 4 | ;;; |
| 5 | 5 | ;;; Redistribution and use in source and binary forms, with or without |
| 6 | 6 | ;;; modification, are permitted provided that the following conditions |
| 43 | 43 | :components |
| 44 | 44 | (#+gcl |
| 45 | 45 | (:module "clII" |
| 46 | :components (#-:defpackage (:file "loop") | |
| 47 | #-:defpackage (:file "defpackage") | |
| 48 | )) | |
| 46 | :components (#-:defpackage (:file "loop") | |
| 47 | #-:defpackage (:file "defpackage") | |
| 48 | )) | |
| 49 | 49 | ;; |
| 50 | 50 | (:file "chaos-package") |
| 51 | 51 | (:file "version") |
| 52 | 52 | ;; (:file "func-spec") |
| 53 | 53 | (:module comlib |
| 54 | :serial t | |
| 55 | :components ((:file "globals") | |
| 56 | (:file "macros") | |
| 57 | (:file "print-utils") | |
| 58 | (:file "message") | |
| 59 | (:file "error") | |
| 60 | (:file "misc") | |
| 61 | (:file "string") | |
| 62 | (:file "list") | |
| 63 | (:file "dag") | |
| 64 | (:file "fsys") | |
| 65 | (:file "tree-display") | |
| 66 | (:file "lex") | |
| 67 | (:file "reader") | |
| 68 | (:file "let-over-lambda") | |
| 69 | )) | |
| 54 | :serial t | |
| 55 | :components ((:file "globals") | |
| 56 | (:file "macros") | |
| 57 | (:file "print-utils") | |
| 58 | (:file "message") | |
| 59 | (:file "error") | |
| 60 | (:file "misc") | |
| 61 | (:file "string") | |
| 62 | (:file "list") | |
| 63 | (:file "dag") | |
| 64 | (:file "fsys") | |
| 65 | (:file "tree-display") | |
| 66 | (:file "lex") | |
| 67 | (:file "reader") | |
| 68 | (:file "let-over-lambda") | |
| 69 | )) | |
| 70 | 70 | (:module "chaos" |
| 71 | :components ((:module primitives | |
| 72 | :serial t | |
| 73 | :components ((:file "term2") | |
| 74 | (:file "defterm") | |
| 75 | (:file "bobject2") | |
| 76 | (:file "absntax") | |
| 77 | (:file "script") | |
| 78 | (:file "op-theory") | |
| 79 | (:file "bmodexp") | |
| 80 | (:file "bmodule2") | |
| 81 | (:file "bview2") | |
| 82 | (:file "parse-modexp") | |
| 83 | (:file "normodexp") | |
| 84 | (:file "bsort") | |
| 85 | (:file "boperator") | |
| 86 | (:file "baxioms") | |
| 87 | (:file "bmacro") | |
| 88 | (:file "gen-eval") | |
| 89 | (:file "gen-print") | |
| 90 | (:file "context") | |
| 91 | (:file "term-utils") | |
| 92 | (:file "substitution") | |
| 93 | (:file "find") | |
| 94 | (:file "print-object") | |
| 95 | )) | |
| 96 | (:module term-parser | |
| 97 | :serial t | |
| 98 | :components ((:file "parse-macro") | |
| 99 | (:file "parse-engine") | |
| 100 | (:file "parse-top") | |
| 101 | ) | |
| 102 | ) | |
| 103 | (:module e-match | |
| 104 | :serial t | |
| 105 | :components ((:file "match-utils") | |
| 106 | (:file "match-system") | |
| 107 | (:file "match-state") | |
| 108 | (:file "match-e") | |
| 109 | (:file "match-idem") | |
| 110 | (:file "match-z") | |
| 111 | (:file "match-a") | |
| 112 | (:file "match-c") | |
| 113 | (:file "match-az") | |
| 114 | (:file "match-cz") | |
| 115 | (:file "match-ac") | |
| 116 | (:file "match-acz") | |
| 117 | (:file "match") | |
| 118 | (:file "match2") | |
| 119 | )) | |
| 120 | (:module construct | |
| 121 | :components ((:file "sort") | |
| 122 | (:file "operator") | |
| 123 | (:file "variable") | |
| 124 | (:file "match-method") | |
| 125 | (:file "axiom") | |
| 126 | (:file "gen-rule") | |
| 127 | (:file "cr") | |
| 128 | (:file "rwl") | |
| 129 | (:file "beh") | |
| 130 | (:file "module") | |
| 131 | (:file "trs") | |
| 132 | ) | |
| 133 | ) | |
| 134 | (:module decafe | |
| 135 | :serial t | |
| 136 | :components ((:file "mutils") | |
| 137 | (:file "modmorph") | |
| 138 | (:file "mrmap") | |
| 139 | (:file "meval") | |
| 140 | (:file "view") | |
| 141 | (:file "mimport") | |
| 142 | )) | |
| 143 | (:module cafein | |
| 144 | :components (;; (:file "apply-rule") | |
| 145 | (:file "rengine") | |
| 146 | (:file "cbred") | |
| 147 | ;; (:file "rdebug") | |
| 148 | ;; (:file "trs") | |
| 149 | )) | |
| 150 | (:module tools | |
| 151 | :components ((:file "regcheck") | |
| 152 | (:file "regularize") | |
| 153 | (:file "describe") | |
| 154 | (:file "sort-tree") | |
| 155 | (:file "module-tree") | |
| 156 | (:file "show") | |
| 157 | (:file "set") | |
| 158 | (:file "op-check") | |
| 159 | (:file "compat") | |
| 160 | (:file "help") | |
| 161 | (:file "inspect") | |
| 162 | (:file "sensible") | |
| 163 | ;; (:file "psupport") | |
| 164 | )) | |
| 165 | (:module eval | |
| 166 | :components ((:file "eval-mod") | |
| 167 | (:file "eval-ast") | |
| 168 | (:file "eval-ast2") | |
| 169 | (:file "chaos-top") | |
| 170 | ) | |
| 171 | ) | |
| 172 | (:module boot | |
| 173 | :components ((:file "preproc") | |
| 174 | (:file "prelude") | |
| 175 | (:file "builtins") | |
| 176 | (:file "meta") | |
| 177 | )) | |
| 178 | (:module tram | |
| 179 | :components ((:file "tram"))) | |
| 180 | (:module psup | |
| 181 | :components ((:file "psup"))) | |
| 182 | )) | |
| 71 | :components ((:module primitives | |
| 72 | :serial t | |
| 73 | :components ((:file "term2") | |
| 74 | (:file "defterm") | |
| 75 | (:file "bobject2") | |
| 76 | (:file "absntax") | |
| 77 | (:file "script") | |
| 78 | (:file "op-theory") | |
| 79 | (:file "bmodexp") | |
| 80 | (:file "bmodule2") | |
| 81 | (:file "bview2") | |
| 82 | (:file "parse-modexp") | |
| 83 | (:file "normodexp") | |
| 84 | (:file "bsort") | |
| 85 | (:file "boperator") | |
| 86 | (:file "baxioms") | |
| 87 | (:file "bmacro") | |
| 88 | (:file "gen-eval") | |
| 89 | (:file "gen-print") | |
| 90 | (:file "context") | |
| 91 | (:file "term-utils") | |
| 92 | (:file "substitution") | |
| 93 | (:file "find") | |
| 94 | (:file "print-object") | |
| 95 | )) | |
| 96 | (:module term-parser | |
| 97 | :serial t | |
| 98 | :components ((:file "parse-macro") | |
| 99 | (:file "parse-engine") | |
| 100 | (:file "parse-top") | |
| 101 | ) | |
| 102 | ) | |
| 103 | (:module e-match | |
| 104 | :serial t | |
| 105 | :components ((:file "match-utils") | |
| 106 | (:file "match-system") | |
| 107 | (:file "match-state") | |
| 108 | (:file "match-e") | |
| 109 | (:file "match-idem") | |
| 110 | (:file "match-z") | |
| 111 | (:file "match-a") | |
| 112 | (:file "match-c") | |
| 113 | (:file "match-az") | |
| 114 | (:file "match-cz") | |
| 115 | (:file "match-ac") | |
| 116 | (:file "match-acz") | |
| 117 | (:file "match") | |
| 118 | (:file "match2") | |
| 119 | )) | |
| 120 | (:module construct | |
| 121 | :components ((:file "sort") | |
| 122 | (:file "operator") | |
| 123 | (:file "variable") | |
| 124 | (:file "match-method") | |
| 125 | (:file "axiom") | |
| 126 | (:file "gen-rule") | |
| 127 | (:file "rwl") | |
| 128 | (:file "beh") | |
| 129 | (:file "module") | |
| 130 | (:file "trs") | |
| 131 | ) | |
| 132 | ) | |
| 133 | (:module decafe | |
| 134 | :serial t | |
| 135 | :components ((:file "mutils") | |
| 136 | (:file "modmorph") | |
| 137 | (:file "mrmap") | |
| 138 | (:file "meval") | |
| 139 | (:file "view") | |
| 140 | (:file "mimport") | |
| 141 | )) | |
| 142 | (:module cafein | |
| 143 | :components ((:file "rengine") | |
| 144 | (:file "cbred") | |
| 145 | (:file "reducer") | |
| 146 | )) | |
| 147 | (:module tools | |
| 148 | :components ((:file "regcheck") | |
| 149 | (:file "regularize") | |
| 150 | (:file "describe") | |
| 151 | (:file "sort-tree") | |
| 152 | (:file "module-tree") | |
| 153 | (:file "show") | |
| 154 | (:file "set") | |
| 155 | (:file "op-check") | |
| 156 | (:file "compat") | |
| 157 | (:file "help") | |
| 158 | (:file "inspect") | |
| 159 | (:file "sensible") | |
| 160 | ;; (:file "psupport") | |
| 161 | )) | |
| 162 | (:module eval | |
| 163 | :components ((:file "eval-mod") | |
| 164 | (:file "eval-ast") | |
| 165 | (:file "eval-ast2") | |
| 166 | (:file "chaos-top") | |
| 167 | ) | |
| 168 | ) | |
| 169 | (:module boot | |
| 170 | :components ((:file "preproc") | |
| 171 | (:file "prelude") | |
| 172 | (:file "builtins") | |
| 173 | (:file "meta") | |
| 174 | )) | |
| 175 | (:module tram | |
| 176 | :components ((:file "tram"))) | |
| 177 | (:module psup | |
| 178 | :components ((:file "psup"))) | |
| 179 | )) | |
| 183 | 180 | (:module thstuff |
| 184 | :serial t | |
| 185 | :components ((:file "parse-apply") | |
| 186 | (:file "basics") | |
| 187 | (:file "eval-match") | |
| 188 | (:file "eval-apply") | |
| 189 | (:file "cexec") | |
| 190 | (:file "case") | |
| 191 | (:file "proof-struct") | |
| 192 | (:file "apply-tactic") | |
| 193 | (:file "citp"))) | |
| 181 | :serial t | |
| 182 | :components ((:file "parse-apply") | |
| 183 | (:file "basics") | |
| 184 | (:file "eval-match") | |
| 185 | (:file "eval-apply") | |
| 186 | (:file "cexec") | |
| 187 | (:file "case") | |
| 188 | (:file "proof-struct") | |
| 189 | (:file "apply-tactic") | |
| 190 | (:file "citp") | |
| 191 | (:file "bterm-inspector"))) | |
| 194 | 192 | (:module "BigPink" |
| 195 | :components ((:module codes | |
| 196 | :serial t | |
| 197 | :components ((:file "types") | |
| 198 | (:file "glob") | |
| 199 | (:file "proof-sys") | |
| 200 | (:file "syntax") | |
| 201 | (:file "index") | |
| 202 | (:file "butils") | |
| 203 | (:file "unify") | |
| 204 | (:file "clause") | |
| 205 | (:file "formula") | |
| 206 | (:file "modconv") | |
| 207 | (:file "weight") | |
| 208 | (:file "lrpo") | |
| 209 | (:file "resolve") | |
| 210 | (:file "paramod") | |
| 211 | (:file "demod") | |
| 212 | (:file "infer") | |
| 213 | (:file "sigmatch") | |
| 214 | (:file "refine") | |
| 215 | (:file "commands") | |
| 216 | (:file "inv") | |
| 217 | )))) | |
| 193 | :components ((:module codes | |
| 194 | :serial t | |
| 195 | :components ((:file "types") | |
| 196 | (:file "glob") | |
| 197 | (:file "proof-sys") | |
| 198 | (:file "syntax") | |
| 199 | (:file "index") | |
| 200 | (:file "butils") | |
| 201 | (:file "unify") | |
| 202 | (:file "clause") | |
| 203 | (:file "formula") | |
| 204 | (:file "modconv") | |
| 205 | (:file "weight") | |
| 206 | (:file "lrpo") | |
| 207 | (:file "resolve") | |
| 208 | (:file "paramod") | |
| 209 | (:file "demod") | |
| 210 | (:file "infer") | |
| 211 | (:file "sigmatch") | |
| 212 | (:file "refine") | |
| 213 | (:file "commands") | |
| 214 | (:file "inv") | |
| 215 | )))) | |
| 218 | 216 | (:module cafeobj |
| 219 | :serial t | |
| 220 | :components ((:file "cafeobjvar") | |
| 221 | (:file "creader") | |
| 222 | (:file "oldoc") | |
| 223 | (:file "define") | |
| 224 | (:file "trans-com") | |
| 225 | (:file "trans-decl") | |
| 226 | (:file "trans-form") | |
| 227 | ;; (:file "command-proc") | |
| 228 | (:file "command-top") | |
| 229 | (:file "commands") | |
| 230 | (:file "declarations") | |
| 231 | (:file "cafeobj-top") | |
| 232 | )) | |
| 217 | :serial t | |
| 218 | :components ((:file "cafeobjvar") | |
| 219 | (:file "creader") | |
| 220 | (:file "oldoc") | |
| 221 | (:file "define") | |
| 222 | (:file "trans-com") | |
| 223 | (:file "trans-decl") | |
| 224 | (:file "trans-form") | |
| 225 | ;; (:file "command-proc") | |
| 226 | (:file "command-top") | |
| 227 | (:file "commands") | |
| 228 | (:file "declarations") | |
| 229 | (:file "cafeobj-top") | |
| 230 | )) | |
| 233 | 231 | |
| 234 | 232 | )) |
| 235 | 233 | |
| 1 | 1 | ;;; |
| 2 | 2 | ;;; defsystem for Allegro CL (version 5.0 or higher) |
| 3 | 3 | ;;; |
| 4 | ;;; Copyright (c) 2000-2014, Toshimi Sawada. All rights reserved. | |
| 4 | ;;; Copyright (c) 2000-2015, Toshimi Sawada. All rights reserved. | |
| 5 | 5 | ;;; |
| 6 | 6 | ;;; Redistribution and use in source and binary forms, with or without |
| 7 | 7 | ;;; modification, are permitted provided that the following conditions |
| 37 | 37 | |
| 38 | 38 | (excl:defsystem :cl-ppcre |
| 39 | 39 | (:default-pathname |
| 40 | #+:mswindows | |
| 41 | "c:/Users/sawada/prj/CafeOBJ/cl-ppcre/" | |
| 40 | #+:mswindows | |
| 41 | "c:/Users/sawada/prj/CafeOBJ/cl-ppcre/" | |
| 42 | 42 | #-:mswindows |
| 43 | 43 | "cl-ppcre/" |
| 44 | 44 | :default-package :cl-ppcre) |
| 160 | 160 | "construct/match-method" |
| 161 | 161 | "construct/axiom" |
| 162 | 162 | "construct/gen-rule" |
| 163 | "construct/cr" | |
| 164 | 163 | "construct/rwl" |
| 165 | 164 | "construct/beh" |
| 166 | 165 | "construct/module" |
| 175 | 174 | "decafe/mimport")) |
| 176 | 175 | (:module-group :cafein |
| 177 | 176 | (:serial "cafein/rengine" |
| 178 | "cafein/cbred")) | |
| 177 | "cafein/cbred" | |
| 178 | "cafein/reducer")) | |
| 179 | 179 | (:module-group :tools |
| 180 | 180 | (:parallel |
| 181 | 181 | "tools/regcheck" |
| 188 | 188 | "tools/op-check" |
| 189 | 189 | "tools/compat" |
| 190 | 190 | "tools/help" |
| 191 | "tools/inspect" | |
| 192 | "tools/sensible" | |
| 191 | "tools/inspect" | |
| 192 | "tools/sensible" | |
| 193 | 193 | ;; "psupport" |
| 194 | 194 | )) |
| 195 | 195 | (:module-group :eval |
| 200 | 200 | "eval/chaos-top")) |
| 201 | 201 | (:module-group :boot |
| 202 | 202 | (:serial |
| 203 | "boot/preproc" | |
| 204 | "boot/prelude" | |
| 205 | "boot/builtins" | |
| 206 | "boot/meta")) | |
| 203 | "boot/preproc" | |
| 204 | "boot/prelude" | |
| 205 | "boot/builtins" | |
| 206 | "boot/meta")) | |
| 207 | 207 | (:module-group :tram |
| 208 | 208 | (:serial "tram/tram")) |
| 209 | 209 | (:module-group :psup |
| 220 | 220 | "chaos-package" |
| 221 | 221 | "version" |
| 222 | 222 | (:definitions |
| 223 | :cl-ppcre | |
| 223 | :cl-ppcre | |
| 224 | 224 | :chaos |
| 225 | 225 | (:serial |
| 226 | 226 | (:module-group :thstuff |
| 230 | 230 | "thstuff/eval-match" |
| 231 | 231 | "thstuff/eval-apply" |
| 232 | 232 | "thstuff/cexec" |
| 233 | "thstuff/case" | |
| 234 | "thstuff/proof-struct" | |
| 235 | "thstuff/apply-tactic" | |
| 236 | "thstuff/citp")) | |
| 237 | (:module-group :bigpink | |
| 233 | "thstuff/case" | |
| 234 | "thstuff/proof-struct" | |
| 235 | "thstuff/apply-tactic" | |
| 236 | "thstuff/citp" | |
| 237 | "thstuff/bterm-inspector")) | |
| 238 | (:module-group :bigpink | |
| 238 | 239 | (:definitions |
| 239 | 240 | "BigPink/codes/types" |
| 240 | 241 | "BigPink/codes/glob" |
| 262 | 263 | "cafeobj/cafeobjvar" |
| 263 | 264 | (:serial |
| 264 | 265 | "cafeobj/creader" |
| 265 | "cafeobj/oldoc" | |
| 266 | "cafeobj/define" | |
| 266 | "cafeobj/oldoc" | |
| 267 | "cafeobj/define" | |
| 267 | 268 | "cafeobj/trans-com" |
| 268 | 269 | "cafeobj/trans-decl" |
| 269 | 270 | ;; "cafeobj/command-proc" |
| 270 | 271 | "cafeobj/command-top" |
| 271 | "cafeobj/commands" | |
| 272 | "cafeobj/declarations" | |
| 272 | "cafeobj/commands" | |
| 273 | "cafeobj/declarations" | |
| 273 | 274 | "cafeobj/cafeobj-top"))) |
| 274 | 275 | |
| 275 | 276 | "acl-init" |
| 27 | 27 | ;;; |
| 28 | 28 | (in-package :chaos) |
| 29 | 29 | #|============================================================================= |
| 30 | System:CHAOS | |
| 31 | Module:thstuff | |
| 32 | File:apply-tactic.lisp | |
| 30 | System:CHAOS | |
| 31 | Module:thstuff | |
| 32 | File:apply-tactic.lisp | |
| 33 | 33 | =============================================================================|# |
| 34 | 34 | #-:chaos-debug |
| 35 | 35 | (declaim (optimize (speed 3) (safety 0) #-GCL (debug 0))) |
| 36 | 36 | #+:chaos-debug |
| 37 | 37 | (declaim (optimize (speed 1) (safety 3) #-GCL (debug 3))) |
| 38 | 38 | |
| 39 | ;;; | |
| 40 | ;;; with-in-context : ptree-node | |
| 41 | ;;; construct a lexical environment for applying a tactic. | |
| 42 | ;;; | |
| 43 | (eval-when (:compile-toplevel :execute :load-toplevel) | |
| 44 | (defmacro with-in-context ((ptree-node) &rest body) | |
| 45 | (once-only (ptree-node) | |
| 46 | `(block :exit | |
| 47 | (let* ((.cur-goal. (ptree-node-goal ,ptree-node)) | |
| 48 | (.cur-targets. (goal-targets .cur-goal.)) | |
| 49 | (.next-goals. nil)) | |
| 50 | (unless .cur-targets. (return-from :exit nil)) | |
| 51 | ,@body)))) | |
| 52 | ||
| 53 | ) | |
| 54 | ||
| 55 | ;;; ***************************************************************************** | |
| 39 | ;;; **************************************************************************** | |
| 56 | 40 | ;;; UTILITIES |
| 57 | 41 | ;;; **************************************************************************** |
| 58 | 42 | |
| 62 | 46 | (defun distribute-sentences (parent axioms tactic) |
| 63 | 47 | (declare (type ptree-node parent)) |
| 64 | 48 | (let ((new-goals nil) |
| 65 | (goal nil)) | |
| 49 | (goal nil)) | |
| 66 | 50 | (cond ((cdr axioms) |
| 67 | (dolist (ax axioms) | |
| 68 | (setq goal (prepare-next-goal parent tactic)) | |
| 69 | (setf (goal-targets goal) (list ax)) | |
| 70 | (push goal new-goals))) | |
| 71 | (t (push (ptree-node-goal parent) new-goals))) | |
| 51 | (dolist (ax axioms) | |
| 52 | (setq goal (prepare-next-goal parent tactic)) | |
| 53 | (setf (goal-targets goal) (list ax)) | |
| 54 | (push goal new-goals))) | |
| 55 | (t (push (ptree-node-goal parent) new-goals))) | |
| 72 | 56 | (nreverse new-goals))) |
| 73 | 57 | |
| 74 | 58 | ;;; rule-copy-cononicalized : rule module -> rule |
| 75 | 59 | ;;; copy rule with all variables are renewed and noralized. |
| 76 | 60 | ;;; |
| 77 | (defun rule-copy-canonicalized (rule module) | |
| 78 | (let* ((new-rule (rule-copy rule)) | |
| 79 | (canon (canonicalize-variables (list (rule-lhs new-rule) | |
| 80 | (rule-rhs new-rule) | |
| 81 | (rule-condition new-rule)) | |
| 82 | module))) | |
| 83 | (setf (rule-lhs new-rule) (first canon) | |
| 84 | (rule-rhs new-rule) (second canon) | |
| 85 | (rule-condition new-rule) (third canon)) | |
| 86 | new-rule)) | |
| 87 | ||
| 88 | ;;; | |
| 61 | (defun rule-copy-canonicalized (rule module &optional label) | |
| 62 | (with-in-module (module) | |
| 63 | (let* ((new-rule (rule-copy rule)) | |
| 64 | (canon (canonicalize-variables (list (rule-lhs new-rule) | |
| 65 | (rule-rhs new-rule) | |
| 66 | (rule-condition new-rule)) | |
| 67 | module))) | |
| 68 | (setf (rule-lhs new-rule) (first canon) | |
| 69 | (rule-rhs new-rule) (second canon) | |
| 70 | (rule-condition new-rule) (third canon)) | |
| 71 | (when label | |
| 72 | (setf (rule-labels new-rule) (append (rule-labels rule) (list label)))) | |
| 73 | new-rule))) | |
| 74 | ||
| 89 | 75 | ;;; apply-substitution-to-axiom : subst axiom [label] [add] -> axiom' |
| 90 | 76 | ;;; |
| 91 | 77 | (defun apply-substitution-to-axiom (subst axiom &optional label add) |
| 92 | 78 | (setf (rule-lhs axiom) (substitution-image-simplifying subst (rule-lhs axiom)) |
| 93 | (rule-rhs axiom) (substitution-image-simplifying subst (rule-rhs axiom)) | |
| 94 | (rule-condition axiom) (if (is-true? (rule-condition axiom)) | |
| 95 | *bool-true* | |
| 96 | (substitution-image-simplifying subst (rule-condition axiom)))) | |
| 79 | (rule-rhs axiom) (substitution-image-simplifying subst (rule-rhs axiom)) | |
| 80 | (rule-condition axiom) (if (is-true? (rule-condition axiom)) | |
| 81 | *bool-true* | |
| 82 | (substitution-image-simplifying subst (rule-condition axiom)))) | |
| 97 | 83 | (when label |
| 98 | 84 | (if add |
| 99 | (setf (rule-labels axiom) (append (if (atom label) | |
| 100 | (list label) | |
| 101 | label) | |
| 102 | (rule-labels axiom))) | |
| 85 | (setf (rule-labels axiom) (append (if (atom label) | |
| 86 | (list label) | |
| 87 | label) | |
| 88 | (rule-labels axiom))) | |
| 103 | 89 | (setf (rule-labels axiom) label))) |
| 104 | 90 | axiom) |
| 105 | 91 | |
| 106 | ;;; | |
| 107 | 92 | ;;; copy-constant-term |
| 108 | 93 | ;;; |
| 109 | 94 | (defun copy-constant-term (constant) |
| 110 | 95 | (make-applform-simple (term-sort constant) (term-head constant) nil)) |
| 111 | 96 | |
| 112 | ;;; | |
| 113 | 97 | ;;; select-comb-elems : List(List) -> List |
| 114 | 98 | ;;; |
| 115 | 99 | (defun select-combs-aux (max-idx list-of-list) |
| 116 | 100 | (declare (type fixnum max-idx) |
| 117 | (type list list-of-list)) | |
| 101 | (type list list-of-list)) | |
| 118 | 102 | (let* ((result nil) |
| 119 | (target (car list-of-list)) | |
| 120 | (rest (cdr list-of-list)) | |
| 121 | (len (length target))) | |
| 103 | (target (car list-of-list)) | |
| 104 | (rest (cdr list-of-list)) | |
| 105 | (len (length target))) | |
| 122 | 106 | (declare (type fixnum len) |
| 123 | (type list result target rest)) | |
| 107 | (type list result target rest)) | |
| 124 | 108 | (if target |
| 125 | (let ((idx 0)) | |
| 126 | (declare (type fixnum idx)) | |
| 127 | (while (< idx max-idx) | |
| 128 | (let ((elt (nth (mod idx len) target)) | |
| 129 | (rr (select-combs-aux max-idx rest))) | |
| 130 | (if rr | |
| 131 | (dolist (r rr) | |
| 132 | (pushnew (cons elt r) result :test #'equal)) | |
| 133 | (pushnew (list elt) result :test #'equal)) | |
| 134 | (incf idx))) | |
| 135 | (nreverse result)) | |
| 109 | (let ((idx 0)) | |
| 110 | (declare (type fixnum idx)) | |
| 111 | (while (< idx max-idx) | |
| 112 | (let ((elt (nth (mod idx len) target)) | |
| 113 | (rr (select-combs-aux max-idx rest))) | |
| 114 | (if rr | |
| 115 | (dolist (r rr) | |
| 116 | (pushnew (cons elt r) result :test #'equal)) | |
| 117 | (pushnew (list elt) result :test #'equal)) | |
| 118 | (incf idx))) | |
| 119 | (nreverse result)) | |
| 136 | 120 | nil))) |
| 137 | 121 | |
| 138 | 122 | (defun select-combs-aux-indexed (max-idx list-of-list index) |
| 139 | 123 | (declare (type fixnum max-idx index) |
| 140 | (type list list-of-list)) | |
| 124 | (type list list-of-list)) | |
| 141 | 125 | (let* ((result nil) |
| 142 | (target (car list-of-list)) | |
| 143 | (rest (cdr list-of-list)) | |
| 144 | (len (length target))) | |
| 126 | (target (car list-of-list)) | |
| 127 | (rest (cdr list-of-list)) | |
| 128 | (len (length target))) | |
| 145 | 129 | (declare (type fixnum len) |
| 146 | (type list result target rest)) | |
| 130 | (type list result target rest)) | |
| 147 | 131 | (if target |
| 148 | (let ((idx 0)) | |
| 149 | (declare (type fixnum idx)) | |
| 150 | (while (< idx max-idx) | |
| 151 | (let ((elt (nth (mod idx len) target)) | |
| 152 | (rr (select-combs-aux-indexed max-idx rest (1+ index)))) | |
| 153 | (if rr | |
| 154 | (dolist (r rr) | |
| 155 | (pushnew (cons (cons index elt) r) result :test #'equal)) | |
| 156 | (pushnew (list (cons index elt)) result :test #'equal)) | |
| 157 | (incf idx))) | |
| 158 | (nreverse result)) | |
| 132 | (let ((idx 0)) | |
| 133 | (declare (type fixnum idx)) | |
| 134 | (while (< idx max-idx) | |
| 135 | (let ((elt (nth (mod idx len) target)) | |
| 136 | (rr (select-combs-aux-indexed max-idx rest (1+ index)))) | |
| 137 | (if rr | |
| 138 | (dolist (r rr) | |
| 139 | (pushnew (cons (cons index elt) r) result :test #'equal)) | |
| 140 | (pushnew (list (cons index elt)) result :test #'equal)) | |
| 141 | (incf idx))) | |
| 142 | (nreverse result)) | |
| 159 | 143 | nil))) |
| 160 | 144 | |
| 161 | 145 | (defun select-comb-elems (list-of-list &optional (indexed nil)) |
| 164 | 148 | (let ((max-idx (apply #'max (mapcar #'(lambda (x) (length x)) list-of-list)))) |
| 165 | 149 | (declare (type fixnum max-idx)) |
| 166 | 150 | (if indexed |
| 167 | (select-combs-aux-indexed max-idx list-of-list 0) | |
| 151 | (select-combs-aux-indexed max-idx list-of-list 0) | |
| 168 | 152 | (select-combs-aux max-idx list-of-list)))) |
| 169 | 153 | |
| 170 | ;;; | |
| 171 | 154 | ;;; axiom-variables : axiom -> List(variable) |
| 172 | 155 | ;;; returns a list of variables contained in the given axiom |
| 173 | 156 | ;;; |
| 174 | 157 | (defun axiom-variables (ax) |
| 175 | 158 | (let ((lhs (axiom-lhs ax)) |
| 176 | (rhs (axiom-rhs ax)) | |
| 177 | (cond (axiom-condition ax)) | |
| 178 | (result nil)) | |
| 159 | (rhs (axiom-rhs ax)) | |
| 160 | (cond (axiom-condition ax)) | |
| 161 | (result nil)) | |
| 179 | 162 | (declare (type list result)) |
| 180 | 163 | (setq result (append (term-variables lhs) |
| 181 | (append (term-variables rhs) | |
| 182 | (term-variables cond)))) | |
| 164 | (append (term-variables rhs) | |
| 165 | (term-variables cond)))) | |
| 183 | 166 | (delete-duplicates result :test #'variable-equal))) |
| 184 | 167 | |
| 185 | ;;; | |
| 186 | 168 | ;;; normalize-term-in : module term -> term Bool |
| 187 | 169 | ;;; reduces the ground terms in given term by rewriting. |
| 188 | 170 | ;;; if rewritten, returned term is distructively changed. |
| 189 | 171 | ;;; |
| 190 | 172 | (defun normalize-term-in (module term &optional (reduction-mode :red)) |
| 191 | 173 | (let ((applied? nil) |
| 192 | (targets nil) | |
| 193 | (rule-count-save *rule-count*)) | |
| 174 | (targets nil) | |
| 175 | (rule-count-save (number-rewritings))) | |
| 194 | 176 | (if (term-variables term) |
| 195 | (setq targets (get-gterms term)) | |
| 177 | (setq targets (get-gterms term)) | |
| 196 | 178 | (setq targets (list term))) |
| 197 | 179 | (if targets |
| 198 | (with-in-module (module) | |
| 199 | (dolist (gt targets) | |
| 200 | (block next | |
| 201 | (when (term-is-reduced? gt) | |
| 202 | (return-from next nil)) | |
| 203 | (let ((*perform-on-demand-reduction* t) | |
| 204 | (*rewrite-exec-mode* (eq reduction-mode :exec))) | |
| 205 | (rewrite gt *current-module* reduction-mode) | |
| 206 | (unless (= rule-count-save *rule-count*) | |
| 207 | (setq applied? t))))) | |
| 208 | (values term applied?)) | |
| 180 | (progn | |
| 181 | (dolist (gt targets) | |
| 182 | (block next | |
| 183 | (when (term-is-reduced? gt) | |
| 184 | (return-from next nil)) | |
| 185 | (reducer-no-stat gt module reduction-mode) | |
| 186 | (unless (= rule-count-save (number-rewritings)) | |
| 187 | (setq applied? t)))) | |
| 188 | (values term applied?)) | |
| 209 | 189 | (values term nil)))) |
| 210 | 190 | |
| 211 | ;;; | |
| 212 | 191 | ;;; normalize-sentence : axiom module -> axiom' Bool |
| 213 | 192 | ;;; normalize an axiom by reduction, returns the result. |
| 214 | 193 | ;;; NOTE: given axiom is preserved (not changed). |
| 215 | 194 | ;;; |
| 216 | 195 | (defun normalize-sentence (ax module) |
| 217 | (with-in-module (module) | |
| 218 | (let* ((target (rule-copy-canonicalized ax module)) | |
| 219 | (lhs (rule-lhs target)) | |
| 220 | (rhs (rule-rhs target)) | |
| 221 | (condition (rule-condition target)) | |
| 222 | (reduction-mode (if (eq (rule-type ax) :equation) | |
| 223 | :red | |
| 224 | :exec)) | |
| 225 | (applied nil) | |
| 226 | (app? nil)) | |
| 227 | (flet ((set-applied (val) | |
| 228 | (or app? (setq app? val)))) | |
| 229 | (with-citp-debug () | |
| 230 | (with-in-module (module) | |
| 231 | (format t "~%[NF] target:") | |
| 232 | (print-next) | |
| 233 | (print-axiom-brief target))) | |
| 234 | ;; normalize lhs | |
| 235 | (multiple-value-setq (lhs applied) | |
| 236 | (normalize-term-in module (reset-reduced-flag lhs) :red)) | |
| 237 | (set-applied applied) | |
| 238 | (when (eq reduction-mode :exec) | |
| 239 | (multiple-value-setq (lhs applied) (normalize-term-in module (reset-reduced-flag lhs) :exec)) | |
| 240 | (set-applied applied)) | |
| 241 | ;; normalize rhs | |
| 242 | (multiple-value-setq (rhs applied) (normalize-term-in module (reset-reduced-flag rhs))) | |
| 243 | (set-applied applied) | |
| 244 | ;; normalize condition | |
| 245 | (unless (is-true? condition) | |
| 246 | (multiple-value-setq (condition applied) | |
| 247 | (normalize-term-in module (reset-reduced-flag condition) :red)) | |
| 248 | (set-applied applied)) | |
| 249 | (setf (rule-lhs target) lhs) | |
| 250 | (setf (rule-rhs target) rhs) | |
| 251 | (setf (rule-condition target) condition) | |
| 252 | ;; | |
| 253 | (with-citp-debug () | |
| 254 | (if (not app?) | |
| 255 | (format t "~% ...not applied: ") | |
| 256 | (progn | |
| 257 | (print-next) | |
| 258 | (princ "==> ") (print-axiom-brief target)))) | |
| 259 | ;; | |
| 260 | (values target app?))))) | |
| 261 | ||
| 262 | ;;; | |
| 196 | (if-spoiler-on | |
| 197 | ;; normalize sentence only if :spoiler is on | |
| 198 | :then (let ((target (rule-copy-canonicalized ax module))) | |
| 199 | (with-in-module (module) | |
| 200 | (let ((lhs (rule-lhs target)) | |
| 201 | (rhs (rule-rhs target)) | |
| 202 | (condition (rule-condition target)) | |
| 203 | (reduction-mode (if (eq (rule-type ax) :equation) | |
| 204 | :red | |
| 205 | :exec)) | |
| 206 | (applied nil) | |
| 207 | (app? nil)) | |
| 208 | (flet ((set-applied (val) | |
| 209 | (or app? (setq app? val)))) | |
| 210 | (with-citp-debug () | |
| 211 | (with-in-module (module) | |
| 212 | (format t "~%[NF] target:") | |
| 213 | (print-next) | |
| 214 | (print-axiom-brief target))) | |
| 215 | ;; normalize lhs | |
| 216 | (multiple-value-setq (lhs applied) | |
| 217 | (normalize-term-in module (reset-reduced-flag lhs) :red)) | |
| 218 | (set-applied applied) | |
| 219 | (when (eq reduction-mode :exec) | |
| 220 | (multiple-value-setq (lhs applied) | |
| 221 | (normalize-term-in module (reset-reduced-flag lhs) :exec)) | |
| 222 | (set-applied applied)) | |
| 223 | ;; normalize rhs | |
| 224 | (multiple-value-setq (rhs applied) | |
| 225 | (normalize-term-in module (reset-reduced-flag rhs))) | |
| 226 | (set-applied applied) | |
| 227 | ;; normalize condition | |
| 228 | (unless (is-true? condition) | |
| 229 | (multiple-value-setq (condition applied) | |
| 230 | (normalize-term-in module (reset-reduced-flag condition) :red)) | |
| 231 | (set-applied applied)) | |
| 232 | (setf (rule-lhs target) lhs) | |
| 233 | (setf (rule-rhs target) rhs) | |
| 234 | (setf (rule-condition target) condition) | |
| 235 | ;; | |
| 236 | (with-citp-debug () | |
| 237 | (if (not app?) | |
| 238 | (format t "~% ...not applied: ") | |
| 239 | (progn | |
| 240 | (print-next) | |
| 241 | (princ "==> ") (print-axiom-brief target)))) | |
| 242 | ;; | |
| 243 | (return-from normalize-sentence (values target app?)))))) | |
| 244 | ;; do nothing if :spoiler is off | |
| 245 | :else (values ax nil))) | |
| 246 | ||
| 263 | 247 | ;;; is-contradiction : term term -> Bool |
| 264 | 248 | ;;; returns true if true ~ false, or false ~ true |
| 265 | 249 | ;;; |
| 250 | #| | |
| 266 | 251 | (defun is-contradiction (t1 t2) |
| 267 | 252 | (or (and (is-true? t1) (is-false? t2)) |
| 268 | 253 | (and (is-false? t1) (is-true? t2)))) |
| 269 | ||
| 270 | ;;; | |
| 254 | |# | |
| 255 | (defun is-contradiction (t1 t2) | |
| 256 | (declare (ignore t1 t2)) | |
| 257 | nil) | |
| 258 | ||
| 271 | 259 | ;;; sentence-is-satisfied : axiom module -> { :satisfied | :ct | nil } |
| 272 | 260 | ;;; |
| 273 | 261 | (defun sentence-is-satisfied (sentence module) |
| 274 | 262 | (let ((old-condition (rule-condition sentence))) |
| 275 | 263 | (multiple-value-bind (norm-sen app?) |
| 276 | (normalize-sentence sentence module) | |
| 264 | (normalize-sentence sentence module) | |
| 277 | 265 | (declare (ignore app?)) |
| 278 | 266 | (let ((lhs (rule-lhs norm-sen)) |
| 279 | (rhs (rule-rhs norm-sen)) | |
| 280 | (condition (rule-condition norm-sen)) | |
| 281 | (result nil)) | |
| 282 | (with-citp-debug () | |
| 283 | (format t "~%[satisfied?]: ") | |
| 284 | (print-axiom-brief norm-sen)) | |
| 285 | (cond ((and (not (is-true? old-condition)) (is-true? condition)) | |
| 286 | (if (is-contradiction lhs rhs) | |
| 287 | (setq result :ct) | |
| 288 | (setq result :st))) | |
| 289 | ((is-true? condition) ; originally the axiom was non-conditional | |
| 290 | (if (is-contradiction lhs rhs) | |
| 291 | (setq result :ct) | |
| 292 | (let ((x-lhs (normalize-term-in module (reset-reduced-flag lhs))) | |
| 293 | (x-rhs (normalize-term-in module (reset-reduced-flag rhs)))) | |
| 294 | (when (term-equational-equal x-lhs x-rhs) | |
| 295 | (setq result :st))))) | |
| 296 | (t (setq result nil))) | |
| 297 | (with-citp-debug () | |
| 298 | (format t "~% --> ~a: " result) | |
| 299 | (print-next) | |
| 300 | (print-axiom-brief norm-sen)) | |
| 301 | (values result norm-sen))))) | |
| 302 | ||
| 303 | ;;; check-contradiction : module -> Bool | |
| 304 | ;;; check if 'true => false' or 'false => true' can happen or not | |
| 305 | ;;; | |
| 306 | ||
| 267 | (rhs (rule-rhs norm-sen)) | |
| 268 | (condition (rule-condition norm-sen)) | |
| 269 | (result nil)) | |
| 270 | (with-citp-debug () | |
| 271 | (format t "~%[satisfied?]: ") | |
| 272 | (print-axiom-brief norm-sen)) | |
| 273 | (cond ((and (not (is-true? old-condition)) (is-true? condition)) | |
| 274 | (if (is-contradiction lhs rhs) | |
| 275 | (setq result :ct) | |
| 276 | (setq result :st))) | |
| 277 | ((is-true? condition) ; originally the axiom was non-conditional | |
| 278 | (if (is-contradiction lhs rhs) | |
| 279 | (setq result :ct) | |
| 280 | (let ((x-lhs (normalize-term-in module (reset-reduced-flag lhs))) | |
| 281 | (x-rhs (normalize-term-in module (reset-reduced-flag rhs)))) | |
| 282 | (when (term-equational-equal x-lhs x-rhs) | |
| 283 | (setq result :st))))) | |
| 284 | (t (setq result nil))) | |
| 285 | (with-citp-debug () | |
| 286 | (format t "~% --> ~a: " result) | |
| 287 | (print-next) | |
| 288 | (print-axiom-brief norm-sen)) | |
| 289 | (values result norm-sen))))) | |
| 290 | ||
| 291 | ;;; check-contradiction : goal -> Bool | |
| 292 | ;;; check if | |
| 293 | ;;; * 'true => false' or | |
| 294 | ;;; * 'false => true' or | |
| 295 | ;;; * (t = t) = false | |
| 307 | 296 | (defun check-true<=>false (module &optional (report-header nil)) |
| 308 | 297 | (with-in-module (module) |
| 309 | 298 | (let ((t-rules (method-rules-with-different-top *bool-true-meth*)) |
| 310 | (f-rules (method-rules-with-different-top *bool-false-meth*)) | |
| 311 | (ct-rule nil)) | |
| 299 | (f-rules (method-rules-with-different-top *bool-false-meth*)) | |
| 300 | (ct-rule nil)) | |
| 312 | 301 | (dolist (rule (append t-rules f-rules)) |
| 313 | (with-citp-debug () | |
| 314 | (format t "~%check true<=> false") | |
| 315 | (print-next) | |
| 316 | (print-axiom-brief rule)) | |
| 317 | (when (or (is-true? (rule-condition rule)) | |
| 318 | (is-true? (normalize-term-in module | |
| 319 | (reset-reduced-flag (term-copy-and-returns-list-variables | |
| 320 | (rule-condition rule)))))) | |
| 321 | (setq ct-rule rule) | |
| 322 | (with-citp-debug () | |
| 323 | (format t "~% CT found!")) | |
| 324 | (return nil))) | |
| 302 | (with-citp-debug () | |
| 303 | (format t "~%check true<=> false") | |
| 304 | (print-next) | |
| 305 | (print-axiom-brief rule)) | |
| 306 | (when (or (is-true? (rule-condition rule)) | |
| 307 | (is-true? (normalize-term-in module | |
| 308 | (reset-reduced-flag (term-copy-and-returns-list-variables | |
| 309 | (rule-condition rule)))))) | |
| 310 | (unless (term-equational-equal (rule-lhs rule) (rule-rhs rule)) | |
| 311 | (setq ct-rule rule) | |
| 312 | (with-citp-debug () | |
| 313 | (format t "~% CT found!")) | |
| 314 | (return nil)))) | |
| 325 | 315 | (when (and ct-rule report-header) |
| 326 | (format t "~%[~a] contradiction: " report-header) | |
| 327 | (let ((*print-indent* (+ 2 *print-indent*))) | |
| 328 | (print-next) | |
| 329 | (print-axiom-brief ct-rule))) | |
| 316 | (format t "~%[~a] contradiction: " report-header) | |
| 317 | (let ((*print-indent* (+ 2 *print-indent*))) | |
| 318 | (print-next) | |
| 319 | (print-axiom-brief ct-rule))) | |
| 330 | 320 | ct-rule))) |
| 331 | 321 | |
| 332 | (defun check-contradiction (module &optional (report-header nil)) | |
| 333 | (or (check-true<=>false module report-header) | |
| 334 | (with-in-module (module) | |
| 335 | (let ((true-term (make-applform-simple *bool-sort* *bool-true-meth* nil)) | |
| 336 | (false-term (make-applform-simple *bool-sort* *bool-false-meth* nil))) | |
| 337 | (let ((true=false (make-applform-simple *bool-sort* *eql-op* (list true-term false-term)))) | |
| 338 | (multiple-value-bind (t-result t-applied?) | |
| 339 | (normalize-term-in module true=false) | |
| 340 | (when (and t-applied? (is-true? t-result)) | |
| 341 | (when report-header | |
| 342 | (format t "~%[~a] contradiction: " report-header) | |
| 343 | (print-next) | |
| 344 | (format t " `true = false' can be derived!")) | |
| 345 | (return-from check-contradiction t)))))) | |
| 346 | nil)) | |
| 347 | ||
| 348 | ;;; | |
| 322 | (defun check-contradictory-assumptions (goal &optional (report-header nil)) | |
| 323 | (let ((ams (goal-assumptions goal)) | |
| 324 | (contra? nil)) | |
| 325 | (with-in-module ((goal-context goal)) | |
| 326 | (dolist (ax ams) | |
| 327 | (when (and (is-false? (rule-rhs ax)) | |
| 328 | (term-is-similar? (rule-lhs ax) (rule-rhs ax))) | |
| 329 | (when report-header | |
| 330 | (format t "~%[~a] contradictory assumption: " report-header) | |
| 331 | (print-next) | |
| 332 | (print-axiom-brief ax)) | |
| 333 | (setf contra? t))) | |
| 334 | contra?))) | |
| 335 | ||
| 336 | (defun check-contradiction (goal &optional (report-header nil)) | |
| 337 | (let ((module (goal-context goal))) | |
| 338 | (or (check-true<=>false module report-header) | |
| 339 | (check-contradictory-assumptions goal report-header) | |
| 340 | (with-in-module (module) | |
| 341 | (let ((true-term (make-applform-simple *bool-sort* *bool-true-meth* nil)) | |
| 342 | (false-term (make-applform-simple *bool-sort* *bool-false-meth* nil))) | |
| 343 | (let ((true=false (make-applform-simple *bool-sort* *eql-op* (list true-term false-term)))) | |
| 344 | (multiple-value-bind (t-result t-applied?) | |
| 345 | (normalize-term-in module true=false) | |
| 346 | (when (and t-applied? (is-true? t-result)) | |
| 347 | (when report-header | |
| 348 | (format t "~%[~a] contradiction: " report-header) | |
| 349 | (print-next) | |
| 350 | (format t " `true = false' can be derived!")) | |
| 351 | (return-from check-contradiction t)))))) | |
| 352 | nil))) | |
| 353 | ||
| 349 | 354 | ;;; check-le : goal -> goal' |
| 350 | 355 | ;;; |
| 351 | 356 | (defun check-le (goal) |
| 352 | 357 | (let ((mod (goal-context goal))) |
| 353 | 358 | (with-in-module (mod) |
| 354 | 359 | (let ((axs (module-equations mod)) |
| 355 | (ls-pats nil) | |
| 356 | (le-pats nil)) | |
| 357 | (dolist (ax axs) | |
| 358 | (block next | |
| 359 | (unless (is-true? (rule-condition ax)) (return-from next)) | |
| 360 | (when (axiom-variables ax) (return-from next)) | |
| 361 | (let ((lhs (rule-lhs ax))) | |
| 362 | (multiple-value-bind (match? subst) | |
| 363 | (@pat-match .ls-pat. lhs) | |
| 364 | (declare (ignore subst)) | |
| 365 | (cond (match? (push (cons (term-arg-1 lhs) (term-arg-2 lhs)) ls-pats)) | |
| 366 | (t (multiple-value-setq (match? subst) | |
| 367 | (@pat-match .le-pat. lhs)) | |
| 368 | (when match? (push (cons (term-arg-1 lhs) (term-arg-2 lhs)) le-pats)))))))) | |
| 369 | (let ((ls-r nil) | |
| 370 | (le-r nil)) | |
| 371 | (dolist (ls ls-pats) | |
| 372 | (let ((ls-pair (find (cdr ls) ls-pats :key #'car :test #'term-equational-equal)) | |
| 373 | (le-pair (find (cdr ls) le-pats :key #'car :test #'term-equational-equal))) | |
| 374 | ;; G1 < G2 < G3 | |
| 375 | (when ls-pair (push (cons (car ls) (cdr ls-pair)) ls-r)) ; < check G3 < G1 | |
| 376 | ;; G1 < G2 <= G3 | |
| 377 | (when le-pair (push (cons (car ls) (cdr le-pair)) le-r)))) ; <= check G3 <= G1 | |
| 378 | (dolist (le le-pats) | |
| 379 | (let ((ls-pair (find (cdr le) ls-pats :key #'car :test #'term-equational-equal)) | |
| 380 | (le-pair (find (cdr le) le-pats :key #'car :test #'term-equational-equal))) | |
| 381 | ;; G1 <= G2 < G3 | |
| 382 | (when ls-pair (push (cons (car le) (cdr ls-pair)) le-r)) ; check G3 <= G1 | |
| 383 | (when le-pair (push (cons (car le) (cdr le-pair)) ls-r)))) ; check G3 < G1 | |
| 384 | ;; | |
| 385 | (with-citp-debug () | |
| 386 | (format t "~%[le] check in goal ~s: " (goal-name goal)) | |
| 387 | (dolist (ls ls-r) | |
| 388 | (print-next) | |
| 389 | (term-print (cdr ls)) (princ " < ") | |
| 390 | (term-print (car ls))) | |
| 391 | (dolist (le le-r) | |
| 392 | (print-next) | |
| 393 | (term-print (cdr le)) (princ " <= ") | |
| 394 | (term-print (car le)))) | |
| 395 | (flet ((do-check (pat op) | |
| 396 | (dolist (ls pat) | |
| 397 | (let ((rg (make-applform-simple *bool-sort* | |
| 398 | op | |
| 399 | (list (cdr ls) (car ls))))) | |
| 400 | (with-citp-debug () | |
| 401 | (format t "~% target term : ") | |
| 402 | (term-print-with-sort rg)) | |
| 403 | (when (is-true? (normalize-term-in *current-module* rg)) | |
| 404 | ;; discharge the goal | |
| 405 | (let ((target (rule-copy-canonicalized (car (goal-targets goal)) | |
| 406 | *current-module*))) | |
| 407 | (setf (rule-labels target) (cons 'le (rule-labels target))) | |
| 408 | (setf (goal-targets goal) nil) | |
| 409 | (setf (goal-proved goal) (list target)) | |
| 410 | (format t "~%[le] discharged the goal ~s" (goal-name goal))) | |
| 411 | (return nil)))))) | |
| 412 | (do-check ls-r (term-head .ls-pat.)) | |
| 413 | (do-check le-r (term-head .le-pat.)))))))) | |
| 414 | ||
| 415 | ;;; | |
| 416 | ;;; make-new-assumption : module term [label] -> axiom | |
| 417 | ;;; | |
| 360 | (ls-pats nil) | |
| 361 | (le-pats nil)) | |
| 362 | (dolist (ax axs) | |
| 363 | (block next | |
| 364 | (unless (is-true? (rule-condition ax)) (return-from next)) | |
| 365 | (when (axiom-variables ax) (return-from next)) | |
| 366 | (let ((lhs (rule-lhs ax))) | |
| 367 | (multiple-value-bind (match? subst) | |
| 368 | (@pat-match .ls-pat. lhs) | |
| 369 | (declare (ignore subst)) | |
| 370 | (cond (match? (push (cons (term-arg-1 lhs) (term-arg-2 lhs)) ls-pats)) | |
| 371 | (t (multiple-value-setq (match? subst) | |
| 372 | (@pat-match .le-pat. lhs)) | |
| 373 | (when match? (push (cons (term-arg-1 lhs) (term-arg-2 lhs)) le-pats)))))))) | |
| 374 | (let ((ls-r nil) | |
| 375 | (le-r nil)) | |
| 376 | (dolist (ls ls-pats) | |
| 377 | (let ((ls-pair (find (cdr ls) ls-pats :key #'car :test #'term-equational-equal)) | |
| 378 | (le-pair (find (cdr ls) le-pats :key #'car :test #'term-equational-equal))) | |
| 379 | ;; G1 < G2 < G3 | |
| 380 | (when ls-pair (push (cons (car ls) (cdr ls-pair)) ls-r)) ; < check G3 < G1 | |
| 381 | ;; G1 < G2 <= G3 | |
| 382 | (when le-pair (push (cons (car ls) (cdr le-pair)) le-r)))) ; <= check G3 <= G1 | |
| 383 | (dolist (le le-pats) | |
| 384 | (let ((ls-pair (find (cdr le) ls-pats :key #'car :test #'term-equational-equal)) | |
| 385 | (le-pair (find (cdr le) le-pats :key #'car :test #'term-equational-equal))) | |
| 386 | ;; G1 <= G2 < G3 | |
| 387 | (when ls-pair (push (cons (car le) (cdr ls-pair)) le-r)) ; check G3 <= G1 | |
| 388 | (when le-pair (push (cons (car le) (cdr le-pair)) ls-r)))) ; check G3 < G1 | |
| 389 | ;; | |
| 390 | (with-citp-debug () | |
| 391 | (format t "~%[le] check in goal ~s: " (goal-name goal)) | |
| 392 | (dolist (ls ls-r) | |
| 393 | (print-next) | |
| 394 | (term-print (cdr ls)) (princ " < ") | |
| 395 | (term-print (car ls))) | |
| 396 | (dolist (le le-r) | |
| 397 | (print-next) | |
| 398 | (term-print (cdr le)) (princ " <= ") | |
| 399 | (term-print (car le)))) | |
| 400 | (flet ((do-check (pat op) | |
| 401 | (dolist (ls pat) | |
| 402 | (let ((rg (make-applform-simple *bool-sort* | |
| 403 | op | |
| 404 | (list (cdr ls) (car ls))))) | |
| 405 | (with-citp-debug () | |
| 406 | (format t "~% target term : ") | |
| 407 | (term-print-with-sort rg)) | |
| 408 | (when (is-true? (normalize-term-in *current-module* rg)) | |
| 409 | ;; discharge the goal | |
| 410 | (let ((target (rule-copy-canonicalized (car (goal-targets goal)) | |
| 411 | *current-module*))) | |
| 412 | (setf (rule-labels target) (cons 'le (rule-labels target))) | |
| 413 | (setf (goal-targets goal) nil) | |
| 414 | (setf (goal-proved goal) (list target)) | |
| 415 | (format t "~%[le] discharged the goal ~s" (goal-name goal))) | |
| 416 | (return nil)))))) | |
| 417 | (do-check ls-r (term-head .ls-pat.)) | |
| 418 | (do-check le-r (term-head .le-pat.)))))))) | |
| 419 | ||
| 420 | ;;; make-new-assumption : module lhs rhs -> new-lhs new-rhs axiom-type | |
| 421 | ;;; | |
| 422 | (defun boolean-constant? (term) | |
| 423 | (or (is-true? term)(is-false? term))) | |
| 424 | ||
| 425 | (defun simplify-boolean-axiom (lhs rhs) | |
| 426 | (let ((r-lhs lhs) | |
| 427 | (r-rhs rhs) | |
| 428 | (type :equation)) | |
| 429 | (with-citp-debug () | |
| 430 | (format t "~%== simplify: ") | |
| 431 | (format t "~% lhs = ")(term-print-with-sort lhs) | |
| 432 | (format t "~% rhs = ")(term-print-with-sort rhs)) | |
| 433 | (cond ((method= *eql-op* (term-method lhs)) | |
| 434 | (with-citp-debug () | |
| 435 | (format t "~%** case _=_")) | |
| 436 | ;; (T1 = T2) = true/false ==> T1 = T2 | |
| 437 | (let* ((arg1 (term-arg-1 lhs)) | |
| 438 | (arg2 (term-arg-2 lhs)) | |
| 439 | (arg1-is-bconstant (boolean-constant? arg1)) | |
| 440 | (arg2-is-bconstant (boolean-constant? arg2))) | |
| 441 | (cond ((is-true? rhs) | |
| 442 | (with-citp-debug () | |
| 443 | (format t "~%-- (T1 = T2) = true")) | |
| 444 | ;; (T1 = T2) = true | |
| 445 | (cond ((method= (term-head arg1) (term-head arg2)) | |
| 446 | ;; (T1 = T1) = true : dangerous tautology | |
| 447 | (with-citp-debug () | |
| 448 | (format t "~%-- (T = T) = true, tautology.")) | |
| 449 | (let ((*chaos-quiet* nil)) | |
| 450 | (with-output-chaos-warning () | |
| 451 | (format t "Found the new assumption is tautology:") | |
| 452 | (print-next) | |
| 453 | (format t "LHS: ") (term-print-with-sort arg1) | |
| 454 | (print-next) | |
| 455 | (format t "RHS: ") (term-print-with-sort arg2) | |
| 456 | (format t "~%... ignored."))) | |
| 457 | (setf r-lhs nil | |
| 458 | r-rhs nil)) | |
| 459 | ((and arg1-is-bconstant arg2-is-bconstant) | |
| 460 | (with-citp-debug () | |
| 461 | (format t "~%-- (true = false) = true, (false = true) = true.")) | |
| 462 | ;; (true = false), (false = true) = true . | |
| 463 | ;; contradiction | |
| 464 | (setf r-lhs arg1 | |
| 465 | r-rhs arg2) | |
| 466 | (let ((*print-indent* (+ 2 *print-indent*))) | |
| 467 | (let ((*chaos-quiet* nil)) | |
| 468 | (with-output-chaos-warning () | |
| 469 | (format t "Caution!, you are introducing contradiction:") | |
| 470 | (print-next) | |
| 471 | (format t "LHS: ") (term-print-with-sort r-lhs) | |
| 472 | (print-next) | |
| 473 | (format t "RHS: ") (term-print-with-sort r-rhs))))) | |
| 474 | (t | |
| 475 | ;; (T1 = T2) = true --> T1 = T2 | |
| 476 | (with-citp-debug () | |
| 477 | (format t "~% trying to simplify..")) | |
| 478 | (setf r-lhs (if arg1-is-bconstant | |
| 479 | arg2 | |
| 480 | arg1)) | |
| 481 | (setf r-rhs (if arg1-is-bconstant | |
| 482 | arg1 | |
| 483 | arg2))))) | |
| 484 | ((is-false? rhs) | |
| 485 | ;; (T1 = T2) = false | |
| 486 | (with-citp-debug () | |
| 487 | (format t "~%-- (T1 = T2) = false")) | |
| 488 | (cond ((method= (term-head arg1) (term-head arg2)) | |
| 489 | ;; (T = T) = false | |
| 490 | ;; contradiction | |
| 491 | (with-citp-debug () | |
| 492 | (format t "~% (T = T) = false, contradiction!")) | |
| 493 | (let ((*print-indent* (+ 2 *print-indent*)) | |
| 494 | (*chaos-quiet* nil)) | |
| 495 | (with-output-chaos-warning () | |
| 496 | (format t "Caution! you are introducing contradiction:") | |
| 497 | (print-next) | |
| 498 | (format t "LHS: ") (term-print-with-sort lhs) | |
| 499 | (print-next) | |
| 500 | (format t "RHS: ") (term-print-with-sort rhs)))) | |
| 501 | ((and arg1-is-bconstant arg2-is-bconstant) | |
| 502 | ;; (true = false) = false, (false = true) = false | |
| 503 | (with-citp-debug () | |
| 504 | (format t "~%(true = false) = false, (false = true) = false")) | |
| 505 | (let ((*print-indent* (+ 2 *print-indent*)) | |
| 506 | (*chaos-quiet* nil)) | |
| 507 | (with-output-chaos-warning () | |
| 508 | (format t "Redundant assumption: ") | |
| 509 | (print-next) | |
| 510 | (format t "LHS: ") (term-print-with-sort lhs) | |
| 511 | (print-next) | |
| 512 | (format t "RHS: ") (term-print-with-sort rhs)) | |
| 513 | (format t "~%... ignored.")) | |
| 514 | (setf r-lhs nil | |
| 515 | r-rhs nil)) | |
| 516 | (t | |
| 517 | ;; | |
| 518 | (with-citp-debug () | |
| 519 | (format t "-- trying to simplify..")) | |
| 520 | (if (is-true? arg1) | |
| 521 | (setf r-lhs arg2 | |
| 522 | r-rhs *bool-false*) | |
| 523 | (if (is-true? arg2) | |
| 524 | (setf r-lhs arg1 | |
| 525 | r-rhs *bool-false*) | |
| 526 | (if (is-false? arg1) | |
| 527 | (setf r-lhs arg2 | |
| 528 | r-rhs *bool-true*) | |
| 529 | (if (is-false? arg2) | |
| 530 | (setf r-lhs arg1 | |
| 531 | r-rhs *bool-true*) | |
| 532 | (setf r-lhs lhs | |
| 533 | r-rhs rhs))))))))))) | |
| 534 | ((method= *bool-match* (term-method lhs)) | |
| 535 | ;; (T1 := T2) = true ==> T2 = T1 | |
| 536 | (setf r-lhs (term-arg-2 lhs) | |
| 537 | r-rhs (term-arg-1 lhs))) | |
| 538 | ((method= *rwl-predicate* (term-method lhs)) | |
| 539 | ;; (T1 => T2) = true ==> T1 => T2 | |
| 540 | (setf r-lhs (term-arg-1 lhs) | |
| 541 | r-rhs (term-arg-2 lhs)) | |
| 542 | (setq type :rule))) | |
| 543 | ||
| 544 | (with-citp-debug () | |
| 545 | (when r-lhs | |
| 546 | (format t "~%=> ") | |
| 547 | (format t "~%LHS: ")(term-print-with-sort r-lhs) | |
| 548 | (format t "~%RHS: ")(term-print-with-sort r-rhs) | |
| 549 | (format t "~%type: ~a" type))) | |
| 550 | (if r-lhs | |
| 551 | (values r-lhs r-rhs type) | |
| 552 | (values nil nil nil)))) | |
| 553 | ||
| 418 | 554 | (defun make-new-assumption (module lhs &optional (label-prefix nil)) |
| 419 | 555 | (with-in-module (module) |
| 420 | 556 | (let ((r-lhs lhs) |
| 421 | (r-rhs *bool-true*) | |
| 422 | (type :equation)) | |
| 557 | (r-rhs *bool-true*) | |
| 558 | (type :equation)) | |
| 423 | 559 | (when (method= *eql-op* (term-method lhs)) |
| 424 | ;; (T1 = T2) = true ==> T1 = T2 | |
| 425 | (setf r-lhs (term-arg-1 lhs) | |
| 426 | r-rhs (term-arg-2 lhs))) | |
| 560 | ;; (T1 = T2) = true ==> T1 = T2 | |
| 561 | (setf r-lhs (term-arg-1 lhs) | |
| 562 | r-rhs (term-arg-2 lhs))) | |
| 427 | 563 | (when (method= *bool-match* (term-method lhs)) |
| 428 | ;; (T1 := T2) = true ==> T2 = T1 | |
| 429 | (setf r-lhs (term-arg-2 lhs) | |
| 430 | r-rhs (term-arg-1 lhs))) | |
| 564 | ;; (T1 := T2) = true ==> T2 = T1 | |
| 565 | (setf r-lhs (term-arg-2 lhs) | |
| 566 | r-rhs (term-arg-1 lhs))) | |
| 431 | 567 | (when (method= *rwl-predicate* (term-method lhs)) |
| 432 | ;; (T1 => T2) = true ==> T1 => T2 | |
| 433 | (setf r-lhs (term-arg-1 lhs) | |
| 434 | r-rhs (term-arg-2 lhs)) | |
| 435 | (setq type :rule)) | |
| 568 | ;; (T1 => T2) = true ==> T1 => T2 | |
| 569 | (setf r-lhs (term-arg-1 lhs) | |
| 570 | r-rhs (term-arg-2 lhs)) | |
| 571 | (setq type :rule)) | |
| 436 | 572 | (compile-module module) |
| 437 | 573 | (let ((axiom (make-rule :lhs (normalize-term-in module (reset-reduced-flag r-lhs)) |
| 438 | :rhs (normalize-term-in module (reset-reduced-flag r-rhs)) | |
| 439 | :condition *bool-true* | |
| 440 | :type type | |
| 441 | :behavioural nil | |
| 442 | :labels (if label-prefix (list label-prefix) nil)))) | |
| 443 | ;; check tautology | |
| 444 | (when (term-equational-equal r-lhs r-rhs) | |
| 445 | (return-from make-new-assumption nil)) | |
| 446 | (with-citp-debug () | |
| 447 | (format t "~%** new assumption: ") | |
| 448 | (print-axiom-brief axiom)) | |
| 449 | axiom)))) | |
| 450 | ||
| 451 | ;;; | |
| 574 | :rhs (normalize-term-in module (reset-reduced-flag r-rhs)) | |
| 575 | :condition *bool-true* | |
| 576 | :type type | |
| 577 | :behavioural nil | |
| 578 | :labels (if label-prefix (list label-prefix) nil)))) | |
| 579 | ;; check tautology | |
| 580 | (when (term-equational-equal r-lhs r-rhs) | |
| 581 | (return-from make-new-assumption nil)) | |
| 582 | (with-citp-debug () | |
| 583 | (format t "~%** new assumption: ") | |
| 584 | (print-axiom-brief axiom)) | |
| 585 | axiom)))) | |
| 586 | ||
| 452 | 587 | ;;; condition->axioms : module term -> List(axiom) |
| 453 | 588 | ;;; |
| 454 | 589 | (defun condition->axioms (module condition &optional (rule-label nil)) |
| 455 | 590 | (with-in-module (module) |
| 456 | 591 | (let ((axs nil) |
| 457 | (cps nil)) | |
| 592 | (cps nil)) | |
| 458 | 593 | (if (method= *bool-cond-op* (term-head condition)) |
| 459 | (let ((subs (list-assoc-subterms condition *bool-cond-op*))) | |
| 460 | (dolist (sub subs) | |
| 461 | (push (term-copy-and-returns-list-variables sub) cps))) | |
| 462 | (setq cps (list (term-copy-and-returns-list-variables condition)))) | |
| 594 | (let ((subs (list-assoc-subterms condition *bool-cond-op*))) | |
| 595 | (dolist (sub subs) | |
| 596 | (push (term-copy-and-returns-list-variables sub) cps))) | |
| 597 | (setq cps (list (term-copy-and-returns-list-variables condition)))) | |
| 463 | 598 | (dolist (c cps) |
| 464 | (let ((new-ax (make-new-assumption module c rule-label))) | |
| 465 | (when new-ax | |
| 466 | (compute-rule-method new-ax) | |
| 467 | (pushnew new-ax axs :test #'rule-is-similar?)))) | |
| 599 | (let ((new-ax (make-new-assumption module c rule-label))) | |
| 600 | (when new-ax | |
| 601 | (compute-rule-method new-ax) | |
| 602 | (pushnew new-ax axs :test #'rule-is-similar?)))) | |
| 468 | 603 | (with-citp-debug () |
| 469 | (format t "~%[~a] generated axioms:" rule-label) | |
| 470 | (dolist (ax axs) | |
| 471 | (print-next) | |
| 472 | (print-axiom-brief ax))) | |
| 604 | (format t "~%[~a] generated axioms:" rule-label) | |
| 605 | (dolist (ax axs) | |
| 606 | (print-next) | |
| 607 | (print-axiom-brief ax))) | |
| 473 | 608 | axs))) |
| 474 | 609 | |
| 475 | 610 | (defun axiom-is-an-instance-of (ax cx module) |
| 480 | 615 | (print-next) |
| 481 | 616 | (format t "* cx: ") (print-axiom-brief cx)) |
| 482 | 617 | (multiple-value-bind (gs subst no-match E-equal) |
| 483 | (funcall (rule-first-match-method cx) (rule-lhs cx) (rule-lhs ax)) | |
| 618 | (funcall (rule-first-match-method cx) (rule-lhs cx) (rule-lhs ax)) | |
| 484 | 619 | (when no-match (return-from axiom-is-an-instance-of nil)) |
| 485 | 620 | (when e-equal (setq subst nil)) |
| 486 | 621 | (let ((pat-instance (substitution-image-simplifying subst (rule-rhs cx))) |
| 487 | (t-instance (rule-rhs ax)) | |
| 488 | (next-match-method nil)) | |
| 489 | (with-citp-debug () | |
| 490 | (format t "~%* matched: ") | |
| 491 | (print-substitution subst) | |
| 492 | (print-next) | |
| 493 | (format t "pat: ") (term-print-with-sort pat-instance) | |
| 494 | (print-next) | |
| 495 | (format t "rhs: ") (term-print-with-sort t-instance)) | |
| 496 | ||
| 497 | (when (term-equational-equal t-instance pat-instance) | |
| 498 | (return-from axiom-is-an-instance-of t)) | |
| 499 | ;; try other match | |
| 500 | (setq next-match-method (rule-next-match-method cx)) | |
| 501 | (loop | |
| 502 | (multiple-value-setq (gs subst no-match) | |
| 503 | (funcall next-match-method gs)) | |
| 504 | (when no-match (return-from axiom-is-an-instance-of nil)) | |
| 505 | (setq pat-instance (substitution-image-simplifying subst (rule-rhs cx))) | |
| 506 | (when (term-equational-equal t-instance pat-instance) | |
| 507 | (return-from axiom-is-an-instance-of t)))) | |
| 622 | (t-instance (rule-rhs ax)) | |
| 623 | (next-match-method nil)) | |
| 624 | (with-citp-debug () | |
| 625 | (format t "~%* matched: ") | |
| 626 | (print-substitution subst) | |
| 627 | (print-next) | |
| 628 | (format t "pat: ") (term-print-with-sort pat-instance) | |
| 629 | (print-next) | |
| 630 | (format t "rhs: ") (term-print-with-sort t-instance)) | |
| 631 | ||
| 632 | (when (term-equational-equal t-instance pat-instance) | |
| 633 | (return-from axiom-is-an-instance-of t)) | |
| 634 | ;; try other match | |
| 635 | (setq next-match-method (rule-next-match-method cx)) | |
| 636 | (loop | |
| 637 | (multiple-value-setq (gs subst no-match) | |
| 638 | (funcall next-match-method gs)) | |
| 639 | (when no-match (return-from axiom-is-an-instance-of nil)) | |
| 640 | (setq pat-instance (substitution-image-simplifying subst (rule-rhs cx))) | |
| 641 | (when (term-equational-equal t-instance pat-instance) | |
| 642 | (return-from axiom-is-an-instance-of t)))) | |
| 508 | 643 | nil))) |
| 509 | 644 | |
| 510 | 645 | (defun check-ct-with-axioms (goal axioms &optional report-header) |
| 511 | 646 | (declare (type goal goal) |
| 512 | (type list axioms)) | |
| 647 | (type list axioms)) | |
| 513 | 648 | (with-in-module ((goal-context goal)) |
| 514 | 649 | (let ((tf-rules (append (method-rules-with-different-top *bool-true-meth*) |
| 515 | (method-rules-with-different-top *bool-false-meth*)))) | |
| 516 | ;; first do light weight check | |
| 517 | (dolist (rule tf-rules) | |
| 518 | (when (is-true? (rule-condition rule)) | |
| 519 | ;; already CT | |
| 520 | (when report-header | |
| 521 | (format t "~%[~a] found contradiction: " report-header) | |
| 522 | (print-axiom-brief rule)) | |
| 523 | (return-from check-ct-with-axioms :ct))) | |
| 524 | (dolist (rule tf-rules) | |
| 525 | (let ((cond-axioms (condition->axioms *current-module* (rule-condition rule)))) | |
| 526 | (let ((remaining cond-axioms)) | |
| 527 | (do* ((cax (car remaining) (car remaining)) | |
| 528 | (axs axioms (cdr axs)) | |
| 529 | (ax (car axs) (car axs))) | |
| 530 | ((or (null cax) (null axs))) | |
| 531 | (when (axiom-is-an-instance-of ax cax *current-module*) | |
| 532 | (setq remaining (remove cax remaining)))) | |
| 533 | (unless remaining | |
| 534 | (when report-header | |
| 535 | (format t "~%[~a] found contradiction: " report-header) | |
| 536 | (print-axiom-brief rule)) | |
| 537 | (return-from check-ct-with-axioms :ct))))) | |
| 538 | nil))) | |
| 650 | (method-rules-with-different-top *bool-false-meth*)))) | |
| 651 | ;; first do light weight check | |
| 652 | (dolist (rule tf-rules) | |
| 653 | (when (is-true? (rule-condition rule)) | |
| 654 | ;; already CT | |
| 655 | (when report-header | |
| 656 | (format t "~%[~a] found contradiction: " report-header) | |
| 657 | (print-axiom-brief rule)) | |
| 658 | (return-from check-ct-with-axioms :ct))) | |
| 659 | (dolist (rule tf-rules) | |
| 660 | (let ((cond-axioms (condition->axioms *current-module* (rule-condition rule)))) | |
| 661 | (let ((remaining cond-axioms)) | |
| 662 | (do* ((cax (car remaining) (car remaining)) | |
| 663 | (axs axioms (cdr axs)) | |
| 664 | (ax (car axs) (car axs))) | |
| 665 | ((or (null cax) (null axs))) | |
| 666 | (when (axiom-is-an-instance-of ax cax *current-module*) | |
| 667 | (setq remaining (remove cax remaining)))) | |
| 668 | (unless remaining | |
| 669 | (when report-header | |
| 670 | (format t "~%[~a] found contradiction: " report-header) | |
| 671 | (print-axiom-brief rule)) | |
| 672 | (return-from check-ct-with-axioms :ct))))) | |
| 673 | nil))) | |
| 539 | 674 | |
| 540 | 675 | ;;; check-sentence&mark-label : sentence module -> (<result> <normalized-sentence> <origina-sentence>) |
| 541 | 676 | ;;; |
| 542 | (defun check-sentence&mark-label (sentence module &optional (report-header nil)) | |
| 543 | (with-in-module (module) | |
| 544 | (flet ((make-st-label () | |
| 545 | (let ((lbl (or report-header 'st))) | |
| 546 | (cons lbl (rule-labels sentence)))) | |
| 547 | (make-ct-label () | |
| 548 | (let ((lbl (if report-header | |
| 549 | (intern (format nil "CT-~A" report-header)) | |
| 550 | 'ct))) | |
| 551 | (cons lbl (rule-labels sentence)))) | |
| 552 | (make-ic-label () | |
| 553 | (let ((lbl (if report-header | |
| 554 | (intern (format nil "IC-~A" report-header)) | |
| 555 | 'ic))) | |
| 556 | (cons lbl (rule-labels sentence))))) | |
| 557 | ;; | |
| 558 | (let ((target sentence) | |
| 559 | (res nil) | |
| 560 | (*print-indent* (+ 2 *print-indent*)) | |
| 561 | (*print-line-limit* 80) | |
| 562 | (*print-xmode* :fancy)) | |
| 563 | (if (check-contradiction module report-header) | |
| 564 | (setq res :ct) | |
| 565 | (multiple-value-setq (res target) | |
| 566 | (sentence-is-satisfied sentence *current-module*))) | |
| 567 | (when res | |
| 568 | ;; discharged by certain reson | |
| 569 | (setq sentence (rule-copy-canonicalized sentence *current-module*))) | |
| 570 | (case res | |
| 571 | (:st (when report-header | |
| 572 | (format t "~%[~a] discharged: " report-header) | |
| 573 | (print-next) | |
| 574 | (print-axiom-brief sentence)) | |
| 575 | (setf (rule-labels sentence) (make-st-label)) | |
| 576 | (values :st target sentence)) | |
| 577 | (:ct (when report-header | |
| 578 | (format t "~%[~a] discharged: " report-header) | |
| 579 | (print-next) | |
| 580 | (print-axiom-brief sentence)) | |
| 581 | (setf (rule-labels sentence) (make-ct-label)) | |
| 582 | (values :ct target sentence)) | |
| 583 | (:ic (when report-header | |
| 584 | (format t "~%[~a] discharged: " report-header) | |
| 585 | (print-next) | |
| 586 | (print-axiom-brief sentence)) | |
| 587 | (setf (rule-labels sentence) (make-ic-label)) | |
| 588 | (values :ic target sentence)) | |
| 589 | (otherwise (values nil target sentence))))))) | |
| 590 | ||
| 591 | ;;; | |
| 677 | (defun check-sentence&mark-label (sentence goal &optional (report-header nil)) | |
| 678 | (flet ((make-st-label () | |
| 679 | (let ((lbl (or report-header 'st))) | |
| 680 | (cons lbl (rule-labels sentence)))) | |
| 681 | (make-ct-label () | |
| 682 | (let ((lbl (if report-header | |
| 683 | (intern (format nil "CT-~A" report-header)) | |
| 684 | 'ct))) | |
| 685 | (cons lbl (rule-labels sentence)))) | |
| 686 | (make-ic-label () | |
| 687 | (let ((lbl (if report-header | |
| 688 | (intern (format nil "IC-~A" report-header)) | |
| 689 | 'ic))) | |
| 690 | (cons lbl (rule-labels sentence))))) | |
| 691 | ;; | |
| 692 | (let ((module (goal-context goal))) | |
| 693 | (with-in-module (module) | |
| 694 | (let ((target sentence) | |
| 695 | (res nil) | |
| 696 | (*print-indent* (+ 2 *print-indent*)) | |
| 697 | (*print-line-limit* 80) | |
| 698 | (*print-xmode* :fancy)) | |
| 699 | (if (check-contradiction goal report-header) | |
| 700 | (setq res :ct) | |
| 701 | (multiple-value-setq (res target) | |
| 702 | (sentence-is-satisfied sentence module))) | |
| 703 | (when res | |
| 704 | ;; discharged by certain reson | |
| 705 | (setq sentence (rule-copy-canonicalized sentence *current-module*))) | |
| 706 | (with-in-module (module) | |
| 707 | ;; check how did we did dischage | |
| 708 | (case res | |
| 709 | (:st (when report-header | |
| 710 | (format t "~%[~a] discharged: " report-header) | |
| 711 | (print-next) | |
| 712 | (print-axiom-brief sentence)) | |
| 713 | (setf (rule-labels sentence) (make-st-label)) | |
| 714 | (values :st target sentence)) | |
| 715 | (:ct (when report-header | |
| 716 | (format t "~%[~a] discharged: " report-header) | |
| 717 | (print-next) | |
| 718 | (print-axiom-brief sentence)) | |
| 719 | (setf (rule-labels sentence) (make-ct-label)) | |
| 720 | (values :ct target sentence)) | |
| 721 | (:ic (when report-header | |
| 722 | (format t "~%[~a] discharged: " report-header) | |
| 723 | (print-next) | |
| 724 | (print-axiom-brief sentence)) | |
| 725 | (setf (rule-labels sentence) (make-ic-label)) | |
| 726 | (values :ic target sentence)) | |
| 727 | ;; could not discharge | |
| 728 | (otherwise (values nil target sentence))))))))) | |
| 729 | ||
| 592 | 730 | ;;; set-operator-rewrite-rule : module axiom -> void |
| 593 | 731 | ;;; |
| 594 | 732 | (defun set-operator-rewrite-rule (module axiom) |
| 595 | 733 | (when (term-is-applform? (rule-lhs axiom)) |
| 596 | 734 | (add-rule-to-method axiom (term-head (rule-lhs axiom)) (module-opinfo-table module)))) |
| 597 | 735 | |
| 598 | ;;; | |
| 736 | ;;; add-assumptions-to-goal : goal assumptions -> void | |
| 737 | ;;; | |
| 738 | (defun add-assumptions-to-goal (goal assumptions) | |
| 739 | (let ((module (goal-context goal))) | |
| 740 | (with-in-module (module) | |
| 741 | (dolist (ax assumptions) | |
| 742 | (adjoin-axiom-to-module module ax) | |
| 743 | (set-operator-rewrite-rule module ax)) | |
| 744 | (compile-module module t)))) | |
| 745 | ||
| 599 | 746 | ;;; check-goal-is-satisfied : goal -> ( <result> <normalized-target> <possibly-marked-target> ) |
| 600 | 747 | ;;; |
| 601 | 748 | (defun check-goal-is-satisfied (goal &optional (report-header nil)) |
| 602 | 749 | (when (cdr (goal-targets goal)) |
| 603 | 750 | (with-output-chaos-error ('invalid-proof-seq) |
| 604 | 751 | (format t "Internal error. more than one target!"))) |
| 605 | (let ((target (car (goal-targets goal)))) | |
| 606 | (multiple-value-bind (discharged normalized-target original-target) | |
| 607 | (do-check-sentence target goal report-header) | |
| 608 | (when discharged | |
| 609 | (setf (goal-targets goal) nil | |
| 610 | (goal-proved goal) (list original-target))) | |
| 611 | (values discharged normalized-target original-target)))) | |
| 612 | ||
| 752 | (if-spoiler-on | |
| 753 | :then (let ((target (car (goal-targets goal)))) | |
| 754 | (multiple-value-bind (discharged normalized-target original-target) | |
| 755 | (do-check-sentence target goal report-header) | |
| 756 | (when discharged | |
| 757 | (setf (goal-targets goal) nil | |
| 758 | (goal-proved goal) (list original-target))) | |
| 759 | (values discharged normalized-target original-target))) | |
| 760 | :else (values nil nil (car (goal-targets goal))))) | |
| 613 | 761 | |
| 614 | 762 | (defun do-check-sentence (target goal &optional report-header) |
| 615 | 763 | (let ((mod (goal-context goal))) |
| 616 | (with-in-module (mod) | |
| 617 | (multiple-value-bind (result norm-target marked-target) | |
| 618 | (check-sentence&mark-label target *current-module* report-header) | |
| 619 | (cond (result | |
| 620 | ;; goal is dischared by some reason | |
| 621 | ;; | |
| 622 | ) | |
| 623 | ((and (is-true? (rule-condition target)) | |
| 624 | (eq (rule-type target) :equation)) | |
| 625 | (setf target (rule-copy-canonicalized target *current-module*)) | |
| 626 | (setf (rule-lhs target) (make-applform-simple *bool-sort* | |
| 627 | *eql-op* | |
| 628 | (list (rule-lhs target) | |
| 629 | (rule-rhs target))) | |
| 630 | (rule-rhs target) *bool-true*) | |
| 631 | (multiple-value-bind (res-2 norm-target-2 marked-target-2) | |
| 632 | (check-sentence&mark-label target *current-module* report-header) | |
| 633 | (declare (ignore norm-target-2 marked-target-2)) | |
| 634 | (when res-2 | |
| 635 | (setf result res-2)))) | |
| 636 | (t ;; nothing to do | |
| 637 | )) | |
| 638 | (values result norm-target marked-target))))) | |
| 639 | ||
| 640 | ;;; | |
| 764 | (multiple-value-bind (result norm-target marked-target) | |
| 765 | (check-sentence&mark-label target goal report-header) | |
| 766 | (cond (result | |
| 767 | ;; goal has been dischared already by some reason | |
| 768 | ) | |
| 769 | ((and (is-true? (rule-condition target)) | |
| 770 | (eq (rule-type target) :equation)) | |
| 771 | (setf target (rule-copy-canonicalized target mod)) | |
| 772 | (setf (rule-lhs target) (make-applform-simple *bool-sort* | |
| 773 | *eql-op* ; _=_ | |
| 774 | (list (rule-lhs target) | |
| 775 | (rule-rhs target))) | |
| 776 | (rule-rhs target) *bool-true*) | |
| 777 | (multiple-value-bind (res-2 norm-target-2 marked-target-2) | |
| 778 | (check-sentence&mark-label target goal report-header) | |
| 779 | (declare (ignore norm-target-2 marked-target-2)) | |
| 780 | (when res-2 | |
| 781 | (setf result res-2)))) | |
| 782 | (t ;; nothing to do | |
| 783 | )) | |
| 784 | (values result norm-target marked-target)))) | |
| 785 | ||
| 641 | 786 | ;;; try-prove-with-axioms : module List(axiom) axiom : -> { :satisfied | :ct | nil } |
| 642 | 787 | ;;; |
| 643 | 788 | (defparameter .trial-context-module. (%module-decl* "trial-dummy" :object :user nil)) |
| 644 | 789 | |
| 645 | (defun try-prove-with-axioms (module axioms target &optional (report-header nil)) | |
| 646 | (let ((*chaos-quiet* t)) | |
| 647 | (let ((tmodule (eval-ast .trial-context-module.))) | |
| 648 | (import-module tmodule :including module) | |
| 649 | (with-in-module (tmodule) | |
| 650 | (dolist (ax axioms) | |
| 651 | (adjoin-axiom-to-module tmodule ax) | |
| 652 | (set-operator-rewrite-rule tmodule ax)) | |
| 653 | (compile-module tmodule t) | |
| 654 | ;; first we check contradiction | |
| 655 | (if (check-contradiction tmodule report-header) | |
| 656 | :ct | |
| 657 | ;; the module is consistent, try | |
| 658 | (sentence-is-satisfied target tmodule)))))) | |
| 790 | (defun try-prove-with-axioms (goal axioms target &optional (report-header nil)) | |
| 791 | (let ((module (goal-context goal))) | |
| 792 | (with-citp-env () | |
| 793 | (let ((tmodule (eval-ast .trial-context-module.))) | |
| 794 | (import-module tmodule :including module) | |
| 795 | (with-in-module (tmodule) | |
| 796 | (dolist (ax axioms) | |
| 797 | (adjoin-axiom-to-module tmodule ax) | |
| 798 | (set-operator-rewrite-rule tmodule ax)) | |
| 799 | (compile-module tmodule t) | |
| 800 | ;; first we check contradiction | |
| 801 | (if (check-contradiction goal report-header) | |
| 802 | :ct | |
| 803 | ;; the module is consistent, try | |
| 804 | (sentence-is-satisfied target tmodule))))))) | |
| 805 | ||
| 806 | ;;; already-proved? : | |
| 807 | ;;; | |
| 808 | (defun already-proved? (node-or-goal &optional (warn t)) | |
| 809 | (declare (type (or ptree-node goal) node-or-goal)) | |
| 810 | (let ((goal (if (ptree-node-p node-or-goal) | |
| 811 | (ptree-node-goal node-or-goal) | |
| 812 | node-or-goal))) | |
| 813 | (unless (goal-is-discharged goal) | |
| 814 | (return-from already-proved? nil)) | |
| 815 | (when warn | |
| 816 | (with-output-chaos-warning () | |
| 817 | (format t "** The goal ~s has already been proved!." | |
| 818 | (goal-name goal)))) | |
| 819 | t)) | |
| 659 | 820 | |
| 660 | 821 | ;;; **************************************************************************** |
| 661 | 822 | ;;; Tactic executors |
| 674 | 835 | |
| 675 | 836 | (defun apply-nil-internal (node sentences &optional (all-together nil) (tactic .tactic-nil.)) |
| 676 | 837 | (declare (type ptree-node node) |
| 677 | (type list sentences)) | |
| 838 | (type list sentences)) | |
| 678 | 839 | (let ((goals nil)) |
| 679 | 840 | (cond (all-together |
| 680 | (let ((ngoal (prepare-next-goal node tactic))) | |
| 681 | (setf (goal-targets ngoal) sentences) | |
| 682 | (push ngoal goals))) | |
| 683 | (t (dolist (sentence sentences) | |
| 684 | (let ((ngoal (prepare-next-goal node tactic))) | |
| 685 | (setf (goal-targets ngoal) (list sentence)) | |
| 686 | (push ngoal goals))))) | |
| 841 | (let ((ngoal (prepare-next-goal node tactic))) | |
| 842 | (setf (goal-targets ngoal) sentences) | |
| 843 | (push ngoal goals))) | |
| 844 | (t (dolist (sentence sentences) | |
| 845 | (let ((ngoal (prepare-next-goal node tactic))) | |
| 846 | (setf (goal-targets ngoal) (list sentence)) | |
| 847 | (push ngoal goals))))) | |
| 687 | 848 | (values goals (nreverse goals)))) |
| 688 | 849 | |
| 689 | 850 | ;;; ======================= |
| 693 | 854 | (defun generate-ip-derived-axioms (module axiom) |
| 694 | 855 | (condition->axioms module (axiom-condition axiom) 'ip)) |
| 695 | 856 | |
| 696 | #|| | |
| 697 | (defun apply-ip (ptree-node) | |
| 698 | (declare (type ptree-node ptree-node)) | |
| 857 | (defun apply-ip (ptree-node &rest ignore) | |
| 858 | (declare (type ptree-node ptree-node) | |
| 859 | (ignore ignore)) | |
| 699 | 860 | (with-in-context (ptree-node) |
| 700 | 861 | (let ((original-goal (ptree-node-goal ptree-node))) |
| 701 | 862 | (flet ((push-next-goal (goal) |
| 702 | (unless (eq goal original-goal) (push goal .next-goals.)))) | |
| 703 | (let ((target-goals (distribute-sentences ptree-node .cur-targets. .tactic-ip.))) | |
| 704 | (dolist (.cur-goal. target-goals) | |
| 705 | (multiple-value-bind (result target otarget) | |
| 706 | (check-goal-is-satisfied .cur-goal. 'ip) | |
| 707 | (declare (ignore otarget)) | |
| 708 | (if result | |
| 709 | ;; discharged by some reason | |
| 710 | (push-next-goal .cur-goal.) | |
| 711 | (cond ((and (not (is-true? (rule-condition target))) | |
| 712 | (null (term-variables (rule-condition target)))) | |
| 713 | ;; t = t' if C | |
| 714 | ;; C is a ground term and is not true. | |
| 715 | ;; try if (SP + { C } |- t = t') or not.. | |
| 716 | ;; if this is satisfied, discharge it. | |
| 717 | (let ((ngoal (if (eq .cur-goal. original-goal) | |
| 718 | (prepare-next-goal ptree-node .tactic-ip.) | |
| 719 | .cur-goal.))) | |
| 720 | (with-in-module ((goal-context ngoal)) | |
| 721 | (let ((new-axs (generate-ip-derived-axioms *current-module* target)) | |
| 722 | (next-target (rule-copy-canonicalized target *current-module*))) | |
| 723 | ;; make the target | |
| 724 | (setf (rule-condition next-target) *bool-true*) | |
| 725 | (setf (goal-targets ngoal) (list next-target)) | |
| 726 | ||
| 727 | ;; add [ip] axioms | |
| 728 | (dolist (ax new-axs) | |
| 729 | (adjoin-axiom-to-module *current-module* ax) | |
| 730 | (set-operator-rewrite-rule *current-module* ax)) | |
| 731 | (setf (goal-assumptions ngoal) (append (goal-assumptions ngoal) (reverse new-axs))) | |
| 732 | ;; compile & check | |
| 733 | (compile-module *current-module* t) | |
| 734 | ;; check if introduced axioms can cause true <=> false: | |
| 735 | (cond ((check-ct-with-axioms ngoal new-axs 'ip) | |
| 736 | (let ((dscd (rule-copy-canonicalized target *current-module*))) | |
| 737 | (setf (goal-targets ngoal) nil) | |
| 738 | (setf (rule-labels dscd) (list '|CT-ip|)) | |
| 739 | (setf (goal-proved ngoal) (list dscd)))) | |
| 740 | (t ;; check-goal-is-satisfied do all the neccessary things for us. | |
| 741 | (check-goal-is-satisfied ngoal 'ip))) | |
| 742 | (push-next-goal ngoal))))) | |
| 743 | ((is-true? (rule-condition target)) | |
| 744 | ;; discharged. | |
| 745 | (push-next-goal .cur-goal.)) | |
| 746 | ;; nothig todo. remain the goal as is | |
| 747 | (t ))))) | |
| 748 | ;; done for all goals | |
| 749 | (values .next-goals. (nreverse .next-goals.))))))) | |
| 750 | ||# | |
| 751 | ||
| 752 | (defun apply-ip (ptree-node) | |
| 753 | (declare (type ptree-node ptree-node)) | |
| 754 | (with-in-context (ptree-node) | |
| 755 | (let ((original-goal (ptree-node-goal ptree-node))) | |
| 756 | (flet ((push-next-goal (goal) | |
| 757 | (unless (eq goal original-goal) (push goal .next-goals.)))) | |
| 758 | (let ((target-goals (distribute-sentences ptree-node .cur-targets. .tactic-ip.))) | |
| 759 | (dolist (.cur-goal. target-goals) | |
| 760 | (let ((target (normalize-sentence (car (goal-targets .cur-goal.)) (goal-context .cur-goal.)))) | |
| 761 | (cond ((and (not (is-true? (rule-condition target))) | |
| 762 | (null (term-variables (rule-condition target)))) | |
| 763 | ;; t = t' if C | |
| 764 | ;; C is a ground term and is not true. | |
| 765 | ;; try if (SP + { C } |- t = t') or not.. | |
| 766 | ;; if this is satisfied, discharge it. | |
| 767 | (let ((ngoal (if (eq .cur-goal. original-goal) | |
| 768 | (prepare-next-goal ptree-node .tactic-ip.) | |
| 769 | .cur-goal.))) | |
| 770 | (with-in-module ((goal-context ngoal)) | |
| 771 | (let ((new-axs (generate-ip-derived-axioms *current-module* target)) | |
| 772 | (next-target (rule-copy-canonicalized target *current-module*))) | |
| 773 | ;; make the target | |
| 774 | (setf (rule-condition next-target) *bool-true*) | |
| 775 | (setf (goal-targets ngoal) (list next-target)) | |
| 776 | ;; add [ip] axioms | |
| 777 | (dolist (ax new-axs) | |
| 778 | (adjoin-axiom-to-module *current-module* ax) | |
| 779 | (set-operator-rewrite-rule *current-module* ax)) | |
| 780 | (setf (goal-assumptions ngoal) (append (goal-assumptions ngoal) (reverse new-axs))) | |
| 781 | ;; compile | |
| 782 | (compile-module *current-module* t) | |
| 783 | (push-next-goal ngoal))))) | |
| 784 | (t | |
| 785 | ;; nothing to do | |
| 786 | (push-next-goal .cur-goal.))))) | |
| 787 | ;; done for all goals | |
| 788 | (setq .next-goals. (nreverse .next-goals.)) | |
| 789 | (dolist (ngoal .next-goals.) | |
| 790 | (multiple-value-bind (discharged norm-sentence org-sentence) | |
| 791 | (check-goal-is-satisfied ngoal 'ip) | |
| 792 | (declare (ignore norm-sentence org-sentence)) | |
| 793 | (when discharged | |
| 794 | (format t "~%[ip] discharged the goal ~s" (goal-name ngoal))))) | |
| 795 | ;; | |
| 796 | (values .next-goals. (nreverse .next-goals.))))))) | |
| 863 | (unless (eq goal original-goal) (push goal .next-goals.)))) | |
| 864 | (let ((target-goals (distribute-sentences ptree-node .cur-targets. .tactic-ip.))) | |
| 865 | (dolist (.cur-goal. target-goals) | |
| 866 | (let ((target (normalize-sentence (car (goal-targets .cur-goal.)) (goal-context .cur-goal.)))) | |
| 867 | (cond ((and (not (is-true? (rule-condition target))) | |
| 868 | (null (term-variables (rule-condition target)))) | |
| 869 | ;; t = t' if C | |
| 870 | ;; C is a ground term and is not true. | |
| 871 | ;; try if (SP + { C } |- t = t') or not.. | |
| 872 | ;; if this is satisfied, discharge it. | |
| 873 | (let ((ngoal (if (eq .cur-goal. original-goal) | |
| 874 | (prepare-next-goal ptree-node .tactic-ip.) | |
| 875 | .cur-goal.))) | |
| 876 | (with-in-module ((goal-context ngoal)) | |
| 877 | (let ((new-axs (generate-ip-derived-axioms *current-module* target)) | |
| 878 | (next-target (rule-copy-canonicalized target *current-module*))) | |
| 879 | ;; make the target | |
| 880 | (setf (rule-condition next-target) *bool-true*) | |
| 881 | (setf (goal-targets ngoal) (list next-target)) | |
| 882 | ;; add [ip] axioms | |
| 883 | (dolist (ax new-axs) | |
| 884 | (adjoin-axiom-to-module *current-module* ax) | |
| 885 | (set-operator-rewrite-rule *current-module* ax)) | |
| 886 | (setf (goal-assumptions ngoal) (append (goal-assumptions ngoal) (reverse new-axs))) | |
| 887 | ;; compile | |
| 888 | (compile-module *current-module* t) | |
| 889 | (push-next-goal ngoal))))) | |
| 890 | (t | |
| 891 | ;; nothing to do | |
| 892 | (push-next-goal .cur-goal.))))) | |
| 893 | ;; done for all goals | |
| 894 | (setq .next-goals. (nreverse .next-goals.)) | |
| 895 | (dolist (ngoal .next-goals.) | |
| 896 | (multiple-value-bind (discharged norm-sentence org-sentence) | |
| 897 | (check-goal-is-satisfied ngoal 'ip) | |
| 898 | (declare (ignore norm-sentence org-sentence)) | |
| 899 | (when discharged | |
| 900 | (format t "~%[ip] discharged the goal ~s" (goal-name ngoal))))) | |
| 901 | ;; | |
| 902 | (values .next-goals. (nreverse .next-goals.))))))) | |
| 797 | 903 | |
| 798 | 904 | ;;; ================================= |
| 799 | 905 | ;;; TACTIC: Theorem of Constants [TC] |
| 801 | 907 | |
| 802 | 908 | (defun make-tc-variable-substitutions (goal vars) |
| 803 | 909 | (declare (type goal goal) |
| 804 | (type list vars)) | |
| 910 | (type list vars)) | |
| 805 | 911 | (let ((subst nil)) |
| 806 | 912 | (dolist (var vars) |
| 807 | 913 | (push (cons var (variable->constant goal var)) subst)) |
| 811 | 917 | (print-substitution subst)) |
| 812 | 918 | subst)) |
| 813 | 919 | |
| 814 | (defun apply-tc (ptree-node) | |
| 815 | (declare (type ptree-node ptree-node)) | |
| 920 | (defun apply-tc (ptree-node &rest ignore) | |
| 921 | (declare (type ptree-node ptree-node) | |
| 922 | (ignore ignore)) | |
| 816 | 923 | (with-in-context (ptree-node) |
| 817 | 924 | (let ((original-goal .cur-goal.)) |
| 818 | (flet ((push-next-goal (goal) | |
| 819 | (unless (eq goal original-goal) (push goal .next-goals.)))) | |
| 820 | (let ((target-goals (distribute-sentences ptree-node .cur-targets. .tactic-tc.))) | |
| 821 | (dolist (cgoal target-goals) | |
| 822 | ;; variables --> constants | |
| 823 | (let ((sentence (car (goal-targets cgoal)))) | |
| 824 | (cond ((axiom-variables sentence) | |
| 825 | (when (eq cgoal original-goal) | |
| 826 | (setq cgoal (prepare-next-goal ptree-node .tactic-tc.))) | |
| 827 | (push-next-goal cgoal) | |
| 828 | (with-in-module ((goal-context cgoal)) | |
| 829 | (let* ((next-target (rule-copy-canonicalized sentence *current-module*)) | |
| 830 | (vars (axiom-variables next-target)) | |
| 831 | (subst (make-tc-variable-substitutions cgoal vars))) | |
| 832 | (apply-substitution-to-axiom subst next-target '(tc) t) | |
| 833 | (compute-rule-method next-target) | |
| 834 | (compile-module *current-module* t) | |
| 835 | (setf (goal-targets cgoal) | |
| 836 | (list (normalize-sentence next-target *current-module*)))))) | |
| 837 | (t | |
| 838 | ;; the sentence does not contain any variables. | |
| 839 | (push-next-goal cgoal))))) | |
| 840 | (setq .next-goals. (nreverse .next-goals.)) | |
| 841 | ;; check goal is satisfied or not | |
| 842 | (dolist (cgoal .next-goals.) | |
| 843 | (multiple-value-bind (res sentence osentence) | |
| 844 | (check-goal-is-satisfied cgoal 'rd) | |
| 845 | (declare (ignore osentence sentence)) | |
| 846 | (when res | |
| 847 | (format t "~%[tc] discharged the goal ~s" (goal-name cgoal))))) | |
| 848 | (values .next-goals. .next-goals.)))))) | |
| 925 | (flet ((push-next-goal (goal) | |
| 926 | (unless (eq goal original-goal) (push goal .next-goals.)))) | |
| 927 | (let ((target-goals (distribute-sentences ptree-node .cur-targets. .tactic-tc.))) | |
| 928 | (dolist (cgoal target-goals) | |
| 929 | ;; variables --> constants | |
| 930 | (let ((sentence (car (goal-targets cgoal)))) | |
| 931 | (cond ((axiom-variables sentence) | |
| 932 | (when (eq cgoal original-goal) | |
| 933 | (setq cgoal (prepare-next-goal ptree-node .tactic-tc.))) | |
| 934 | (push-next-goal cgoal) | |
| 935 | (with-in-module ((goal-context cgoal)) | |
| 936 | (let* ((next-target (rule-copy-canonicalized sentence *current-module*)) | |
| 937 | (vars (axiom-variables next-target)) | |
| 938 | (subst (make-tc-variable-substitutions cgoal vars))) | |
| 939 | (apply-substitution-to-axiom subst next-target '(tc) t) | |
| 940 | (compute-rule-method next-target) | |
| 941 | (compile-module *current-module* t) | |
| 942 | (setf (goal-targets cgoal) | |
| 943 | (list (normalize-sentence next-target *current-module*)))))) | |
| 944 | (t | |
| 945 | ;; the sentence does not contain any variables. | |
| 946 | (push-next-goal cgoal))))) | |
| 947 | (setq .next-goals. (nreverse .next-goals.)) | |
| 948 | ;; check goal is satisfied or not | |
| 949 | (dolist (cgoal .next-goals.) | |
| 950 | (multiple-value-bind (res sentence osentence) | |
| 951 | (check-goal-is-satisfied cgoal 'tc) | |
| 952 | (declare (ignore osentence sentence)) | |
| 953 | (when res | |
| 954 | (format t "~%[tc] discharged the goal ~s" (goal-name cgoal))))) | |
| 955 | (values .next-goals. .next-goals.)))))) | |
| 849 | 956 | |
| 850 | 957 | ;;; =================================== |
| 851 | 958 | ;;; TACTIC: Simultaneous Induction [SI] |
| 857 | 964 | (defun set-indvars (ptree-node variables) |
| 858 | 965 | (declare (type ptree-node ptree-node)) |
| 859 | 966 | (let* ((cur-goal (ptree-node-goal ptree-node)) |
| 860 | (cur-targets (goal-targets cur-goal)) | |
| 861 | (ind-vars nil)) | |
| 967 | (cur-targets (goal-targets cur-goal)) | |
| 968 | (ind-vars nil)) | |
| 862 | 969 | (dolist (cur-target cur-targets) |
| 863 | 970 | (let ((target-variables (axiom-variables cur-target))) |
| 864 | (dolist (v variables) | |
| 865 | (let ((tv (find-if #'(lambda (x) (and (eq (variable-name v) (variable-name x)) | |
| 866 | (eq (variable-sort v) (variable-sort x)))) | |
| 867 | target-variables))) | |
| 868 | (if tv (pushnew v ind-vars :test #'equal :key #'(lambda (x) (variable-name x))) | |
| 869 | (with-output-chaos-error ('no-such-variable) | |
| 870 | (format t "Setting induction variable, no such variable ~a:~a in target axiom." | |
| 871 | (variable-name v) (variable-sort v)))))))) | |
| 971 | (dolist (v variables) | |
| 972 | (let ((tv (find-if #'(lambda (x) (and (eq (variable-name v) (variable-name x)) | |
| 973 | (eq (variable-sort v) (variable-sort x)))) | |
| 974 | target-variables))) | |
| 975 | (if tv (pushnew v ind-vars :test #'equal :key #'(lambda (x) (variable-name x))) | |
| 976 | (with-output-chaos-error ('no-such-variable) | |
| 977 | (format t "Setting induction variable, no such variable ~a:~a in target axiom." | |
| 978 | (variable-name v) (variable-sort v)))))))) | |
| 872 | 979 | (setf (goal-indvars cur-goal) (nreverse ind-vars)) |
| 873 | 980 | (format t "~%**> Induction will be conducted on ") |
| 874 | 981 | (dolist (var (goal-indvars cur-goal)) |
| 875 | 982 | (term-print-with-sort var) (princ " ")) |
| 876 | 983 | ind-vars)) |
| 877 | 984 | |
| 878 | ;;; | |
| 879 | 985 | ;;; set-induction-variables |
| 880 | 986 | ;;; top level function. |
| 881 | 987 | (defun set-induction-variables (variables) |
| 883 | 989 | (let ((node (car (get-unproved-nodes *proof-tree*)))) |
| 884 | 990 | (unless node |
| 885 | 991 | (with-output-chaos-error ('no-unproved) |
| 886 | (format t "There is no unproved goals."))) | |
| 992 | (format t "There is no unproved goals."))) | |
| 887 | 993 | (set-indvars node variables))) |
| 888 | 994 | |
| 889 | ;;; | |
| 890 | 995 | ;;; gather-constructor-ops : module -> List(constructor) |
| 891 | 996 | ;;; list up all the constructor ops in a given module |
| 892 | 997 | ;;; |
| 894 | 999 | (let ((res nil)) |
| 895 | 1000 | (with-in-module (module) |
| 896 | 1001 | (dolist (opinfo (module-all-operators *current-module*)) |
| 897 | (dolist (meth (opinfo-methods opinfo)) | |
| 898 | (when (method-is-constructor? meth) | |
| 899 | (push meth res)))) | |
| 1002 | (dolist (meth (opinfo-methods opinfo)) | |
| 1003 | (when (method-is-constructor? meth) | |
| 1004 | (push meth res)))) | |
| 900 | 1005 | res))) |
| 901 | 1006 | |
| 902 | ;;; | |
| 903 | 1007 | ;;; get-induction-variable-constructors : variable -> List(constructor) |
| 904 | 1008 | ;;; returns a list of constructors of a given induction variable |
| 905 | 1009 | ;;; |
| 907 | 1011 | (let ((ops nil)) |
| 908 | 1012 | (dolist (op constructors) |
| 909 | 1013 | (when (sort<= (method-coarity op) (variable-sort v) (module-sort-order *current-module*)) |
| 910 | (push op ops))) | |
| 1014 | (push op ops))) | |
| 911 | 1015 | (unless ops |
| 912 | 1016 | (with-output-chaos-error ('internal-error) |
| 913 | (format t "Finding constructor of sort ~a, none was found." (string (sort-name (variable-sort v)))))) | |
| 1017 | (format t "Finding constructor of sort ~a, none was found." (string (sort-name (variable-sort v)))))) | |
| 914 | 1018 | ;; we sort the list of ops by number of arguments |
| 915 | 1019 | ;; this is important for generating step cases properly. |
| 916 | 1020 | (sort ops #'(lambda (x y) (< (length (method-arity x)) (length (method-arity y))))))) |
| 917 | 1021 | |
| 918 | ;;; | |
| 919 | 1022 | ;;; get-indvar-constructors |
| 920 | 1023 | ;;; returns a list of (indvar . const1 const2 ...constn) for an induction variable indvar. |
| 921 | 1024 | ;;; (((idvar-1 . const-1) ... (idvar-1 ... const-n)) |
| 927 | 1030 | (let ((ivar-map nil)) |
| 928 | 1031 | (dolist (iv indvars) |
| 929 | 1032 | (push (mapcar #'(lambda (cts) (cons iv cts)) |
| 930 | (get-induction-variable-constructors iv constructors)) | |
| 931 | ivar-map)) | |
| 1033 | (get-induction-variable-constructors iv constructors)) | |
| 1034 | ivar-map)) | |
| 932 | 1035 | (nreverse ivar-map))) |
| 933 | 1036 | |
| 934 | ;;; | |
| 935 | 1037 | ;;; make-indvar-comb-substitutions : List(variable) List(constructor) -> List(substitution) |
| 936 | 1038 | ;;; returns all possible substitution patterns of induction variables. |
| 937 | 1039 | ;;; ex. for induction variables A, B, C, there are constructors |
| 951 | 1053 | (declare (type list list-of-alist)) |
| 952 | 1054 | (select-comb-elems list-of-alist))) |
| 953 | 1055 | |
| 954 | ;;; | |
| 955 | 1056 | ;;; get-induction-base-substitutions : List(substitution) -> List(substitution) |
| 956 | 1057 | ;;; |
| 957 | 1058 | (defun get-induction-base-substitutions (all-subst) |
| 958 | 1059 | (let ((res nil)) |
| 959 | 1060 | (dolist (subst all-subst) |
| 960 | 1061 | (when (every #'(lambda (sub) (null (method-arity (cdr sub)))) subst) |
| 961 | (push subst res))) | |
| 1062 | (push subst res))) | |
| 962 | 1063 | (with-citp-debug () |
| 963 | 1064 | (format t "~%[si] base case subst") |
| 964 | 1065 | (dolist (sub res) |
| 965 | (print-next) | |
| 966 | (print-substitution sub))) | |
| 1066 | (print-next) | |
| 1067 | (print-substitution sub))) | |
| 967 | 1068 | (nreverse res))) |
| 968 | 1069 | |
| 969 | ;;; | |
| 970 | 1070 | ;;; get-induction-step-substitutions : List(substitution) -> List(substitution) |
| 971 | 1071 | ;;; |
| 972 | 1072 | (defun get-induction-step-substitutions (all-subst) |
| 973 | 1073 | (let ((res nil)) |
| 974 | 1074 | (dolist (subst all-subst) |
| 975 | 1075 | (unless (every #'(lambda (sub) (null (method-arity (cdr sub)))) subst) |
| 976 | (push subst res))) | |
| 1076 | (push subst res))) | |
| 977 | 1077 | (with-citp-debug () |
| 978 | 1078 | (format t "~%[si] get-induction-step-subsutitutions") |
| 979 | 1079 | (dolist (sub res) |
| 980 | (print-next) | |
| 981 | (print-substitution sub))) | |
| 1080 | (print-next) | |
| 1081 | (print-substitution sub))) | |
| 982 | 1082 | (nreverse res))) |
| 983 | 1083 | |
| 984 | ;;; | |
| 985 | 1084 | ;;; get-real-target-variable : variable List(variable) -> { variable | null } |
| 986 | 1085 | ;;; finds an variable from a list of variables. |
| 987 | 1086 | ;;; |
| 988 | 1087 | (defun get-real-target-variable (indvar axiom-variables) |
| 989 | 1088 | (find-if #'(lambda (m) (and (sort= (variable-sort m) (variable-sort indvar)) |
| 990 | (equal (variable-name m) (variable-name indvar)))) | |
| 991 | axiom-variables)) | |
| 992 | ||
| 993 | ;;; | |
| 1089 | (equal (variable-name m) (variable-name indvar)))) | |
| 1090 | axiom-variables)) | |
| 1091 | ||
| 994 | 1092 | ;;; make-real-induction-subst |
| 995 | 1093 | ;;; |
| 996 | 1094 | (defun make-real-induction-subst (subst axiom-vars) |
| 997 | 1095 | (let ((rsubst nil)) |
| 998 | 1096 | (dolist (sub subst) |
| 999 | 1097 | (let ((iv (car sub)) |
| 1000 | (op (cdr sub)) | |
| 1001 | (rv nil)) | |
| 1002 | (when (setq rv (get-real-target-variable iv axiom-vars)) | |
| 1003 | (setq rsubst (acons rv (make-applform-simple (method-coarity op) op nil) rsubst))))) | |
| 1098 | (op (cdr sub)) | |
| 1099 | (rv nil)) | |
| 1100 | (when (setq rv (get-real-target-variable iv axiom-vars)) | |
| 1101 | (setq rsubst (acons rv (make-applform-simple (method-coarity op) op nil) rsubst))))) | |
| 1004 | 1102 | rsubst)) |
| 1005 | 1103 | |
| 1006 | ;;; | |
| 1007 | 1104 | ;;; set-base-cases |
| 1008 | 1105 | ;;; generates base case axioms for a given target |
| 1009 | 1106 | ;;; |
| 1010 | 1107 | (defun set-base-cases (goal target base-substitutions) |
| 1011 | 1108 | (let ((all-targets nil) |
| 1012 | (app? nil)) | |
| 1109 | (app? nil)) | |
| 1013 | 1110 | (with-in-module ((goal-context goal)) |
| 1014 | 1111 | (dolist (subst base-substitutions) |
| 1015 | (let* ((new-target (rule-copy-canonicalized target *current-module*)) | |
| 1016 | (real-subst (make-real-induction-subst subst (axiom-variables new-target)))) | |
| 1017 | (when real-subst | |
| 1018 | (setq app? t) | |
| 1019 | (apply-substitution-to-axiom real-subst new-target) | |
| 1020 | (push new-target all-targets))))) | |
| 1112 | (let* ((new-target (rule-copy-canonicalized target *current-module*)) | |
| 1113 | (real-subst (make-real-induction-subst subst (axiom-variables new-target)))) | |
| 1114 | (when real-subst | |
| 1115 | (setq app? t) | |
| 1116 | (apply-substitution-to-axiom real-subst new-target) | |
| 1117 | (push new-target all-targets))))) | |
| 1021 | 1118 | (setf (goal-targets goal) (nconc (goal-targets goal) all-targets)) |
| 1022 | 1119 | app?)) |
| 1023 | 1120 | |
| 1024 | ;;; | |
| 1025 | 1121 | ;;; make-step-constructor-term |
| 1026 | 1122 | ;;; |
| 1027 | 1123 | (defun make-step-constructor-term (goal op one-arg variable) |
| 1028 | 1124 | (with-in-module ((goal-context goal)) |
| 1029 | 1125 | (let ((arity (method-arity op)) |
| 1030 | (arg-list nil)) | |
| 1126 | (arg-list nil) | |
| 1127 | (arg-var-assoc nil) | |
| 1128 | (n 0)) | |
| 1129 | (setq arg-var-assoc | |
| 1130 | (mapcar #'(lambda (x) (cons x 0)) arity)) | |
| 1031 | 1131 | (dolist (s arity) |
| 1032 | (cond ((sort<= (term-sort one-arg) s *current-sort-order*) | |
| 1033 | (push one-arg arg-list) | |
| 1034 | (setq one-arg (make-variable-term *cosmos* 'dummy))) ; make ...... | |
| 1035 | (t (let ((constant (variable->constructor goal variable :sort s))) | |
| 1036 | (push constant arg-list))))) | |
| 1132 | (cond ((sort<= (term-sort one-arg) s *current-sort-order*) | |
| 1133 | (when (< 1 (incf n)) | |
| 1134 | (with-output-chaos-error ('sorry) | |
| 1135 | (format t "Sorry, but system does not handle a constructor having multiple arguments of the same sort."))) | |
| 1136 | (push one-arg arg-list)) | |
| 1137 | (t (let* ((var-assoc (assoc s arg-var-assoc)) | |
| 1138 | (ind-var (if (zerop (cdr var-assoc)) | |
| 1139 | (progn (incf (cdr var-assoc)) variable) | |
| 1140 | (make-variable-term s | |
| 1141 | (intern (format nil "~A~D" | |
| 1142 | (string (variable-name variable)) | |
| 1143 | (incf (cdr var-assoc))))))) | |
| 1144 | (constant (variable->constructor goal ind-var :sort s))) | |
| 1145 | (push constant arg-list))))) | |
| 1037 | 1146 | (let ((res (make-applform-simple (method-coarity op) op (nreverse arg-list)))) |
| 1038 | res)))) | |
| 1039 | ||
| 1040 | ;;; | |
| 1147 | res)))) | |
| 1148 | ||
| 1041 | 1149 | ;;; make-induction-step-subst : goal axiom (var . op) -> substitution |
| 1042 | 1150 | ;;; |
| 1043 | 1151 | (defun make-induction-step-subst (goal target v-op-list) |
| 1044 | 1152 | ;; we ignore all mapped operators are constant constructors. |
| 1045 | 1153 | (when (every #'(lambda (v-op) |
| 1046 | (let ((op (cdr v-op))) | |
| 1047 | (and (null (method-arity op)) | |
| 1048 | (method-is-constructor? op)))) | |
| 1049 | v-op-list) | |
| 1154 | (let ((op (cdr v-op))) | |
| 1155 | (and (null (method-arity op)) | |
| 1156 | (method-is-constructor? op)))) | |
| 1157 | v-op-list) | |
| 1050 | 1158 | (return-from make-induction-step-subst nil)) |
| 1051 | 1159 | ;; |
| 1052 | 1160 | (let ((hypo-v-op nil) |
| 1053 | (step-v-op nil) | |
| 1054 | ;; (new-ops nil) | |
| 1055 | (axiom-vars (axiom-variables target))) | |
| 1161 | (step-v-op nil) | |
| 1162 | ;; (new-ops nil) | |
| 1163 | (axiom-vars (axiom-variables target))) | |
| 1056 | 1164 | ;; we generate the following case for each induction variable v: |
| 1057 | 1165 | ;; 1) (v . <term of constant constructor>) |
| 1058 | 1166 | ;; 2) (v . <constant term of non-constant-constructor>) |
| 1060 | 1168 | ;; |
| 1061 | 1169 | (dolist (sub v-op-list) |
| 1062 | 1170 | (let* ((iv (car sub)) ; induction variable |
| 1063 | (op (cdr sub)) ; operator | |
| 1064 | (rv nil)) ; real induction variable in target | |
| 1065 | (when (setq rv (get-real-target-variable iv axiom-vars)) | |
| 1066 | (cond ((null (method-arity op)) | |
| 1067 | (let* ((ct (variable->constructor goal rv :op op)) | |
| 1068 | (c-subst (cons iv ct))) | |
| 1069 | ;; operator is constant constructor | |
| 1070 | (push (list (cons iv (list op ct))) hypo-v-op) | |
| 1071 | (push c-subst step-v-op))) | |
| 1072 | (t ;; operator is non-constant constructor | |
| 1073 | (let ((const-term (variable->constructor goal rv))) | |
| 1074 | (push (list (cons rv (list op const-term))) hypo-v-op) | |
| 1075 | (push (cons rv (make-step-constructor-term goal op const-term rv)) step-v-op))))))) | |
| 1171 | (op (cdr sub)) ; operator | |
| 1172 | (rv nil)) ; real induction variable in target | |
| 1173 | (when (setq rv (get-real-target-variable iv axiom-vars)) | |
| 1174 | (cond ((null (method-arity op)) | |
| 1175 | (let* ((ct (variable->constructor goal rv :op op)) | |
| 1176 | (c-subst (cons iv ct))) | |
| 1177 | ;; operator is constant constructor | |
| 1178 | (push (list (cons iv (list op ct))) hypo-v-op) | |
| 1179 | (push c-subst step-v-op))) | |
| 1180 | (t ;; operator is non-constant constructor | |
| 1181 | (let ((const-term (variable->constructor goal rv))) | |
| 1182 | (push (list (cons rv (list op const-term))) hypo-v-op) | |
| 1183 | (push (cons rv (make-step-constructor-term goal op const-term rv)) step-v-op))))))) | |
| 1076 | 1184 | (values (select-comb-elems (nreverse hypo-v-op)) |
| 1077 | (nreverse step-v-op)))) | |
| 1185 | (nreverse step-v-op)))) | |
| 1078 | 1186 | |
| 1079 | 1187 | (defun make-real-induction-step-subst (subst variables) |
| 1080 | 1188 | (let ((rsubst nil)) |
| 1081 | 1189 | (dolist (sub subst) |
| 1082 | 1190 | (let ((iv (car sub)) |
| 1083 | (term (cdr sub)) | |
| 1084 | (rv nil)) | |
| 1085 | (when (setq rv (get-real-target-variable iv variables)) | |
| 1086 | (setq rsubst (acons rv term rsubst))))) | |
| 1191 | (term (cdr sub)) | |
| 1192 | (rv nil)) | |
| 1193 | (when (setq rv (get-real-target-variable iv variables)) | |
| 1194 | (setq rsubst (acons rv term rsubst))))) | |
| 1087 | 1195 | (nreverse rsubst))) |
| 1088 | 1196 | |
| 1089 | 1197 | (defun resolve-induction-subst (goal hypo-v-op step-subst) |
| 1090 | 1198 | (declare (ignore goal)) |
| 1091 | 1199 | (flet ((make-proper-alist (sub) |
| 1092 | (mapcar #'(lambda (s) (cons (car s) (cadr s))) sub))) | |
| 1200 | (mapcar #'(lambda (s) (cons (car s) (cadr s))) sub))) | |
| 1093 | 1201 | (unless hypo-v-op |
| 1094 | 1202 | (with-output-chaos-warning () |
| 1095 | (format t "No subst given.") | |
| 1096 | (return-from resolve-induction-subst nil))) | |
| 1203 | (format t "No subst given.") | |
| 1204 | (return-from resolve-induction-subst nil))) | |
| 1097 | 1205 | (let ((rsubsts (mapcar #'(lambda (sub) |
| 1098 | (cons (car sub) (list (third sub)))) | |
| 1099 | hypo-v-op)) | |
| 1100 | (all-subst nil)) | |
| 1206 | (cons (car sub) (list (third sub)))) | |
| 1207 | hypo-v-op)) | |
| 1208 | (all-subst nil)) | |
| 1101 | 1209 | (with-citp-debug () |
| 1102 | (format t "~%[si] resolve induction step: given") | |
| 1103 | (print-next) (format t "hypo-v-op: ~s" hypo-v-op) | |
| 1104 | (print-next) (princ "step-subst" ) | |
| 1105 | (print-substitution step-subst)) | |
| 1210 | (format t "~%[si] resolve induction step: given") | |
| 1211 | (print-next) (format t "hypo-v-op: ~s" hypo-v-op) | |
| 1212 | (print-next) (princ "step-subst" ) | |
| 1213 | (print-substitution step-subst)) | |
| 1106 | 1214 | ;; return if there are no possible combinations |
| 1107 | 1215 | ;; (unless (cdr hypo-v-op) |
| 1108 | 1216 | ;; (return-from resolve-induction-subst (list (make-proper-alist rsubsts)))) |
| 1109 | 1217 | ;; |
| 1110 | 1218 | (with-citp-debug () |
| 1111 | (format t "~%resolve subst: given") | |
| 1112 | (dolist (v-op hypo-v-op) | |
| 1113 | (let ((*print-indent* (+ 2 *print-indent*))) | |
| 1114 | (print-next) | |
| 1115 | (format t "(~a . ~a <- " (variable-name (first v-op)) (car (method-name (second v-op)))) | |
| 1116 | (term-print-with-sort (third v-op)) | |
| 1117 | (princ ")")))) | |
| 1219 | (format t "~%resolve subst: given") | |
| 1220 | (dolist (v-op hypo-v-op) | |
| 1221 | (let ((*print-indent* (+ 2 *print-indent*))) | |
| 1222 | (print-next) | |
| 1223 | (format t "(~a . ~a <- " (variable-name (first v-op)) (car (method-name (second v-op)))) | |
| 1224 | (term-print-with-sort (third v-op)) | |
| 1225 | (princ ")")))) | |
| 1118 | 1226 | |
| 1119 | 1227 | ;; make all possible hypothesis substitutions |
| 1120 | 1228 | (let ((vop-hash (make-hash-table :test #'eq)) |
| 1121 | (vcombs nil)) | |
| 1122 | (dolist (v-op hypo-v-op) | |
| 1123 | (let ((v (first v-op)) | |
| 1124 | (as nil)) | |
| 1125 | (unless (setq as (assoc v rsubsts)) | |
| 1126 | (with-output-chaos-error ('internal-err) | |
| 1127 | (format t "!! cannot find variable subst ~s" (variable-name v)))) | |
| 1128 | (setf (gethash v vop-hash) (list as)) | |
| 1129 | (let ((st (assoc v step-subst :test #'equal)) | |
| 1130 | (hentry (gethash v vop-hash)) | |
| 1131 | (new-element nil)) | |
| 1132 | (unless st (with-output-chaos-error ('no-step-term) | |
| 1133 | (format t "No step term found for variable ~a" (variable-name v)))) | |
| 1134 | (setq new-element (cons v (list (cdr st)))) | |
| 1135 | (unless (member new-element hentry :test #'equal) | |
| 1136 | (setf (gethash v vop-hash) (append hentry (list new-element))))))) | |
| 1137 | (maphash #'(lambda (x vl) (declare (ignore x)) (push vl vcombs)) vop-hash) | |
| 1138 | (setq all-subst (select-comb-elems vcombs)) | |
| 1139 | (with-citp-debug () | |
| 1140 | (format t "~%resolve subt: all possibilities") | |
| 1141 | (let ((*print-indent* (+ 2 *print-indent*)) | |
| 1142 | (num 0)) | |
| 1143 | (declare (type fixnum num)) | |
| 1144 | (dolist (vcom all-subst) | |
| 1145 | (print-next) | |
| 1146 | (format t "=== (#~d) " (incf num)) | |
| 1147 | (dolist (rs vcom) | |
| 1148 | (format t "~a |-> " (variable-name (car rs))) | |
| 1149 | (term-print-with-sort (cadr rs)) (princ " "))))) | |
| 1150 | ;; | |
| 1151 | (mapcar #'make-proper-alist all-subst))))) | |
| 1152 | ||
| 1153 | ;;; | |
| 1229 | (vcombs nil)) | |
| 1230 | (dolist (v-op hypo-v-op) | |
| 1231 | (let ((v (first v-op)) | |
| 1232 | (as nil)) | |
| 1233 | (unless (setq as (assoc v rsubsts)) | |
| 1234 | (with-output-chaos-error ('internal-err) | |
| 1235 | (format t "!! cannot find variable subst ~s" (variable-name v)))) | |
| 1236 | (setf (gethash v vop-hash) (list as)) | |
| 1237 | (let ((st (assoc v step-subst :test #'equal)) | |
| 1238 | (hentry (gethash v vop-hash)) | |
| 1239 | (new-element nil)) | |
| 1240 | (unless st (with-output-chaos-error ('no-step-term) | |
| 1241 | (format t "No step term found for variable ~a" (variable-name v)))) | |
| 1242 | (setq new-element (cons v (list (cdr st)))) | |
| 1243 | (unless (member new-element hentry :test #'equal) | |
| 1244 | (setf (gethash v vop-hash) (append hentry (list new-element))))))) | |
| 1245 | (maphash #'(lambda (x vl) (declare (ignore x)) (push vl vcombs)) vop-hash) | |
| 1246 | (setq all-subst (select-comb-elems vcombs)) | |
| 1247 | (with-citp-debug () | |
| 1248 | (format t "~%resolve subt: all possibilities") | |
| 1249 | (let ((*print-indent* (+ 2 *print-indent*)) | |
| 1250 | (num 0)) | |
| 1251 | (declare (type fixnum num)) | |
| 1252 | (dolist (vcom all-subst) | |
| 1253 | (print-next) | |
| 1254 | (format t "=== (#~d) " (incf num)) | |
| 1255 | (dolist (rs vcom) | |
| 1256 | (format t "~a |-> " (variable-name (car rs))) | |
| 1257 | (term-print-with-sort (cadr rs)) (princ " "))))) | |
| 1258 | ;; | |
| 1259 | (mapcar #'make-proper-alist all-subst))))) | |
| 1260 | ||
| 1154 | 1261 | ;;; add-hypothesis |
| 1155 | 1262 | ;;; Note: assumes computing module context is established. |
| 1156 | 1263 | ;;; |
| 1159 | 1266 | (let ((entry2 (assoc (car entry) sub2 :test #'equal))) |
| 1160 | 1267 | (unless entry2 (return-from subst-is-equal nil)) |
| 1161 | 1268 | (unless (equal (cdr entry) (cdr entry2)) |
| 1162 | (return-from subst-is-equal nil)))) | |
| 1269 | (return-from subst-is-equal nil)))) | |
| 1163 | 1270 | t) |
| 1164 | 1271 | |
| 1165 | 1272 | (defun add-hypothesis (step-goal target hypo-subst step-subst) |
| 1174 | 1281 | (dolist (osub hypo-subst) |
| 1175 | 1282 | (dolist (sub (resolve-induction-subst step-goal osub step-subst)) |
| 1176 | 1283 | (unless (subst-is-equal sub step-subst) |
| 1177 | (let* ((hypo (rule-copy-canonicalized target *current-module*)) | |
| 1178 | (subst (make-real-induction-step-subst sub (axiom-variables hypo)))) | |
| 1179 | (with-citp-debug | |
| 1180 | (format t "~%[applying hypo subst] ") | |
| 1181 | (print-substitution subst) | |
| 1182 | (print-next) | |
| 1183 | (princ "to ") | |
| 1184 | (print-axiom-brief hypo)) | |
| 1185 | (apply-substitution-to-axiom subst hypo '(si) t) | |
| 1186 | (compute-rule-method hypo) | |
| 1187 | (set-operator-rewrite-rule *current-module* hypo) | |
| 1188 | (adjoin-axiom-to-module *current-module* hypo) | |
| 1189 | (with-citp-debug () | |
| 1190 | (format t "~%--> ") | |
| 1191 | (print-axiom-brief hypo)) | |
| 1192 | (setf (goal-assumptions step-goal) (append (goal-assumptions step-goal) (list hypo)))))))) | |
| 1193 | ||
| 1194 | ;;; | |
| 1284 | (let* ((hypo (rule-copy-canonicalized target *current-module*)) | |
| 1285 | (subst (make-real-induction-step-subst sub (axiom-variables hypo)))) | |
| 1286 | (with-citp-debug | |
| 1287 | (format t "~%[applying hypo subst] ") | |
| 1288 | (print-substitution subst) | |
| 1289 | (print-next) | |
| 1290 | (princ "to ") | |
| 1291 | (print-axiom-brief hypo)) | |
| 1292 | (apply-substitution-to-axiom subst hypo '(si) t) | |
| 1293 | (compute-rule-method hypo) | |
| 1294 | (set-operator-rewrite-rule *current-module* hypo) | |
| 1295 | (adjoin-axiom-to-module *current-module* hypo) | |
| 1296 | (with-citp-debug () | |
| 1297 | (format t "~%--> ") | |
| 1298 | (print-axiom-brief hypo)) | |
| 1299 | (setf (goal-assumptions step-goal) (append (goal-assumptions step-goal) (list hypo)))))))) | |
| 1300 | ||
| 1195 | 1301 | ;;; add-step-cases |
| 1196 | 1302 | ;;; Note: assumes computing module context is established. |
| 1197 | 1303 | ;;; |
| 1198 | 1304 | (defun add-step-cases (step-goal target step-subst) |
| 1199 | 1305 | (let* ((new-target (rule-copy-canonicalized target *current-module*)) |
| 1200 | (subst (make-real-induction-step-subst step-subst (axiom-variables new-target)))) | |
| 1306 | (subst (make-real-induction-step-subst step-subst (axiom-variables new-target)))) | |
| 1201 | 1307 | (when (car subst) |
| 1202 | 1308 | (with-citp-debug |
| 1203 | (format t "~%[applying step subst] ") | |
| 1204 | (print-substitution subst)) | |
| 1309 | (format t "~%[applying step subst] ") | |
| 1310 | (print-substitution subst)) | |
| 1205 | 1311 | (apply-substitution-to-axiom subst new-target) |
| 1206 | 1312 | (setf (goal-targets step-goal) (nconc (goal-targets step-goal) (list new-target)))))) |
| 1207 | ||
| 1208 | ;;; | |
| 1313 | ||
| 1209 | 1314 | ;;; induction-cases |
| 1210 | 1315 | ;;; Note: assumes there properly set induction variables in the current goal. |
| 1211 | 1316 | ;;; |
| 1212 | 1317 | (defun induction-cases (parent-node) |
| 1213 | 1318 | (declare (type ptree-node parent-node)) |
| 1214 | 1319 | (let* ((cur-goal (ptree-node-goal parent-node)) |
| 1215 | (cur-targets nil) | |
| 1216 | (indvars (goal-indvars cur-goal)) | |
| 1217 | (all-subst (make-indvar-comb-substitutions indvars | |
| 1218 | (gather-constructor-ops (goal-context cur-goal)))) | |
| 1219 | (base-goal (prepare-next-goal parent-node .tactic-si.)) | |
| 1220 | (step-goals nil) | |
| 1221 | (need-goal nil) | |
| 1222 | (base-generated nil) | |
| 1223 | (remainings nil)) | |
| 1320 | (cur-targets nil) | |
| 1321 | (indvars (goal-indvars cur-goal)) | |
| 1322 | (all-subst (make-indvar-comb-substitutions indvars | |
| 1323 | (gather-constructor-ops (goal-context cur-goal)))) | |
| 1324 | (base-goal (prepare-next-goal parent-node .tactic-si.)) | |
| 1325 | (step-goals nil) | |
| 1326 | (need-goal nil) | |
| 1327 | (base-generated nil) | |
| 1328 | (remainings nil)) | |
| 1224 | 1329 | ;; |
| 1225 | 1330 | (with-citp-debug () |
| 1226 | 1331 | (format t "~%[si] all possible substitutions") |
| 1227 | 1332 | (let ((num 0)) |
| 1228 | (declare (type fixnum num)) | |
| 1229 | (dolist (subs all-subst) | |
| 1230 | (format t "~%subst #~d" (incf num)) | |
| 1231 | (let ((*print-indent* (+ 2 *print-indent*))) | |
| 1232 | (print-next) | |
| 1233 | (print-substitution subs))))) | |
| 1333 | (declare (type fixnum num)) | |
| 1334 | (dolist (subs all-subst) | |
| 1335 | (format t "~%subst #~d" (incf num)) | |
| 1336 | (let ((*print-indent* (+ 2 *print-indent*))) | |
| 1337 | (print-next) | |
| 1338 | (print-substitution subs))))) | |
| 1234 | 1339 | |
| 1235 | 1340 | ;; implicit NF application |
| 1236 | 1341 | (dolist (ct (goal-targets cur-goal)) |
| 1237 | 1342 | (multiple-value-bind (ntarget app?) |
| 1238 | (normalize-sentence ct (goal-context cur-goal)) | |
| 1239 | (when app? (setq need-goal t)) | |
| 1240 | (push ntarget cur-targets))) | |
| 1343 | (normalize-sentence ct (goal-context cur-goal)) | |
| 1344 | (when app? (setq need-goal t)) | |
| 1345 | (push ntarget cur-targets))) | |
| 1241 | 1346 | (setq cur-targets (nreverse cur-targets)) |
| 1242 | 1347 | |
| 1243 | 1348 | ;; generate base cases |
| 1244 | 1349 | ;; |
| 1245 | 1350 | (dolist (target cur-targets) |
| 1246 | 1351 | (if (not (set-base-cases base-goal target (get-induction-base-substitutions all-subst))) |
| 1247 | (when need-goal | |
| 1248 | (push target remainings)) | |
| 1249 | (setq base-generated t))) | |
| 1352 | (when need-goal | |
| 1353 | (push target remainings)) | |
| 1354 | (setq base-generated t))) | |
| 1250 | 1355 | (unless base-generated (setq base-goal nil)) |
| 1251 | 1356 | |
| 1252 | 1357 | ;; generate step cases |
| 1255 | 1360 | ;; |
| 1256 | 1361 | (dolist (subst (get-induction-step-substitutions all-subst)) |
| 1257 | 1362 | (let ((step-goal (prepare-next-goal parent-node .tactic-si.))) |
| 1258 | (with-in-module ((goal-context step-goal)) | |
| 1259 | ;; following functions and their callies can assume the computing context is established. | |
| 1260 | (dolist (target cur-targets) | |
| 1261 | (multiple-value-bind (hypo-subst-list step-subst) | |
| 1262 | (make-induction-step-subst step-goal target subst) | |
| 1263 | (add-hypothesis step-goal target hypo-subst-list step-subst) | |
| 1264 | (add-step-cases step-goal target step-subst))) | |
| 1265 | (cond ((goal-targets step-goal) | |
| 1266 | (push step-goal step-goals)) | |
| 1267 | (t ))))) ; do nothig | |
| 1363 | (with-in-module ((goal-context step-goal)) | |
| 1364 | ;; following functions and their callies can assume the computing context is established. | |
| 1365 | (dolist (target cur-targets) | |
| 1366 | (multiple-value-bind (hypo-subst-list step-subst) | |
| 1367 | (make-induction-step-subst step-goal target subst) | |
| 1368 | (add-hypothesis step-goal target hypo-subst-list step-subst) | |
| 1369 | (add-step-cases step-goal target step-subst))) | |
| 1370 | (cond ((goal-targets step-goal) | |
| 1371 | (push step-goal step-goals)) | |
| 1372 | (t ))))) ; do nothig | |
| 1268 | 1373 | ;; |
| 1269 | 1374 | (when remainings |
| 1270 | 1375 | (multiple-value-bind (ap? nil-goals) |
| 1271 | (apply-nil-internal parent-node (reverse remainings) :all-togather .tactic-si.) | |
| 1272 | (declare (ignore ap?)) | |
| 1273 | (dolist (ng nil-goals) | |
| 1274 | (push ng step-goals)))) | |
| 1376 | (apply-nil-internal parent-node (reverse remainings) :all-togather .tactic-si.) | |
| 1377 | (declare (ignore ap?)) | |
| 1378 | (dolist (ng nil-goals) | |
| 1379 | (push ng step-goals)))) | |
| 1275 | 1380 | ;; |
| 1276 | 1381 | (if base-goal |
| 1277 | (values t (cons base-goal (nreverse step-goals))) | |
| 1382 | (values t (cons base-goal (nreverse step-goals))) | |
| 1278 | 1383 | (if step-goals |
| 1279 | ;; case remainings | |
| 1280 | (values t step-goals) | |
| 1281 | (values nil nil))))) | |
| 1282 | ||
| 1283 | ;;; | |
| 1284 | ;;; apply-si : ptree-node -> (applied? . List(goal)) | |
| 1285 | ;;; | |
| 1286 | (defun apply-si (ptree-node) | |
| 1287 | (declare (type ptree-node ptree-node)) | |
| 1384 | ;; case remainings | |
| 1385 | (values t step-goals) | |
| 1386 | (values nil nil))))) | |
| 1387 | ||
| 1388 | ;;; apply-si : ptree-node tactic -> (applied? . List(goal)) | |
| 1389 | ;;; | |
| 1390 | (defun apply-si (ptree-node &rest ignore) | |
| 1391 | (declare (type ptree-node ptree-node) | |
| 1392 | (ignore ignore)) | |
| 1288 | 1393 | (let ((cur-goal (ptree-node-goal ptree-node))) |
| 1289 | 1394 | (unless (and (goal-indvars cur-goal) (goal-targets cur-goal)) |
| 1290 | 1395 | (return-from apply-si nil)) |
| 1291 | 1396 | (multiple-value-bind (applied new-goals) |
| 1292 | (induction-cases ptree-node) | |
| 1397 | (induction-cases ptree-node) | |
| 1293 | 1398 | (if applied |
| 1294 | (values applied new-goals) | |
| 1295 | (values nil nil))))) | |
| 1399 | (values applied new-goals) | |
| 1400 | (values nil nil))))) | |
| 1296 | 1401 | |
| 1297 | 1402 | ;;; ======================= |
| 1298 | 1403 | ;;; TACTIC: REDUCTION [RD] |
| 1299 | 1404 | ;;; ======================= |
| 1300 | (defun do-apply-rd (cur-goal tactic) | |
| 1301 | (setq *m-pattern-subst* nil) | |
| 1302 | (setq .rwl-context-stack. nil) | |
| 1303 | (setq .rwl-sch-context. nil) | |
| 1304 | (setq .rwl-states-so-far. 0) | |
| 1305 | (let ((*rewrite-exec-mode* nil) | |
| 1306 | (*rewrite-semantic-reduce* nil) | |
| 1307 | (time1 (get-internal-run-time)) | |
| 1308 | time2 | |
| 1309 | (consumed-time nil) | |
| 1310 | (*perform-on-demand-reduction* t) | |
| 1311 | (*rule-count* 0)) | |
| 1312 | (setq $$matches 0) | |
| 1313 | (let ((cur-targets (goal-targets cur-goal)) | |
| 1314 | (reduced-targets nil) | |
| 1315 | (discharged nil) | |
| 1316 | (result nil)) | |
| 1317 | (when cur-targets | |
| 1318 | (with-in-module ((goal-context cur-goal)) | |
| 1319 | (compile-module *current-module* t) | |
| 1320 | (dolist (target cur-targets) | |
| 1321 | (multiple-value-bind (c-result cur-target original-sentence) | |
| 1322 | (do-check-sentence target cur-goal tactic) | |
| 1323 | (cond (c-result ; satisfied or contradition | |
| 1324 | (setq result t) | |
| 1325 | (push original-sentence discharged)) | |
| 1326 | (t (push cur-target reduced-targets))))) | |
| 1327 | (setf (goal-targets cur-goal) (nreverse reduced-targets)) | |
| 1328 | (setf (goal-proved cur-goal) (nreverse discharged)) | |
| 1329 | (unless reduced-targets | |
| 1330 | (format t "~%[~a] discharged goal ~s." tactic (goal-name cur-goal))))) | |
| 1331 | (setq time2 (get-internal-run-time)) | |
| 1332 | (setq consumed-time (format nil "~,4f sec" (elapsed-time-in-seconds time1 time2))) | |
| 1333 | (unless (zerop *rule-count*) | |
| 1334 | (format t "~%[rd] consumed ~a (~d rewrites, ~d matches)" consumed-time *rule-count* $$matches)) | |
| 1335 | (values result nil)))) | |
| 1336 | ||
| 1337 | (defun apply-rd (ptree-node &optional (tactic 'rd)) | |
| 1338 | (declare (type ptree-node ptree-node)) | |
| 1339 | (do-apply-rd (ptree-node-goal ptree-node) tactic)) | |
| 1405 | ||
| 1406 | ;;; do-apply-rd | |
| 1407 | ;;; | |
| 1408 | (defun do-apply-rd (cur-goal next-goal tactic) | |
| 1409 | (let* ((target-goal (or next-goal cur-goal)) | |
| 1410 | (cur-targets (goal-targets target-goal)) | |
| 1411 | (reduced-targets nil) | |
| 1412 | (discharged nil) | |
| 1413 | (result nil) | |
| 1414 | (tactic-name (tactic-name tactic))) | |
| 1415 | (unless cur-targets | |
| 1416 | (with-citp-debug () | |
| 1417 | (format t "~%[rd] no target sentences.")) | |
| 1418 | (return-from do-apply-rd (values nil nil))) | |
| 1419 | (compile-module (goal-context target-goal) t) | |
| 1420 | (dolist (target cur-targets) | |
| 1421 | (multiple-value-bind (c-result cur-target original-sentence) | |
| 1422 | (do-check-sentence target (or next-goal cur-goal) tactic-name) | |
| 1423 | (cond (c-result ; satisfied or contradition | |
| 1424 | (setq result t) | |
| 1425 | (push original-sentence discharged)) | |
| 1426 | ;; reduced but not discharged | |
| 1427 | (t (push cur-target reduced-targets))))) | |
| 1428 | ;; set new (reduced sentences) as targets | |
| 1429 | (setf (goal-targets target-goal) (nreverse reduced-targets)) | |
| 1430 | ;; set discharged sentences | |
| 1431 | (setf (goal-proved cur-goal) (nreverse discharged)) | |
| 1432 | (unless reduced-targets | |
| 1433 | ;; this means all sentences are discharged | |
| 1434 | (setf (goal-targets cur-goal) nil) | |
| 1435 | (format t "~%[~a] discharged goal ~s." tactic-name (goal-name cur-goal)) | |
| 1436 | (return-from do-apply-rd (values result nil))) | |
| 1437 | ;; there remains | |
| 1438 | (values t (list (or next-goal cur-goal))))) | |
| 1439 | ||
| 1440 | ;;; apply-rd | |
| 1441 | ;;; explicit application of tactic RD. | |
| 1442 | (defun apply-rd (ptree-node &optional (tactic .tactic-rd.)) | |
| 1443 | (declare (type ptree-node ptree-node) | |
| 1444 | (type tactic tactic)) | |
| 1445 | ;; we set :spoiler on | |
| 1446 | (with-spoiler-on () ; force application of implicit tactcs(NF, CF, e.t.c.) | |
| 1447 | (let ((cur-goal (ptree-node-goal ptree-node))) | |
| 1448 | (when (goal-is-discharged cur-goal) | |
| 1449 | (with-output-chaos-warning () | |
| 1450 | (format t "** The goal ~s has already been proved!" | |
| 1451 | (goal-name cur-goal))) | |
| 1452 | (return-from apply-rd (values nil nil))) | |
| 1453 | (unless (goal-targets cur-goal) | |
| 1454 | (return-from apply-rd nil)) | |
| 1455 | (let ((undo? (the-goal-needs-undo cur-goal)) | |
| 1456 | (original-target (ptree-node-goal (ptree-node-parent ptree-node)))) | |
| 1457 | ;; undo? = true means the current goal is generatd by | |
| 1458 | ;; :defined :ctf- or :csp-, AND | |
| 1459 | ;; this RD application follows it, i.e., :apply(... ctf-n rd ...) | |
| 1460 | ;; in this case we don't prepare next-goal and .. | |
| 1461 | (let ((next-goal (if undo? | |
| 1462 | nil | |
| 1463 | (prepare-next-goal ptree-node .tactic-rd.)))) | |
| 1464 | (unless undo? | |
| 1465 | (setf (goal-targets next-goal) (goal-targets cur-goal))) | |
| 1466 | (with-citp-debug () | |
| 1467 | (format t "~%[rd] target: ~a" (if next-goal | |
| 1468 | (goal-name next-goal) | |
| 1469 | (goal-name cur-goal)))) | |
| 1470 | (multiple-value-bind (applied next-goals) | |
| 1471 | (do-apply-rd cur-goal next-goal tactic) | |
| 1472 | (declare (ignore applied)) | |
| 1473 | (when undo? | |
| 1474 | (dolist (ngoal next-goals) | |
| 1475 | (when (goal-targets ngoal) | |
| 1476 | ;; reset target | |
| 1477 | (when-citp-verbose () | |
| 1478 | (format t "~%[rd] ~a rollback to original goal ~a" | |
| 1479 | (goal-name ngoal)(goal-name original-target))) | |
| 1480 | (setf (goal-targets ngoal) (goal-targets original-target))))) | |
| 1481 | (if undo? | |
| 1482 | ;; the original goal rolled back, no new goal is needed. | |
| 1483 | (values next-goals nil) | |
| 1484 | (values next-goals next-goals)))))))) | |
| 1340 | 1485 | |
| 1341 | 1486 | ;;; ========================== |
| 1342 | 1487 | ;;; TACTIC: Case Analysis [CA] |
| 1351 | 1496 | (declare (type list gterms)) |
| 1352 | 1497 | (when (term-is-applform? term) |
| 1353 | 1498 | (unless (term-variables term) |
| 1354 | (push term gterms)) | |
| 1499 | (push term gterms)) | |
| 1355 | 1500 | (dolist (arg (term-subterms term)) |
| 1356 | (setq gterms (nconc gterms (get-gterms arg))))) | |
| 1501 | (setq gterms (nconc gterms (get-gterms arg))))) | |
| 1357 | 1502 | gterms)) |
| 1358 | 1503 | |
| 1359 | 1504 | ;;; get-gterms-from-axiom : axiom -> List(ground-term) |
| 1364 | 1509 | (let ((gterms nil)) |
| 1365 | 1510 | (declare (type list gterms)) |
| 1366 | 1511 | (cond (condition-only |
| 1367 | (unless (is-true? (axiom-condition axiom)) | |
| 1368 | (setq gterms (remove-duplicates (get-gterms (axiom-condition axiom)) | |
| 1369 | :test #'equal)))) | |
| 1370 | (t (setq gterms (delete-duplicates (append (get-gterms (axiom-lhs axiom)) | |
| 1371 | (append (get-gterms (axiom-rhs axiom)) | |
| 1372 | (get-gterms-from-axiom axiom t))) | |
| 1373 | :test #'equal)))) | |
| 1512 | (unless (is-true? (axiom-condition axiom)) | |
| 1513 | (setq gterms (remove-duplicates (get-gterms (axiom-condition axiom)) | |
| 1514 | :test #'equal)))) | |
| 1515 | (t (setq gterms (delete-duplicates (append (get-gterms (axiom-lhs axiom)) | |
| 1516 | (append (get-gterms (axiom-rhs axiom)) | |
| 1517 | (get-gterms-from-axiom axiom t))) | |
| 1518 | :test #'equal)))) | |
| 1374 | 1519 | |
| 1375 | 1520 | gterms)) |
| 1376 | 1521 | |
| 1380 | 1525 | ;;; |
| 1381 | 1526 | (defun gsubterm-has-matching-rule (gterm c-rules) |
| 1382 | 1527 | (declare (type term gterm) |
| 1383 | (type list c-rules)) | |
| 1528 | (type list c-rules)) | |
| 1384 | 1529 | (dolist (term (delete gterm (get-gterms gterm))) |
| 1385 | 1530 | (with-citp-debug () |
| 1386 | 1531 | (format t "~% check : ") |
| 1387 | 1532 | (term-print-with-sort term)) |
| 1388 | 1533 | (dolist (crule c-rules) |
| 1389 | 1534 | (multiple-value-bind (gs sub no-match eeq) |
| 1390 | (@matcher (axiom-lhs crule) term :match) | |
| 1391 | (declare (ignore eeq sub gs)) | |
| 1392 | (unless no-match | |
| 1393 | #|| | |
| 1394 | (with-citp-debug | |
| 1395 | (format t "~%[ca] sub has matching rule: ") (print-axiom-brief crule) | |
| 1396 | (print-next) | |
| 1397 | (term-print-with-sort gterm)) | |
| 1398 | ||# | |
| 1399 | (return-from gsubterm-has-matching-rule t))))) | |
| 1535 | (@matcher (axiom-lhs crule) term :match) | |
| 1536 | (declare (ignore eeq sub gs)) | |
| 1537 | (unless no-match | |
| 1538 | (return-from gsubterm-has-matching-rule t))))) | |
| 1400 | 1539 | nil) |
| 1401 | 1540 | |
| 1402 | 1541 | ;;; ca-instantiate-condition : goal term -> term' |
| 1405 | 1544 | ;;; |
| 1406 | 1545 | (defun ca-instantiate-condition (goal condition) |
| 1407 | 1546 | (declare (type goal goal) |
| 1408 | (type term condition)) | |
| 1547 | (type term condition)) | |
| 1409 | 1548 | (let ((vars (term-variables condition)) |
| 1410 | (subst nil)) | |
| 1549 | (subst nil)) | |
| 1411 | 1550 | (declare (type list vars subst)) |
| 1412 | 1551 | (cond (vars (dolist (v vars) |
| 1413 | (push (cons v (variable->constant goal v)) subst)) | |
| 1414 | (substitution-image-simplifying subst condition)) | |
| 1415 | (t condition)))) | |
| 1552 | (push (cons v (variable->constant goal v)) subst)) | |
| 1553 | (substitution-image-simplifying subst condition)) | |
| 1554 | (t condition)))) | |
| 1416 | 1555 | |
| 1417 | 1556 | ;;; find-gterm-matching-conditionals : goal term List(conditional axioms) |
| 1418 | 1557 | ;;; -> List(<subst, axiom, condition>) |
| 1421 | 1560 | (defvar .duplicated. nil) |
| 1422 | 1561 | (defvar .subst-so-far. nil) |
| 1423 | 1562 | |
| 1563 | ||
| 1424 | 1564 | (defun find-gterm-matching-conditionals (goal gterm conditional-rules idx) |
| 1425 | 1565 | (declare (type goal goal) |
| 1426 | (type term gterm) | |
| 1427 | (type list conditional-rules) | |
| 1428 | (type fixnum idx)) | |
| 1566 | (type term gterm) | |
| 1567 | (type list conditional-rules) | |
| 1568 | (type fixnum idx)) | |
| 1429 | 1569 | (let ((res nil) |
| 1430 | (rejected nil)) | |
| 1570 | (rejected nil)) | |
| 1431 | 1571 | (dolist (rule conditional-rules) |
| 1432 | 1572 | (block next |
| 1433 | (unless (is-true? (rule-condition rule)) | |
| 1434 | (multiple-value-bind (gs sub no-match eeq) | |
| 1435 | (@matcher (axiom-lhs rule) gterm :match) | |
| 1436 | (declare (ignore eeq)) | |
| 1437 | (when no-match (return-from next nil)) | |
| 1438 | (let ((cond-instance | |
| 1439 | (ca-instantiate-condition goal | |
| 1440 | (substitution-image-simplifying sub (rule-condition rule))))) | |
| 1441 | (cond ((not (member cond-instance .subst-so-far. :test #'term-equational-equal)) | |
| 1442 | (push cond-instance .subst-so-far.) | |
| 1443 | (push cond-instance res)) | |
| 1444 | (t | |
| 1445 | ;; (push cond-instance res) ; *** | |
| 1446 | (push cond-instance rejected))) | |
| 1447 | (loop | |
| 1448 | (let ((n-subst nil) | |
| 1449 | (n-cond-inst nil)) | |
| 1450 | (multiple-value-setq (gs n-subst no-match) | |
| 1451 | (next-match gs)) | |
| 1452 | (when no-match (return-from next)) | |
| 1453 | (with-citp-debug () | |
| 1454 | (format t "~%[ca] adding extra.")) | |
| 1455 | (setq n-cond-inst | |
| 1456 | (ca-instantiate-condition goal | |
| 1457 | (substitution-image-simplifying n-subst (rule-condition rule)))) | |
| 1458 | (cond ((not (member n-cond-inst .subst-so-far. :test #'term-equational-equal)) | |
| 1459 | (unless (term-equational-equal n-cond-inst cond-instance) | |
| 1460 | (push n-cond-inst .subst-so-far.) | |
| 1461 | (push n-cond-inst res))) | |
| 1462 | (t | |
| 1463 | ;; (push cond-instance res) ; *** | |
| 1464 | (push cond-instance rejected)))))))))) | |
| 1573 | (unless (is-true? (rule-condition rule)) | |
| 1574 | (multiple-value-bind (gs sub no-match eeq) | |
| 1575 | (@matcher (axiom-lhs rule) gterm :match) | |
| 1576 | (declare (ignore eeq)) | |
| 1577 | (when no-match (return-from next nil)) | |
| 1578 | (let ((cond-instance | |
| 1579 | (ca-instantiate-condition goal | |
| 1580 | (substitution-image-simplifying sub (rule-condition rule))))) | |
| 1581 | (cond ((not (member cond-instance .subst-so-far. :test #'term-equational-equal)) | |
| 1582 | (push cond-instance .subst-so-far.) | |
| 1583 | (push cond-instance res)) | |
| 1584 | (t | |
| 1585 | (push cond-instance rejected))) | |
| 1586 | (loop | |
| 1587 | (let ((n-subst nil) | |
| 1588 | (n-cond-inst nil)) | |
| 1589 | (multiple-value-setq (gs n-subst no-match) | |
| 1590 | (next-match gs)) | |
| 1591 | (when no-match (return-from next)) | |
| 1592 | (with-citp-debug () | |
| 1593 | (format t "~%[ca] adding extra.")) | |
| 1594 | (setq n-cond-inst | |
| 1595 | (ca-instantiate-condition goal | |
| 1596 | (substitution-image-simplifying n-subst (rule-condition rule)))) | |
| 1597 | (cond ((not (member n-cond-inst .subst-so-far. :test #'term-equational-equal)) | |
| 1598 | (unless (term-equational-equal n-cond-inst cond-instance) | |
| 1599 | (push n-cond-inst .subst-so-far.) | |
| 1600 | (push n-cond-inst res))) | |
| 1601 | (t | |
| 1602 | ;; (push cond-instance res) ; *** | |
| 1603 | (push cond-instance rejected)))))))))) | |
| 1465 | 1604 | ;; |
| 1466 | 1605 | (with-citp-debug () |
| 1467 | 1606 | (when res |
| 1468 | (format t "~%found cases for ") (term-print-with-sort gterm) | |
| 1469 | (dolist (i res) | |
| 1470 | (print-next) | |
| 1471 | (term-print-with-sort i))) | |
| 1607 | (format t "~%found cases for ") (term-print-with-sort gterm) | |
| 1608 | (dolist (i res) | |
| 1609 | (print-next) | |
| 1610 | (term-print-with-sort i))) | |
| 1472 | 1611 | (when rejected |
| 1473 | (format t "~%rejected cases") | |
| 1474 | (dolist (i rejected) | |
| 1475 | (print-next) | |
| 1476 | (term-print-with-sort i)))) | |
| 1612 | (format t "~%rejected cases") | |
| 1613 | (dolist (i rejected) | |
| 1614 | (print-next) | |
| 1615 | (term-print-with-sort i)))) | |
| 1477 | 1616 | (when rejected |
| 1478 | 1617 | (setf (aref .duplicated. idx) (remove-duplicates rejected :test #'term-equational-equal))) |
| 1479 | 1618 | ;; |
| 1480 | 1619 | (remove-duplicates res :test #'term-equational-equal))) |
| 1481 | 1620 | |
| 1482 | ;;; | |
| 1483 | 1621 | ;;; generate-case-axioms : goal List(< rule . subst >) -> List(axiom) |
| 1484 | 1622 | ;;; |
| 1485 | 1623 | (defvar .new-axs-so-far. nil) |
| 1488 | 1626 | (with-in-module ((goal-context next-goal)) |
| 1489 | 1627 | (let ((case-axioms nil)) |
| 1490 | 1628 | (dolist (condition conditions) |
| 1491 | (let ((list-lhs nil)) | |
| 1492 | (if (method= *bool-cond-op* (term-method condition)) | |
| 1493 | (dolist (arg (list-assoc-subterms condition *bool-cond-op*)) | |
| 1494 | (push arg list-lhs)) | |
| 1495 | (setq list-lhs (list condition))) | |
| 1496 | (dolist (condition list-lhs) | |
| 1497 | (let ((axs (make-new-assumption *current-module* condition 'ca))) | |
| 1498 | (when axs | |
| 1499 | (unless (member axs .new-axs-so-far. :test #'rule-is-similar?) | |
| 1500 | (push axs .new-axs-so-far.) | |
| 1501 | (compute-rule-method axs) | |
| 1502 | (with-citp-debug () | |
| 1503 | (format t "~%[ca] adding an axiom to module ~s" (get-module-simple-name (goal-context next-goal))) | |
| 1504 | (print-next) | |
| 1505 | (print-axiom-brief axs)) | |
| 1506 | (set-operator-rewrite-rule *current-module* axs) | |
| 1507 | (adjoin-axiom-to-module *current-module* axs) | |
| 1508 | (push axs case-axioms))))))) | |
| 1629 | (let ((list-lhs nil)) | |
| 1630 | (if (method= *bool-cond-op* (term-method condition)) | |
| 1631 | (dolist (arg (list-assoc-subterms condition *bool-cond-op*)) | |
| 1632 | (push arg list-lhs)) | |
| 1633 | (setq list-lhs (list condition))) | |
| 1634 | (dolist (condition list-lhs) | |
| 1635 | (let ((axs (make-new-assumption *current-module* condition 'ca))) | |
| 1636 | (when axs | |
| 1637 | (unless (member axs .new-axs-so-far. :test #'rule-is-similar?) | |
| 1638 | (push axs .new-axs-so-far.) | |
| 1639 | (compute-rule-method axs) | |
| 1640 | (with-citp-debug () | |
| 1641 | (format t "~%[ca] adding an axiom to module ~s" (get-module-simple-name (goal-context next-goal))) | |
| 1642 | (print-next) | |
| 1643 | (print-axiom-brief axs)) | |
| 1644 | (set-operator-rewrite-rule *current-module* axs) | |
| 1645 | (adjoin-axiom-to-module *current-module* axs) | |
| 1646 | (push axs case-axioms))))))) | |
| 1509 | 1647 | (compile-module *current-module* t) |
| 1510 | 1648 | (setf (goal-assumptions next-goal) (append (goal-assumptions next-goal) |
| 1511 | (nreverse case-axioms)))))) | |
| 1512 | ||
| 1649 | (nreverse case-axioms)))))) | |
| 1650 | ||
| 1513 | 1651 | ;;; normalize-cases : List(List(term)) -> List(List(term))' |
| 1514 | 1652 | ;;; |
| 1515 | ||
| 1516 | #|| | |
| 1517 | (defun find-same-case-in (case l-case) | |
| 1518 | (declare (type list case l-case)) | |
| 1519 | (let ((size (length case))) | |
| 1520 | (declare (type fixnum size)) | |
| 1521 | (dolist (xc l-case) | |
| 1522 | (when (and (= size (length xc)) | |
| 1523 | (every #'(lambda (x) (find x xc :test #'term-equational-equal)) case)) | |
| 1524 | (return-from find-same-case-in xc))) | |
| 1525 | nil)) | |
| 1526 | ||# | |
| 1527 | 1653 | |
| 1528 | 1654 | (defun find-sub-case-in (case l-case) |
| 1529 | 1655 | (declare (type list case l-case)) |
| 1531 | 1657 | (declare (type fixnum size)) |
| 1532 | 1658 | (dolist (xc l-case) |
| 1533 | 1659 | (when (and (<= size (length xc)) |
| 1534 | (every #'(lambda (x) (find x xc :test #'term-equational-equal)) case)) | |
| 1660 | (every #'(lambda (x) (find x xc :test #'term-equational-equal)) case)) | |
| 1535 | 1661 | (return-from find-sub-case-in xc))) |
| 1536 | 1662 | nil)) |
| 1537 | 1663 | |
| 1539 | 1665 | (dolist (idx idxs) |
| 1540 | 1666 | (when (member term (aref .duplicated. idx) :test #'term-equational-equal) |
| 1541 | 1667 | (with-citp-debug () |
| 1542 | (format t "~% ... rejected.")) | |
| 1668 | (format t "~% ... rejected.")) | |
| 1543 | 1669 | (return-from case-is-valid nil))) |
| 1544 | 1670 | term) |
| 1545 | 1671 | |
| 1546 | 1672 | (defun remove-exclusive-cases (case) |
| 1547 | 1673 | (let ((idxs (mapcar #'(lambda (x) (car x)) case)) |
| 1548 | (result nil)) | |
| 1674 | (result nil)) | |
| 1549 | 1675 | (declare (type list idxs result)) |
| 1550 | 1676 | (with-citp-debug () |
| 1551 | 1677 | (format t "~%-- check these combination") |
| 1552 | 1678 | (dolist (c case) |
| 1553 | (print-next) | |
| 1554 | (format t "~idx ~d: " (car c)) | |
| 1555 | (term-print-with-sort (cdr c)))) | |
| 1679 | (print-next) | |
| 1680 | (format t "~idx ~d: " (car c)) | |
| 1681 | (term-print-with-sort (cdr c)))) | |
| 1556 | 1682 | (dolist (c case) |
| 1557 | 1683 | (let ((term (cdr c))) |
| 1558 | (when (case-is-valid idxs term) | |
| 1559 | (push term result)))) | |
| 1684 | (when (case-is-valid idxs term) | |
| 1685 | (push term result)))) | |
| 1560 | 1686 | result)) |
| 1561 | 1687 | |
| 1562 | 1688 | (defun normalize-cases (l-case ptree-node all-cases) |
| 1563 | 1689 | (declare (type list l-case) |
| 1564 | (type ptree-node ptree-node)) | |
| 1690 | (type ptree-node ptree-node)) | |
| 1565 | 1691 | (let ((mod (goal-context (ptree-node-goal ptree-node))) |
| 1566 | (dist-cases nil)) | |
| 1692 | (dist-cases nil)) | |
| 1567 | 1693 | (with-in-module (mod) |
| 1568 | 1694 | (flet ((distribute-cond (term) |
| 1569 | (if (method= *bool-cond-op* (term-head term)) | |
| 1570 | (list-assoc-subterms term *bool-cond-op*) | |
| 1571 | (list term)))) | |
| 1572 | (with-citp-debug () | |
| 1573 | (when .duplicated. | |
| 1574 | (format t "~%== .duplicated. === ") | |
| 1575 | (dotimes (x (1- (length .duplicated.))) | |
| 1576 | (format t "~%(~d)" x) | |
| 1577 | (dolist (trm (aref .duplicated. x)) | |
| 1578 | (print-next) | |
| 1579 | (term-print-with-sort trm))))) | |
| 1580 | (dolist (case l-case) | |
| 1581 | (block next | |
| 1582 | ;; case ::= (t0 t1 ... tn) | |
| 1583 | ;; first we remove exclusive cases | |
| 1584 | (setq case (remove-exclusive-cases case)) | |
| 1585 | (unless case (return-from next nil)) | |
| 1586 | (dolist (c case) | |
| 1587 | (setq all-cases (delete c all-cases :test #'term-equational-equal))) | |
| 1588 | ;; then divide /\ in each cases | |
| 1589 | (let ((dcase nil)) | |
| 1590 | (dolist (c case) | |
| 1591 | (setq dcase (nconc dcase (distribute-cond c)))) | |
| 1592 | (push (delete-duplicates dcase :test #'term-equational-equal) dist-cases))) | |
| 1593 | (setq dist-cases (nreverse dist-cases))) | |
| 1594 | ;; | |
| 1595 | (let ((result nil)) | |
| 1596 | ;; for each case | |
| 1597 | (dolist (case dist-cases) | |
| 1598 | (unless (find-sub-case-in case result) | |
| 1599 | (setq result (nconc result (list case))))) | |
| 1600 | (when all-cases | |
| 1601 | ;; remaining sole cases | |
| 1602 | (dolist (c all-cases) | |
| 1603 | (push (list c) result))) | |
| 1604 | ;; | |
| 1605 | result))))) | |
| 1695 | (if (method= *bool-cond-op* (term-head term)) | |
| 1696 | (list-assoc-subterms term *bool-cond-op*) | |
| 1697 | (list term)))) | |
| 1698 | (with-citp-debug () | |
| 1699 | (when .duplicated. | |
| 1700 | (format t "~%== .duplicated. === ") | |
| 1701 | (dotimes (x (1- (length .duplicated.))) | |
| 1702 | (format t "~%(~d)" x) | |
| 1703 | (dolist (trm (aref .duplicated. x)) | |
| 1704 | (print-next) | |
| 1705 | (term-print-with-sort trm))))) | |
| 1706 | (dolist (case l-case) | |
| 1707 | (block next | |
| 1708 | ;; case ::= (t0 t1 ... tn) | |
| 1709 | ;; first we remove exclusive cases | |
| 1710 | (setq case (remove-exclusive-cases case)) | |
| 1711 | (unless case (return-from next nil)) | |
| 1712 | (dolist (c case) | |
| 1713 | (setq all-cases (delete c all-cases :test #'term-equational-equal))) | |
| 1714 | ;; then divide /\ into each cases | |
| 1715 | (let ((dcase nil)) | |
| 1716 | (dolist (c case) | |
| 1717 | (setq dcase (nconc dcase (distribute-cond c)))) | |
| 1718 | (push (delete-duplicates dcase :test #'term-equational-equal) dist-cases))) | |
| 1719 | (setq dist-cases (nreverse dist-cases))) | |
| 1720 | ;; | |
| 1721 | (let ((result nil)) | |
| 1722 | ;; for each case | |
| 1723 | (dolist (case dist-cases) | |
| 1724 | (unless (find-sub-case-in case result) | |
| 1725 | (setq result (nconc result (list case))))) | |
| 1726 | (when all-cases | |
| 1727 | ;; remaining sole cases | |
| 1728 | (dolist (c all-cases) | |
| 1729 | (push (list c) result))) | |
| 1730 | ;; | |
| 1731 | result))))) | |
| 1606 | 1732 | |
| 1607 | 1733 | ;;; generate-cases : ptree-node term List(conditional-axiom) |
| 1608 | 1734 | ;;; |
| 1609 | 1735 | (defun generate-cases (ptree-node target conditional-rules divide?) |
| 1610 | 1736 | (declare (type ptree-node ptree-node) |
| 1611 | (list conditional-rules)) | |
| 1737 | (list conditional-rules)) | |
| 1612 | 1738 | (multiple-value-bind (norm-target app?) |
| 1613 | 1739 | (normalize-sentence target (goal-context (ptree-node-goal ptree-node))) |
| 1614 | 1740 | (when app? |
| 1619 | 1745 | (print-axiom-brief target)) |
| 1620 | 1746 | ;; then generate possible cases |
| 1621 | 1747 | (let ((gterms (get-gterms-from-axiom target)) |
| 1622 | (next-goals nil) | |
| 1623 | (remainings nil) | |
| 1624 | (all-cases nil) | |
| 1625 | (gt-idx 0) | |
| 1626 | (.subst-so-far. nil) | |
| 1627 | (.duplicated. nil)) | |
| 1748 | (next-goals nil) | |
| 1749 | (remainings nil) | |
| 1750 | (all-cases nil) | |
| 1751 | (gt-idx 0) | |
| 1752 | (.subst-so-far. nil) | |
| 1753 | (.duplicated. nil)) | |
| 1628 | 1754 | (declare (type fixnum gt-idx) |
| 1629 | (type list gterms next-goals remainings .subst-so-far.)) | |
| 1755 | (type list gterms next-goals remainings .subst-so-far.)) | |
| 1630 | 1756 | (setf .duplicated. (make-array (length gterms) :initial-element nil)) |
| 1631 | 1757 | ;; |
| 1632 | 1758 | (let ((g-conditions nil)) |
| 1633 | (dolist (gterm gterms) | |
| 1634 | (unless (gsubterm-has-matching-rule gterm conditional-rules) | |
| 1635 | (let ((conds (find-gterm-matching-conditionals (ptree-node-goal ptree-node) | |
| 1636 | gterm | |
| 1637 | conditional-rules | |
| 1638 | gt-idx))) | |
| 1639 | (when conds | |
| 1640 | (incf gt-idx) | |
| 1641 | (push conds g-conditions))))) | |
| 1642 | (setq g-conditions (nreverse g-conditions)) | |
| 1643 | (with-citp-debug () | |
| 1644 | (format t "~%All the conditions") | |
| 1645 | (print-next) | |
| 1646 | (dolist (gc g-conditions) | |
| 1647 | (princ "====") | |
| 1648 | (print-next) | |
| 1649 | (dolist (cond gc) | |
| 1650 | (term-print-with-sort cond)))) | |
| 1651 | ;; | |
| 1652 | (dolist (gc g-conditions) | |
| 1653 | (dolist (c gc) | |
| 1654 | (pushnew c all-cases :test #'term-equational-equal))) | |
| 1655 | ||
| 1656 | ;; make all combinations and generate cases | |
| 1657 | (let ((rv-combs (select-comb-elems g-conditions t)) | |
| 1658 | (next-goal nil)) | |
| 1659 | ;; distribute /\ and delete duplicated conditions | |
| 1660 | (with-citp-debug () | |
| 1661 | (format t "~%[ca] gterm conditions --BEFORE normalization: ") | |
| 1662 | (if rv-combs | |
| 1663 | (let ((rv-com nil)) | |
| 1664 | (dotimes (x (length rv-combs)) | |
| 1665 | (setq rv-com (nth x rv-combs)) | |
| 1666 | (print-next) | |
| 1667 | (format t "--(~d)--" (1+ x)) | |
| 1668 | (dolist (rr rv-com) | |
| 1669 | (print-next) | |
| 1670 | (format t "~d:" (car rr)) | |
| 1671 | (term-print-with-sort (cdr rr))))) | |
| 1672 | (format t "NONE."))) | |
| 1673 | ;; eliminate exclusive combinations and dupulicated cases. | |
| 1674 | ;; | |
| 1675 | (setq rv-combs (normalize-cases rv-combs ptree-node all-cases)) | |
| 1676 | ||
| 1677 | (with-citp-debug () | |
| 1678 | (format t "~%[ca] gterm conditions --AFTER normalization: ") | |
| 1679 | (if rv-combs | |
| 1680 | (let ((rv-com nil)) | |
| 1681 | (dotimes (x (length rv-combs)) | |
| 1682 | (setq rv-com (nth x rv-combs)) | |
| 1683 | (print-next) | |
| 1684 | (format t "--(~d)--" (1+ x)) | |
| 1685 | (dolist (rr rv-com) | |
| 1686 | (print-next) | |
| 1687 | (term-print-with-sort rr)))) | |
| 1688 | (format t "NONE."))) | |
| 1689 | (cond (rv-combs | |
| 1690 | (dolist (rv-com rv-combs) | |
| 1691 | (let ((.new-axs-so-far. nil)) | |
| 1692 | (setq next-goal (prepare-next-goal ptree-node .tactic-ca.)) | |
| 1693 | (setf (goal-targets next-goal) (list target)) | |
| 1694 | (generate-case-axioms next-goal rv-com) | |
| 1695 | (push next-goal next-goals))) | |
| 1696 | ;; normalize the target after adding cases | |
| 1697 | (normalize-sentence target *current-module*)) | |
| 1698 | (t | |
| 1699 | ;; no case is generated for the target | |
| 1700 | (push target remainings))))) | |
| 1759 | (dolist (gterm gterms) | |
| 1760 | (unless (gsubterm-has-matching-rule gterm conditional-rules) | |
| 1761 | (let ((conds (find-gterm-matching-conditionals (ptree-node-goal ptree-node) | |
| 1762 | gterm | |
| 1763 | conditional-rules | |
| 1764 | gt-idx))) | |
| 1765 | (when conds | |
| 1766 | (incf gt-idx) | |
| 1767 | (push conds g-conditions))))) | |
| 1768 | (setq g-conditions (nreverse g-conditions)) | |
| 1769 | (with-citp-debug () | |
| 1770 | (format t "~%All the conditions") | |
| 1771 | (print-next) | |
| 1772 | (dolist (gc g-conditions) | |
| 1773 | (princ "====") | |
| 1774 | (print-next) | |
| 1775 | (dolist (cond gc) | |
| 1776 | (term-print-with-sort cond)))) | |
| 1777 | ;; | |
| 1778 | (dolist (gc g-conditions) | |
| 1779 | (dolist (c gc) | |
| 1780 | (pushnew c all-cases :test #'term-equational-equal))) | |
| 1781 | ||
| 1782 | ;; make all combinations and generate cases | |
| 1783 | (let ((rv-combs (select-comb-elems g-conditions t)) | |
| 1784 | (next-goal nil)) | |
| 1785 | ;; distribute /\ and delete duplicated conditions | |
| 1786 | (with-citp-debug () | |
| 1787 | (format t "~%[ca] gterm conditions --BEFORE normalization: ") | |
| 1788 | (if rv-combs | |
| 1789 | (let ((rv-com nil)) | |
| 1790 | (dotimes (x (length rv-combs)) | |
| 1791 | (setq rv-com (nth x rv-combs)) | |
| 1792 | (print-next) | |
| 1793 | (format t "--(~d)--" (1+ x)) | |
| 1794 | (dolist (rr rv-com) | |
| 1795 | (print-next) | |
| 1796 | (format t "~d:" (car rr)) | |
| 1797 | (term-print-with-sort (cdr rr))))) | |
| 1798 | (format t "NONE."))) | |
| 1799 | ;; eliminate exclusive combinations and dupulicated cases. | |
| 1800 | (setq rv-combs (normalize-cases rv-combs ptree-node all-cases)) | |
| 1801 | ||
| 1802 | (with-citp-debug () | |
| 1803 | (format t "~%[ca] gterm conditions --AFTER normalization: ") | |
| 1804 | (if rv-combs | |
| 1805 | (let ((rv-com nil)) | |
| 1806 | (dotimes (x (length rv-combs)) | |
| 1807 | (setq rv-com (nth x rv-combs)) | |
| 1808 | (print-next) | |
| 1809 | (format t "--(~d)--" (1+ x)) | |
| 1810 | (dolist (rr rv-com) | |
| 1811 | (print-next) | |
| 1812 | (term-print-with-sort rr)))) | |
| 1813 | (format t "NONE."))) | |
| 1814 | (cond (rv-combs | |
| 1815 | (dolist (rv-com rv-combs) | |
| 1816 | (let ((.new-axs-so-far. nil)) | |
| 1817 | (setq next-goal (prepare-next-goal ptree-node .tactic-ca.)) | |
| 1818 | (setf (goal-targets next-goal) (list target)) | |
| 1819 | (generate-case-axioms next-goal rv-com) | |
| 1820 | (push next-goal next-goals))) | |
| 1821 | ;; normalize the target after adding cases | |
| 1822 | (normalize-sentence target *current-module*)) | |
| 1823 | (t | |
| 1824 | ;; no case is generated for the target | |
| 1825 | (push target remainings))))) | |
| 1701 | 1826 | ;; |
| 1702 | 1827 | (when remainings |
| 1703 | (when (or next-goals app? divide?) | |
| 1704 | (multiple-value-bind (app? nop-goals) | |
| 1705 | (apply-nil-internal ptree-node (reverse remainings) nil .tactic-ca.) | |
| 1706 | (declare (ignore app?)) | |
| 1707 | (dolist(ng nop-goals) | |
| 1708 | (let ((target (car (goal-targets ng)))) | |
| 1709 | ;; no case is generated: apply normalization & check the result | |
| 1710 | (multiple-value-bind (discharged normalized-target original-target) | |
| 1711 | (do-check-sentence target ng) | |
| 1712 | (when discharged | |
| 1713 | (format t "~%[ca] discharged: ") | |
| 1714 | (print-axiom-brief normalized-target) | |
| 1715 | (setf (goal-targets ng) nil | |
| 1716 | (goal-proved ng) (list original-target)))) | |
| 1717 | (push ng next-goals)))))) | |
| 1828 | (when (or next-goals app? divide?) | |
| 1829 | (multiple-value-bind (app? nop-goals) | |
| 1830 | (apply-nil-internal ptree-node (reverse remainings) nil .tactic-ca.) | |
| 1831 | (declare (ignore app?)) | |
| 1832 | (if-spoiler-on | |
| 1833 | :then (dolist(ng nop-goals) | |
| 1834 | (let ((target (car (goal-targets ng)))) | |
| 1835 | ;; no case is generated: apply normalization & check the result | |
| 1836 | (multiple-value-bind (discharged normalized-target original-target) | |
| 1837 | (do-check-sentence target ng) | |
| 1838 | (when discharged | |
| 1839 | (format t "~%[ca] discharged: ") | |
| 1840 | (print-axiom-brief normalized-target) | |
| 1841 | (setf (goal-targets ng) nil | |
| 1842 | (goal-proved ng) (list original-target)))) | |
| 1843 | (push ng next-goals))) | |
| 1844 | :else (setq next-goals nop-goals))))) | |
| 1718 | 1845 | ;; check LE |
| 1719 | 1846 | (setq next-goals (nreverse next-goals)) |
| 1720 | 1847 | (dolist (goal next-goals) |
| 1721 | (check-le goal)) | |
| 1848 | (check-le goal)) | |
| 1722 | 1849 | ;; |
| 1723 | 1850 | (values next-goals next-goals)))) |
| 1724 | 1851 | |
| 1725 | 1852 | (defun rule-is-for-case (rule) |
| 1726 | 1853 | (and (not (is-true? (rule-condition rule))) |
| 1727 | 1854 | (let ((labels (rule-labels rule))) |
| 1728 | (dolist (lb labels nil) | |
| 1729 | (let ((lstr (string lb))) | |
| 1730 | (when (and (>= (length lstr) 3) | |
| 1731 | (string-equal (subseq lstr 0 3) "CA-")) | |
| 1732 | (return-from rule-is-for-case t))))))) | |
| 1855 | (dolist (lb labels nil) | |
| 1856 | (let ((lstr (string lb))) | |
| 1857 | (when (and (>= (length lstr) 3) | |
| 1858 | (string-equal (subseq lstr 0 3) "CA-")) | |
| 1859 | (return-from rule-is-for-case t))))))) | |
| 1733 | 1860 | |
| 1734 | 1861 | (defun get-ca-rules (module) |
| 1735 | 1862 | (remove-if-not #'rule-is-for-case (module-all-rules module))) |
| 1736 | 1863 | |
| 1737 | (defun apply-ca (ptree-node) | |
| 1738 | (declare (type ptree-node ptree-node)) | |
| 1864 | ;;; apply-ca | |
| 1865 | ;;; toplevel of :ca | |
| 1866 | (defun apply-ca (ptree-node &rest ignore) | |
| 1867 | (declare (type ptree-node ptree-node) | |
| 1868 | (ignore ignore)) | |
| 1739 | 1869 | (with-in-context (ptree-node) |
| 1740 | 1870 | (with-in-module ((goal-context .cur-goal.)) |
| 1741 | 1871 | (let ((crules (get-ca-rules *current-module*)) |
| 1742 | (divide? (cdr .cur-targets.))) | |
| 1743 | (dolist (target .cur-targets.) | |
| 1744 | (multiple-value-bind (applied goals) | |
| 1745 | (generate-cases ptree-node target crules divide?) | |
| 1746 | (declare (ignore applied)) | |
| 1747 | (when goals (setq .next-goals. (nconc .next-goals. goals))))) | |
| 1748 | (values .next-goals. .next-goals.))))) | |
| 1872 | (divide? (cdr .cur-targets.))) | |
| 1873 | (dolist (target .cur-targets.) | |
| 1874 | (multiple-value-bind (applied goals) | |
| 1875 | (generate-cases ptree-node target crules divide?) | |
| 1876 | (declare (ignore applied)) | |
| 1877 | (when goals (setq .next-goals. (nconc .next-goals. goals))))) | |
| 1878 | (values .next-goals. .next-goals.))))) | |
| 1749 | 1879 | |
| 1750 | 1880 | ;;; for debug |
| 1751 | 1881 | (defun rule-is-case-generated (rule) |
| 1752 | 1882 | (and (is-true? (rule-condition rule)) |
| 1753 | 1883 | (let ((labels (rule-labels rule))) |
| 1754 | (dolist (lb labels nil) | |
| 1755 | (let ((lstr (string lb))) | |
| 1756 | (when (and (= 2 (length lstr)) | |
| 1757 | (string-equal lstr "CA")) | |
| 1758 | (return-from rule-is-case-generated t))))))) | |
| 1884 | (dolist (lb labels nil) | |
| 1885 | (let ((lstr (string lb))) | |
| 1886 | (when (and (= 2 (length lstr)) | |
| 1887 | (string-equal lstr "CA")) | |
| 1888 | (return-from rule-is-case-generated t))))))) | |
| 1759 | 1889 | |
| 1760 | 1890 | (defun print-case-axioms (node) |
| 1761 | 1891 | (let ((mod (goal-context (ptree-node-goal node))) |
| 1762 | (cas nil)) | |
| 1892 | (cas nil)) | |
| 1763 | 1893 | (with-in-module (mod) |
| 1764 | 1894 | (let ((all-rules (module-all-rules mod))) |
| 1765 | (dolist (rule all-rules) | |
| 1766 | (when (rule-is-case-generated rule) | |
| 1767 | (push rule cas)))) | |
| 1895 | (dolist (rule all-rules) | |
| 1896 | (when (rule-is-case-generated rule) | |
| 1897 | (push rule cas)))) | |
| 1768 | 1898 | (when cas |
| 1769 | (format t "~%** generated axioms in goal ~s" (goal-name (ptree-node-goal node))) | |
| 1770 | (let ((*print-indent* (+ 2 *print-indent*))) | |
| 1771 | (dolist (rl cas) | |
| 1772 | (print-next) | |
| 1773 | (print-axiom-brief rl))))))) | |
| 1899 | (format t "~%** generated axioms in goal ~s" (goal-name (ptree-node-goal node))) | |
| 1900 | (let ((*print-indent* (+ 2 *print-indent*))) | |
| 1901 | (dolist (rl cas) | |
| 1902 | (print-next) | |
| 1903 | (print-axiom-brief rl))))))) | |
| 1774 | 1904 | |
| 1775 | 1905 | (defun all-cases () |
| 1776 | 1906 | (unless *proof-tree* |
| 1777 | 1907 | (with-output-chaos-error ('no-context) |
| 1778 | 1908 | (format t "No proof tree!"))) |
| 1779 | 1909 | (dag-wfs (ptree-root *proof-tree*) |
| 1780 | #'print-case-axioms)) | |
| 1910 | #'print-case-axioms)) | |
| 1781 | 1911 | |
| 1782 | 1912 | ;;; ====================================== |
| 1783 | 1913 | ;;; TACTIC: Case Analysis on Sequence [CS] |
| 1784 | 1914 | ;;; TODO |
| 1785 | 1915 | ;;; ====================================== |
| 1786 | (defun apply-cs (ptree-node) | |
| 1916 | (defun apply-cs (ptree-node &rest ignore) | |
| 1917 | (declare (ignore ignore)) | |
| 1787 | 1918 | ptree-node) |
| 1788 | 1919 | |
| 1789 | 1920 | ;;; ========================================== |
| 1795 | 1926 | ;;; |
| 1796 | 1927 | (defun get-target-axiom (module target-form &optional (add-to-module nil)) |
| 1797 | 1928 | (let ((kind (first target-form)) |
| 1798 | (ax nil)) | |
| 1929 | (ax nil)) | |
| 1799 | 1930 | (cond ((eq :label kind) (setq ax (get-rule-labelled module (second target-form)))) |
| 1800 | (t (with-in-module (module) | |
| 1801 | (setq ax (parse-axiom-declaration (parse-module-element-1 (cdr target-form)))) | |
| 1802 | (when add-to-module | |
| 1803 | (set-operator-rewrite-rule module ax) | |
| 1804 | (adjoin-axiom-to-module module ax) | |
| 1805 | (set-needs-rule))))) | |
| 1931 | (t (with-in-module (module) | |
| 1932 | (setq ax (parse-axiom-declaration (parse-module-element-1 (cdr target-form)))) | |
| 1933 | (when add-to-module | |
| 1934 | (set-operator-rewrite-rule module ax) | |
| 1935 | (adjoin-axiom-to-module module ax) | |
| 1936 | (set-needs-rule))))) | |
| 1806 | 1937 | ax)) |
| 1807 | 1938 | |
| 1808 | 1939 | ;;; resolve-subst-form |
| 1810 | 1941 | (defun resolve-subst-form (context subst-forms) |
| 1811 | 1942 | (with-in-module (context) |
| 1812 | 1943 | (let ((subst nil) |
| 1813 | (*parse-variables* nil)) | |
| 1944 | (*parse-variables* nil)) | |
| 1814 | 1945 | (dolist (subst-form subst-forms) |
| 1815 | (let ((var-form (first subst-form)) | |
| 1816 | (term-form (rest subst-form)) | |
| 1817 | (var nil) | |
| 1818 | (term nil)) | |
| 1819 | (with-citp-debug () | |
| 1820 | (format t "~%resolving subst form:") | |
| 1821 | (print-next) | |
| 1822 | (format t " var=~s, term=~s" var-form term-form)) | |
| 1823 | (setq var (simple-parse context var-form)) | |
| 1824 | (when (or (term-ill-defined var) (not (term-is-variable? var))) | |
| 1825 | (with-output-chaos-error ('invalid-var-form) | |
| 1826 | (format t "Invalid variable in substitution: ~s" var-form))) | |
| 1827 | (setq term (simple-parse context term-form)) | |
| 1828 | (when (term-ill-defined term) | |
| 1829 | (with-output-chaos-error ('invalid-term) | |
| 1830 | (format t "No parse..: ~s" term-form))) | |
| 1831 | (unless (sort<= (term-sort term) (variable-sort var) *current-sort-order*) | |
| 1832 | (with-output-chaos-error ('sort-mismatch) | |
| 1833 | (format t "Sort mismatch for the substitution") | |
| 1834 | (print-next) | |
| 1835 | (format t " variable: ") (term-print-with-sort var) | |
| 1836 | (print-next) | |
| 1837 | (format t " term: ") (term-print-with-sort term))) | |
| 1838 | (push (cons var term) subst))) | |
| 1946 | (let ((var-form (first subst-form)) | |
| 1947 | (term-form (rest subst-form)) | |
| 1948 | (var nil) | |
| 1949 | (term nil)) | |
| 1950 | (with-citp-debug () | |
| 1951 | (format t "~%resolving subst form:") | |
| 1952 | (print-next) | |
| 1953 | (format t " var=~s, term=~s" var-form term-form)) | |
| 1954 | (setq var (simple-parse context var-form)) | |
| 1955 | (when (or (term-ill-defined var) (not (term-is-variable? var))) | |
| 1956 | (with-output-chaos-error ('invalid-var-form) | |
| 1957 | (format t "Invalid variable in substitution: ~s" var-form))) | |
| 1958 | (setq term (simple-parse context term-form)) | |
| 1959 | (when (term-ill-defined term) | |
| 1960 | (with-output-chaos-error ('invalid-term) | |
| 1961 | (format t "No parse..: ~s" term-form))) | |
| 1962 | (unless (sort<= (term-sort term) (variable-sort var) *current-sort-order*) | |
| 1963 | (with-output-chaos-error ('sort-mismatch) | |
| 1964 | (format t "Sort mismatch for the substitution") | |
| 1965 | (print-next) | |
| 1966 | (format t " variable: ") (term-print-with-sort var) | |
| 1967 | (print-next) | |
| 1968 | (format t " term: ") (term-print-with-sort term))) | |
| 1969 | (push (cons var term) subst))) | |
| 1839 | 1970 | subst))) |
| 1840 | 1971 | |
| 1841 | 1972 | ;;; |
| 1842 | 1973 | (defun make-real-instanciation-subst (subst axiom-vars) |
| 1843 | 1974 | (let ((rsubst nil) |
| 1844 | rv) | |
| 1975 | rv) | |
| 1845 | 1976 | (dolist (vt-pair subst) |
| 1846 | 1977 | (if (setq rv (get-real-target-variable (car vt-pair) axiom-vars)) |
| 1847 | (setq rsubst (acons rv (cdr vt-pair) rsubst)) | |
| 1848 | (with-output-chaos-error ('no-var) | |
| 1849 | (format t "Instanciating an axiom, no such variable ") | |
| 1850 | (term-print-with-sort (car vt-pair))))) | |
| 1978 | (setq rsubst (acons rv (cdr vt-pair) rsubst)) | |
| 1979 | (with-output-chaos-error ('no-var) | |
| 1980 | (format t "Instanciating an axiom, no such variable ") | |
| 1981 | (term-print-with-sort (car vt-pair))))) | |
| 1851 | 1982 | rsubst)) |
| 1852 | 1983 | |
| 1853 | 1984 | ;;; make-axiom-instance : module substitution axiom -> axiom' |
| 1855 | 1986 | ;;; |
| 1856 | 1987 | (defun make-axiom-instance (module subst axiom) |
| 1857 | 1988 | (let ((new-axiom (rule-copy-canonicalized axiom module)) |
| 1858 | (rsubst nil)) | |
| 1989 | (rsubst nil)) | |
| 1859 | 1990 | (setq rsubst (make-real-instanciation-subst subst (axiom-variables new-axiom))) |
| 1860 | 1991 | (apply-substitution-to-axiom rsubst new-axiom '(init)) |
| 1861 | #|| | |
| 1862 | (when (axiom-variables new-axiom) | |
| 1863 | (with-output-chaos-error ('not-ground) | |
| 1864 | (format t "Instanciating an axiom, not all variable substitutions are supplied.") | |
| 1865 | (dolist (v (axiom-variables new-axiom)) | |
| 1866 | (print-next) | |
| 1867 | (term-print-with-sort v)))) | |
| 1868 | ||# | |
| 1869 | 1992 | new-axiom)) |
| 1870 | 1993 | |
| 1871 | ;;; | |
| 1872 | 1994 | ;;; instanciate-axiom |
| 1873 | 1995 | ;;; |
| 1874 | 1996 | (defun instanciate-axiom (target-form subst-form) |
| 1875 | 1997 | (let ((context (get-next-proof-context *proof-tree*))) |
| 1876 | 1998 | (unless context |
| 1877 | 1999 | (with-output-chaos-error ('no-context) |
| 1878 | (format t "Instanciating axiom, no context module is established."))) | |
| 2000 | (format t "Instanciating axiom, no context module is established."))) | |
| 1879 | 2001 | (with-in-module ((goal-context (ptree-node-goal context))) |
| 1880 | (let ((*chaos-quiet* t) | |
| 1881 | (target-axiom (get-target-axiom *current-module* target-form t)) | |
| 1882 | (subst (resolve-subst-form *current-module* subst-form)) | |
| 1883 | (instance nil)) | |
| 1884 | ;; | |
| 1885 | (setq instance (make-axiom-instance *current-module* subst target-axiom)) | |
| 1886 | ;; input the instance to current context | |
| 1887 | (let ((goal (ptree-node-goal context))) | |
| 1888 | (setf (goal-assumptions goal) (append (goal-assumptions goal) (list instance))) | |
| 1889 | (format t "~%**> initialized the axiom in goal ~s" (goal-name (ptree-node-goal context))) | |
| 1890 | (let ((*print-indent* (+ 2 *print-indent*)) | |
| 1891 | (*print-line-limit* 80) | |
| 1892 | (*print-xmode* :fancy)) | |
| 1893 | (print-next) | |
| 1894 | (print-axiom-brief instance)) | |
| 1895 | (when *citp-verbose* | |
| 1896 | (pr-goal (ptree-node-goal context))) | |
| 1897 | (set-operator-rewrite-rule *current-module* instance) | |
| 1898 | (adjoin-axiom-to-module *current-module* instance) | |
| 1899 | (compile-module *current-module* t)))))) | |
| 2002 | (with-citp-env () | |
| 2003 | (let ((target-axiom (get-target-axiom *current-module* target-form t)) | |
| 2004 | (subst (resolve-subst-form *current-module* subst-form)) | |
| 2005 | (instance nil)) | |
| 2006 | ;; | |
| 2007 | (setq instance (make-axiom-instance *current-module* subst target-axiom)) | |
| 2008 | ;; we normalize the LHS of the instance | |
| 2009 | (with-spoiler-on | |
| 2010 | (multiple-value-bind (n-lhs applied?) | |
| 2011 | (normalize-term-in *current-module* (axiom-lhs instance)) | |
| 2012 | (when applied? | |
| 2013 | (setf (axiom-lhs instance) n-lhs)))) | |
| 2014 | ||
| 2015 | ;; input the instance to current context | |
| 2016 | (let ((goal (ptree-node-goal context))) | |
| 2017 | (setf (goal-assumptions goal) (append (goal-assumptions goal) (list instance))) | |
| 2018 | (format t "~%**> initialized the axiom in goal ~s" (goal-name (ptree-node-goal context))) | |
| 2019 | (let ((*print-indent* (+ 2 *print-indent*)) | |
| 2020 | (*print-line-limit* 80) | |
| 2021 | (*print-xmode* :fancy)) | |
| 2022 | (print-next) | |
| 2023 | (print-axiom-brief instance)) | |
| 2024 | (when-citp-verbose () | |
| 2025 | (pr-goal (ptree-node-goal context))) | |
| 2026 | (set-operator-rewrite-rule *current-module* instance) | |
| 2027 | (adjoin-axiom-to-module *current-module* instance) | |
| 2028 | (compile-module *current-module* t))))))) | |
| 2029 | ||
| 2030 | ;;; ================================ | |
| 2031 | ;;; Target sentence T -> A implies T [:ip] | |
| 2032 | ;;; ================================ | |
| 2033 | ||
| 1900 | 2034 | |
| 1901 | 2035 | ;;; ============== |
| 1902 | ;;; CRITICAL PAIRS | |
| 2036 | ;;; CRITICAL PAIRS [:cp] | |
| 1903 | 2037 | ;;; ============== |
| 1904 | 2038 | |
| 1905 | 2039 | (defun citp-rename-term-variables (suffix list-vars) |
| 1906 | 2040 | (let ((done nil)) |
| 1907 | 2041 | (dolist (var list-vars) |
| 1908 | 2042 | (unless (member var done) |
| 1909 | (push var done) | |
| 1910 | (setf (variable-name var) (intern (format nil "~a~a" (variable-name var) suffix))))))) | |
| 2043 | (push var done) | |
| 2044 | (setf (variable-name var) (intern (format nil "~a~a" (variable-name var) suffix))))))) | |
| 1911 | 2045 | |
| 1912 | 2046 | (let ((*renamed-variable-number* 0)) |
| 1913 | 2047 | (declare (type fixnum *renamed-variable-number*)) |
| 1918 | 2052 | ) |
| 1919 | 2053 | |
| 1920 | 2054 | (defstruct (cpp (:print-function pr-cpp)) |
| 1921 | (t1 nil :type term) ; sigma(lhs[pos]) | |
| 1922 | (t2 nil :type term) ; sigma(lhs) | |
| 1923 | (pos nil :type list) ; occurence of t1 in root term | |
| 1924 | (subst nil :type list) ; mgu | |
| 1925 | (cpairs nil :type list)) ; generated critical pairs in a form of axiom | |
| 2055 | (t1 nil :type term) ; sigma(lhs[pos]) | |
| 2056 | (t2 nil :type term) ; sigma(lhs) | |
| 2057 | (pos nil :type list) ; occurence of t1 in root term | |
| 2058 | (subst nil :type list) ; mgu | |
| 2059 | (cpairs nil :type list)) ; generated critical pairs in a form of axiom | |
| 1926 | 2060 | |
| 1927 | 2061 | (defun pr-cpp (cpp &optional (stream *standard-output*) &rest ignore) |
| 1928 | 2062 | (declare (ignore ignore)) |
| 1929 | 2063 | (format stream "~%Critical Pair ---------") |
| 1930 | 2064 | (let ((*print-indent* (+ *print-indent*)) |
| 1931 | (*standard-output* stream)) | |
| 2065 | (*standard-output* stream)) | |
| 1932 | 2066 | (print-next) |
| 1933 | 2067 | (princ "term 1: ") (term-print-with-sort (cpp-t1 cpp)) |
| 1934 | 2068 | (print-next) |
| 1941 | 2075 | (setq *print-indent* (+ 2 *print-indent*)) |
| 1942 | 2076 | (format t "~%- ~d critical pairs" (length (cpp-cpairs cpp))) |
| 1943 | 2077 | (dolist (cpair (cpp-cpairs cpp)) |
| 1944 | (print-next) | |
| 1945 | (print-axiom-brief cpair))))) | |
| 2078 | (print-next) | |
| 2079 | (print-axiom-brief cpair))))) | |
| 1946 | 2080 | |
| 1947 | 2081 | (defun compute-overwraps (t1 t2 occur) |
| 1948 | 2082 | (let ((cpps nil)) |
| 1949 | 2083 | (cond ((term-is-applform? t1) |
| 1950 | (multiple-value-bind (subst no-match e-eq) | |
| 1951 | (unify t1 t2) | |
| 1952 | (declare (ignore e-eq)) | |
| 1953 | (unless no-match | |
| 1954 | (push (make-cpp :t1 (substitution-image-simplifying subst t1) | |
| 1955 | :t2 (substitution-image-simplifying subst t2) | |
| 1956 | :subst subst | |
| 1957 | :pos occur) cpps)) | |
| 1958 | (let ((pos 0)) | |
| 1959 | (declare (type fixnum pos)) | |
| 1960 | (dolist (sub (term-subterms t1)) | |
| 1961 | (setq cpps (append cpps (compute-overwraps sub t2 (append occur (cons pos occur))))) | |
| 1962 | (incf pos))))) | |
| 1963 | (t nil)) | |
| 2084 | (multiple-value-bind (subst no-match e-eq) | |
| 2085 | (unify t1 t2) | |
| 2086 | (declare (ignore e-eq)) | |
| 2087 | (unless no-match | |
| 2088 | (push (make-cpp :t1 (substitution-image-simplifying subst t1) | |
| 2089 | :t2 (substitution-image-simplifying subst t2) | |
| 2090 | :subst subst | |
| 2091 | :pos occur) cpps)) | |
| 2092 | (let ((pos 0)) | |
| 2093 | (declare (type fixnum pos)) | |
| 2094 | (dolist (sub (term-subterms t1)) | |
| 2095 | (setq cpps (append cpps (compute-overwraps sub t2 (append occur (cons pos occur))))) | |
| 2096 | (incf pos))))) | |
| 2097 | (t nil)) | |
| 1964 | 2098 | cpps)) |
| 1965 | 2099 | |
| 1966 | 2100 | (defun term-at-pos (pos term) |
| 1973 | 2107 | (term-replace target repl-term) |
| 1974 | 2108 | term)) |
| 1975 | 2109 | |
| 1976 | ;;; | |
| 1977 | 2110 | ;;; compute-all-overwrapps : axiom axiom -> List(cpp) |
| 1978 | 2111 | ;;; |
| 1979 | 2112 | (defun compute-axiom-overwrapps (ax-1 ax-2) |
| 1980 | 2113 | (let ((lhs-1 (rule-lhs ax-1)) |
| 1981 | (lhs-2 (rule-lhs ax-2)) | |
| 1982 | (cpps nil)) | |
| 2114 | (lhs-2 (rule-lhs ax-2)) | |
| 2115 | (cpps nil)) | |
| 1983 | 2116 | (setq cpps (compute-overwraps lhs-1 lhs-2 '())) |
| 1984 | 2117 | cpps)) |
| 1985 | 2118 | |
| 1986 | 2119 | (defun generate-critical-pairs (cpps ax-1 ax-2) |
| 1987 | 2120 | (dolist (cpp cpps) |
| 1988 | 2121 | (let ((subst (cpp-subst cpp)) |
| 1989 | (cpairs nil)) | |
| 2122 | (cpairs nil)) | |
| 1990 | 2123 | (let ((cond-1 (substitution-image-simplifying subst (rule-condition ax-1))) |
| 1991 | (cond-2 (substitution-image-simplifying subst (rule-condition ax-2))) | |
| 1992 | (rhs (substitution-image-simplifying subst (rule-rhs ax-1))) | |
| 1993 | (lhs (replace-term-at (cpp-pos cpp) | |
| 1994 | (substitution-image-simplifying subst (axiom-lhs ax-1)) | |
| 1995 | (substitution-image-simplifying subst (axiom-rhs ax-2))))) | |
| 1996 | (with-citp-debug () | |
| 1997 | (format t "~%cond-1: ")(term-print-with-sort cond-1) | |
| 1998 | (format t "~%cond-2: ")(term-print-with-sort cond-2) | |
| 1999 | (format t "~%lhs: ") (term-print-with-sort lhs) | |
| 2000 | (format t "~%rhs: ") (term-print-with-sort rhs)) | |
| 2001 | ||
| 2002 | (let ((*perform-on-demand-reduction* t)) | |
| 2003 | (compile-module *current-module* t) | |
| 2004 | ;; LHS | |
| 2005 | (rewrite lhs *current-module*) | |
| 2006 | ;; RHS | |
| 2007 | (rewrite rhs *current-module*) | |
| 2008 | (unless (term-equational-equal lhs rhs) | |
| 2009 | (let ((ordered-pair (sort (list lhs rhs) #'lrpo))) | |
| 2010 | (pushnew (make-rule :lhs (first ordered-pair) | |
| 2011 | :rhs (second ordered-pair) | |
| 2012 | :condition *bool-true* | |
| 2013 | :type :equation ; might be changed later by command :equqtion or :rule | |
| 2014 | :labels '(cp)) | |
| 2015 | cpairs | |
| 2016 | :test #'rule-is-similar?))) | |
| 2017 | ||
| 2018 | ;; Condition | |
| 2019 | (let ((new-cond (make-applform-simple *condition-sort* *bool-cond-op* (list cond-1 cond-2)))) | |
| 2020 | (with-citp-debug () | |
| 2021 | (format t "~%[cp] generated condition: ") | |
| 2022 | (term-print-with-sort new-cond)) | |
| 2023 | (rewrite new-cond *current-module*) | |
| 2024 | (with-citp-debug () | |
| 2025 | (format t "~% after normalized :") | |
| 2026 | (print-next) | |
| 2027 | (term-print-with-sort new-cond)) | |
| 2028 | (unless (is-true? new-cond) | |
| 2029 | (cond ((eq *bool-cond-op* (term-head new-cond)) | |
| 2030 | (let ((subs (list-assoc-subterms new-cond *bool-cond-op*))) | |
| 2031 | (setq subs (sort subs #'lrpo)) | |
| 2032 | (do* ((sl subs (cdr sl)) | |
| 2033 | (lhs (car sl) (car sl)) | |
| 2034 | (rhs (cadr sl))) | |
| 2035 | ((null rhs)) | |
| 2036 | (pushnew (make-rule :lhs lhs | |
| 2037 | :rhs rhs | |
| 2038 | :condition *bool-true* | |
| 2039 | :type :equation | |
| 2040 | :labels '(cpc)) | |
| 2041 | cpairs | |
| 2042 | :test #'rule-is-similar?)))) | |
| 2043 | (t (pushnew (make-rule :lhs new-cond | |
| 2044 | :rhs *bool-true* | |
| 2045 | :condition *bool-true* | |
| 2046 | :type :equation | |
| 2047 | :labels '(cpc)) | |
| 2048 | cpairs | |
| 2049 | :test #'rule-is-similar?))))))) | |
| 2124 | (cond-2 (substitution-image-simplifying subst (rule-condition ax-2))) | |
| 2125 | (rhs (substitution-image-simplifying subst (rule-rhs ax-1))) | |
| 2126 | (lhs (replace-term-at (cpp-pos cpp) | |
| 2127 | (substitution-image-simplifying subst (axiom-lhs ax-1)) | |
| 2128 | (substitution-image-simplifying subst (axiom-rhs ax-2))))) | |
| 2129 | (with-citp-debug () | |
| 2130 | (format t "~%cond-1: ")(term-print-with-sort cond-1) | |
| 2131 | (format t "~%cond-2: ")(term-print-with-sort cond-2) | |
| 2132 | (format t "~%lhs: ") (term-print-with-sort lhs) | |
| 2133 | (format t "~%rhs: ") (term-print-with-sort rhs)) | |
| 2134 | ||
| 2135 | (let ((*perform-on-demand-reduction* t)) | |
| 2136 | (compile-module *current-module* t) | |
| 2137 | ;; LHS | |
| 2138 | (rewrite lhs *current-module*) | |
| 2139 | ;; RHS | |
| 2140 | (rewrite rhs *current-module*) | |
| 2141 | (unless (term-equational-equal lhs rhs) | |
| 2142 | (let ((ordered-pair (sort (list lhs rhs) #'lrpo))) | |
| 2143 | (pushnew (make-rule :lhs (first ordered-pair) | |
| 2144 | :rhs (second ordered-pair) | |
| 2145 | :condition *bool-true* | |
| 2146 | :type :equation ; might be changed later by command :equqtion or :rule | |
| 2147 | :labels '(cp)) | |
| 2148 | cpairs | |
| 2149 | :test #'rule-is-similar?))) | |
| 2150 | ||
| 2151 | ;; Condition | |
| 2152 | (let ((new-cond (make-applform-simple *condition-sort* *bool-cond-op* (list cond-1 cond-2)))) | |
| 2153 | (with-citp-debug () | |
| 2154 | (format t "~%[cp] generated condition: ") | |
| 2155 | (term-print-with-sort new-cond)) | |
| 2156 | (rewrite new-cond *current-module*) | |
| 2157 | (with-citp-debug () | |
| 2158 | (format t "~% after normalized :") | |
| 2159 | (print-next) | |
| 2160 | (term-print-with-sort new-cond)) | |
| 2161 | (unless (is-true? new-cond) | |
| 2162 | (cond ((eq *bool-cond-op* (term-head new-cond)) | |
| 2163 | (let ((subs (list-assoc-subterms new-cond *bool-cond-op*))) | |
| 2164 | (setq subs (sort subs #'lrpo)) | |
| 2165 | (do* ((sl subs (cdr sl)) | |
| 2166 | (lhs (car sl) (car sl)) | |
| 2167 | (rhs (cadr sl))) | |
| 2168 | ((null rhs)) | |
| 2169 | (pushnew (make-rule :lhs lhs | |
| 2170 | :rhs rhs | |
| 2171 | :condition *bool-true* | |
| 2172 | :type :equation | |
| 2173 | :labels '(cpc)) | |
| 2174 | cpairs | |
| 2175 | :test #'rule-is-similar?)))) | |
| 2176 | (t (pushnew (make-rule :lhs new-cond | |
| 2177 | :rhs *bool-true* | |
| 2178 | :condition *bool-true* | |
| 2179 | :type :equation | |
| 2180 | :labels '(cpc)) | |
| 2181 | cpairs | |
| 2182 | :test #'rule-is-similar?))))))) | |
| 2050 | 2183 | (setf (cpp-cpairs cpp) cpairs)))) |
| 2051 | 2184 | |
| 2052 | 2185 | (defun compute-critical-pairs (module axiom1 axiom2) |
| 2053 | 2186 | (with-in-module (module) |
| 2054 | 2187 | (let ((ax-1 (citp-rename-axiom-variables (rule-copy-canonicalized axiom1 module))) |
| 2055 | (ax-2 (citp-rename-axiom-variables (rule-copy-canonicalized axiom2 module))) | |
| 2056 | (cpp-1 nil) | |
| 2057 | (cpp-2 nil)) | |
| 2188 | (ax-2 (citp-rename-axiom-variables (rule-copy-canonicalized axiom2 module))) | |
| 2189 | (cpp-1 nil) | |
| 2190 | (cpp-2 nil)) | |
| 2058 | 2191 | (setq cpp-1 (compute-axiom-overwrapps ax-1 ax-2)) |
| 2059 | 2192 | (setq cpp-2 (compute-axiom-overwrapps ax-2 ax-1)) |
| 2060 | 2193 | (generate-critical-pairs cpp-1 ax-1 ax-2) |
| 2061 | 2194 | (generate-critical-pairs cpp-2 ax-2 ax-1) |
| 2062 | 2195 | |
| 2063 | 2196 | (with-citp-debug () |
| 2064 | (format t "~%------- cpp-1") | |
| 2065 | (print cpp-1) | |
| 2066 | (format t "~%------- cpp-2") | |
| 2067 | (print cpp-2)) | |
| 2197 | (format t "~%------- cpp-1") | |
| 2198 | (print cpp-1) | |
| 2199 | (format t "~%------- cpp-2") | |
| 2200 | (print cpp-2)) | |
| 2068 | 2201 | |
| 2069 | 2202 | (let ((all-cpairs nil)) |
| 2070 | (dolist (cp1 (nconc cpp-1 cpp-2)) | |
| 2071 | (setq all-cpairs (nconc all-cpairs (cpp-cpairs cp1)))) | |
| 2072 | (remove-duplicates all-cpairs :test #'rule-is-similar?))))) | |
| 2203 | (dolist (cp1 (nconc cpp-1 cpp-2)) | |
| 2204 | (setq all-cpairs (nconc all-cpairs (cpp-cpairs cp1)))) | |
| 2205 | (remove-duplicates all-cpairs :test #'rule-is-similar?))))) | |
| 2073 | 2206 | |
| 2074 | 2207 | ;;; apply-cp : axiom-form axiom-form -> void |
| 2075 | 2208 | ;;; |
| 2077 | 2210 | (let ((context (get-next-proof-context *proof-tree*))) |
| 2078 | 2211 | (unless context |
| 2079 | 2212 | (with-output-chaos-error ('no-context) |
| 2080 | (format t "Applying [cp], no context module is established."))) | |
| 2213 | (format t "Applying [cp], no context module is established."))) | |
| 2081 | 2214 | (let ((goal (ptree-node-goal context))) |
| 2082 | 2215 | (with-in-module ((goal-context goal)) |
| 2083 | (let ((t1axiom (get-target-axiom *current-module* target-1)) | |
| 2084 | (t2axiom (get-target-axiom *current-module* target-2)) | |
| 2085 | (cpps nil)) | |
| 2086 | (setq cpps | |
| 2087 | (setf (goal-critical-pairs goal) (compute-critical-pairs *current-module* t1axiom t2axiom))) | |
| 2088 | (when cpps | |
| 2089 | (format t "~%[cp] :") | |
| 2090 | (let ((*print-indent* (+ 2 *print-indent*))) | |
| 2091 | (dotimes (x (length cpps)) | |
| 2092 | (print-next) | |
| 2093 | (format t "(~d) " (1+ x)) | |
| 2094 | (let ((ax (nth x cpps))) | |
| 2095 | (term-print-with-sort (axiom-lhs ax)) | |
| 2096 | (print-next) | |
| 2097 | (princ " => ") | |
| 2098 | (term-print-with-sort (axiom-rhs ax))))))))))) | |
| 2216 | (let ((t1axiom (get-target-axiom *current-module* target-1)) | |
| 2217 | (t2axiom (get-target-axiom *current-module* target-2)) | |
| 2218 | (cpps nil)) | |
| 2219 | (setq cpps | |
| 2220 | (setf (goal-critical-pairs goal) (compute-critical-pairs *current-module* t1axiom t2axiom))) | |
| 2221 | (when cpps | |
| 2222 | (format t "~%[cp] :") | |
| 2223 | (let ((*print-indent* (+ 2 *print-indent*))) | |
| 2224 | (dotimes (x (length cpps)) | |
| 2225 | (print-next) | |
| 2226 | (format t "(~d) " (1+ x)) | |
| 2227 | (let ((ax (nth x cpps))) | |
| 2228 | (term-print-with-sort (axiom-lhs ax)) | |
| 2229 | (print-next) | |
| 2230 | (princ " => ") | |
| 2231 | (term-print-with-sort (axiom-rhs ax))))))))))) | |
| 2099 | 2232 | |
| 2100 | 2233 | ;;; add-critical-pairs |
| 2101 | 2234 | ;;; |
| 2103 | 2236 | (let ((context (get-next-proof-context *proof-tree*))) |
| 2104 | 2237 | (unless context |
| 2105 | 2238 | (with-output-chaos-error ('no-context) |
| 2106 | (format t "Applying [cp], no context module is established."))) | |
| 2239 | (format t "Applying [cp], no context module is established."))) | |
| 2107 | 2240 | (let ((goal (ptree-node-goal context)) |
| 2108 | (applied nil)) | |
| 2241 | (applied nil)) | |
| 2109 | 2242 | (with-in-module ((goal-context goal)) |
| 2110 | (dolist (cps (goal-critical-pairs goal)) | |
| 2111 | (setf (rule-type cps) type) | |
| 2112 | (when (eq direction :backward) | |
| 2113 | (let ((rhs (rule-lhs cps)) | |
| 2114 | (lhs (rule-rhs cps))) | |
| 2115 | (setf (rule-lhs cps) lhs | |
| 2116 | (rule-rhs cps) rhs))) | |
| 2117 | (compute-rule-method cps) | |
| 2118 | (set-operator-rewrite-rule *current-module* cps) | |
| 2119 | (adjoin-axiom-to-module *current-module* cps) | |
| 2120 | (setq applied (nconc applied (list cps)))) | |
| 2121 | (when applied | |
| 2122 | (setf (goal-assumptions goal) (nconc (goal-assumptions goal) (nreverse applied))) | |
| 2123 | (format t "~%[cp] added cp ~a~p to goal ~s: " type (length applied) (goal-name goal)) | |
| 2124 | (let ((*print-indent* (+ 2 *print-indent*))) | |
| 2125 | (dolist (ax applied) | |
| 2126 | (print-next) | |
| 2127 | (print-axiom-brief ax))) | |
| 2128 | (when *citp-verbose* | |
| 2129 | (pr-goal goal))))))) | |
| 2243 | (dolist (cps (goal-critical-pairs goal)) | |
| 2244 | (setf (rule-type cps) type) | |
| 2245 | (when (eq direction :backward) | |
| 2246 | (let ((rhs (rule-lhs cps)) | |
| 2247 | (lhs (rule-rhs cps))) | |
| 2248 | (setf (rule-lhs cps) lhs | |
| 2249 | (rule-rhs cps) rhs))) | |
| 2250 | (compute-rule-method cps) | |
| 2251 | (set-operator-rewrite-rule *current-module* cps) | |
| 2252 | (adjoin-axiom-to-module *current-module* cps) | |
| 2253 | (setq applied (nconc applied (list cps)))) | |
| 2254 | (when applied | |
| 2255 | (setf (goal-assumptions goal) (nconc (goal-assumptions goal) (nreverse applied))) | |
| 2256 | (format t "~%[cp] added cp ~a~p to goal ~s: " type (length applied) (goal-name goal)) | |
| 2257 | (let ((*print-indent* (+ 2 *print-indent*))) | |
| 2258 | (dolist (ax applied) | |
| 2259 | (print-next) | |
| 2260 | (print-axiom-brief ax))) | |
| 2261 | (when *citp-verbose* | |
| 2262 | (pr-goal goal))))))) | |
| 2130 | 2263 | |
| 2131 | 2264 | ;;; =================================================== |
| 2132 | 2265 | ;;; {:red | :exec | :bred} [in <goal-name> : ] <term> . |
| 2136 | 2269 | (defun reduce-in-goal (mode goal-name token-seq) |
| 2137 | 2270 | (with-citp-debug () |
| 2138 | 2271 | (format t "~%~s in ~s : ~s" (string mode) goal-name token-seq)) |
| 2139 | (let ((next-goal-node (if goal-name | |
| 2140 | (find-goal-node *proof-tree* goal-name) | |
| 2141 | (get-next-proof-context *proof-tree*)))) | |
| 2142 | (unless next-goal-node | |
| 2143 | (with-output-chaos-error ('no-target) | |
| 2144 | (if goal-name | |
| 2145 | (format t ":~a could not find the goal ~s." mode goal-name) | |
| 2146 | (format t "No default target goal.")))) | |
| 2272 | (let ((next-goal-node (get-target-goal-node goal-name))) | |
| 2273 | ;; do rewriting | |
| 2147 | 2274 | (perform-reduction* token-seq (goal-context (ptree-node-goal next-goal-node)) mode))) |
| 2148 | 2275 | |
| 2149 | ;;; :ctf | |
| 2150 | ;;; | |
| 2151 | (defun do-apply-ctf (cur-node equation) | |
| 2152 | (let ((*chaos-quiet* t) | |
| 2153 | (*rwl-search-no-state-report* t) | |
| 2154 | (cur-goal (ptree-node-goal cur-node))) | |
| 2155 | (when (goal-is-discharged cur-goal) | |
| 2276 | ;;; =========== | |
| 2277 | ;;; TACTIC: :NF | |
| 2278 | ;;; explicit application of NF (compute normal form of targets). | |
| 2279 | ;;; | |
| 2280 | ;;; =========== | |
| 2281 | (defun apply-nf (ptree-node &rest ignore) | |
| 2282 | (declare (type ptree-node ptree-node) | |
| 2283 | (ignore ignore)) | |
| 2284 | (let ((.cur-goal. (ptree-node-goal ptree-node))) | |
| 2285 | (when (goal-is-discharged .cur-goal.) | |
| 2156 | 2286 | (with-output-chaos-warning () |
| 2157 | (format t "** The goal ~s has been proved!." (goal-name (ptree-node-goal cur-node))) | |
| 2158 | (return-from do-apply-ctf nil))) | |
| 2159 | (let ((t-goal (prepare-next-goal cur-node .tactic-ctf.)) | |
| 2160 | (f-goal (prepare-next-goal cur-node .tactic-ctf.))) | |
| 2161 | ;; true case | |
| 2162 | (with-in-module ((goal-context t-goal)) | |
| 2163 | (adjoin-axiom-to-module *current-module* equation) | |
| 2164 | (set-operator-rewrite-rule *current-module* equation) | |
| 2165 | (compile-module *current-module*)) | |
| 2166 | (setf (goal-targets t-goal) (goal-targets cur-goal)) | |
| 2167 | (setf (goal-assumptions t-goal) (append (goal-assumptions cur-goal) (list equation))) | |
| 2168 | ;; false case | |
| 2169 | (let ((f-ax nil)) | |
| 2170 | (with-in-module ((goal-context f-goal)) | |
| 2171 | (setq f-ax (make-rule :lhs (make-applform-simple *bool-sort* | |
| 2172 | *eql-op* | |
| 2173 | (list (rule-lhs equation) | |
| 2174 | (rule-rhs equation))) | |
| 2175 | :rhs *bool-false* | |
| 2176 | :condition *bool-true* | |
| 2177 | :type :equation | |
| 2178 | :behavioural nil)) | |
| 2179 | (adjoin-axiom-to-module *current-module* f-ax) | |
| 2180 | (set-operator-rewrite-rule *current-module* f-ax) | |
| 2181 | (compile-module *current-module*)) | |
| 2182 | (setf (goal-targets f-goal) (goal-targets cur-goal)) | |
| 2183 | (setf (goal-assumptions f-goal) (append (goal-assumptions cur-goal) (list f-ax))) | |
| 2184 | (values t (list t-goal f-goal)))))) | |
| 2185 | ||
| 2186 | (defun apply-ctf (equation &optional (verbose *citp-verbose*)) | |
| 2187 | (check-ptree) | |
| 2287 | (format t "** The goal ~s has already been proved!." | |
| 2288 | (goal-name .cur-goal.))) | |
| 2289 | (return-from apply-nf nil)) | |
| 2290 | (with-citp-env () | |
| 2291 | (with-spoiler-on () | |
| 2292 | (with-in-module ((goal-context .cur-goal.)) | |
| 2293 | (let ((n-targets nil) | |
| 2294 | (applied nil)) | |
| 2295 | ;; normalize goal sentences | |
| 2296 | (dolist (sen (goal-targets .cur-goal.)) | |
| 2297 | (multiple-value-bind (ngoal app?) | |
| 2298 | (normalize-sentence sen *current-module*) | |
| 2299 | (if app? | |
| 2300 | (progn (setq applied t) (push ngoal n-targets)) | |
| 2301 | (push sen n-targets)))) | |
| 2302 | (when applied | |
| 2303 | (let ((next-goal (prepare-next-goal ptree-node 'nf))) | |
| 2304 | (setf (goal-targets next-goal) (nreverse n-targets)) | |
| 2305 | (return-from apply-nf (values t (list next-goal))))) | |
| 2306 | (values nil nil))))))) | |
| 2307 | ||
| 2308 | ;;; =========== | |
| 2309 | ;;; TACTIC: :CT | |
| 2310 | ;;; do contradiction check, can dischage the goal | |
| 2311 | ;;; =========== | |
| 2312 | (defun apply-ct (ptree-node &rest ignore) | |
| 2313 | (declare (type ptree-node ptree-node) | |
| 2314 | (ignore ignore)) | |
| 2315 | (let ((.cur-goal. (ptree-node-goal ptree-node))) | |
| 2316 | (when (goal-is-discharged .cur-goal.) | |
| 2317 | (with-output-chaos-warning () | |
| 2318 | (format t "** The goal ~s has already been proved!." | |
| 2319 | (goal-name .cur-goal.))) | |
| 2320 | (return-from apply-ct nil)) | |
| 2321 | ;; | |
| 2322 | (with-in-module ((goal-context .cur-goal.)) | |
| 2323 | (with-citp-env () | |
| 2324 | (with-spoiler-on () | |
| 2325 | (when (check-contradiction .cur-goal. 'ct) | |
| 2326 | (with-in-module ((goal-context .cur-goal.)) | |
| 2327 | (format t "%[ct] dischaged:") | |
| 2328 | (dolist (target (goal-targets .cur-goal.)) | |
| 2329 | (print-next) | |
| 2330 | (print-axiom-brief target)) | |
| 2331 | (setf (goal-proved .cur-goal.) (goal-targets .cur-goal.)) | |
| 2332 | (setf (goal-targets .cur-goal.) nil))))) | |
| 2333 | t))) | |
| 2334 | ||
| 2335 | ;;; ============== | |
| 2336 | ;;; :ctf or :ctf- | |
| 2337 | ;;; ============== | |
| 2338 | ||
| 2339 | (defun make-ctf-constructor-pattern (const-op) | |
| 2340 | (when (method-arity const-op) | |
| 2341 | (with-output-chaos-warning () | |
| 2342 | (format t "Only constant constructors are supported. Sorry!") | |
| 2343 | (return-from make-ctf-constructor-pattern nil))) | |
| 2344 | (make-applform-simple (method-coarity const-op) const-op nil)) | |
| 2345 | ||
| 2346 | (defun do-apply-ctf-with-constructors (cur-node term tactic) | |
| 2347 | (let ((cur-goal (ptree-node-goal cur-node)) | |
| 2348 | (sort (term-sort term)) | |
| 2349 | (goals nil)) | |
| 2350 | (let ((constructors (find-sort-constructors-in *current-module* sort))) | |
| 2351 | (unless constructors | |
| 2352 | (with-output-chaos-error ('no-constructors) | |
| 2353 | (format t "Sort ~a has no constructors." (sort-name sort)))) | |
| 2354 | (dolist (const (sort constructors | |
| 2355 | #'(lambda (x y) | |
| 2356 | (let ((prec (op-lex-precedence x y))) | |
| 2357 | (if (eq prec :greater) | |
| 2358 | t | |
| 2359 | nil))))) | |
| 2360 | (let ((n-goal nil) | |
| 2361 | (const-pat (make-ctf-constructor-pattern const))) | |
| 2362 | (when const-pat | |
| 2363 | (setq n-goal (prepare-next-goal cur-node tactic)) | |
| 2364 | (with-in-module ((goal-context n-goal)) | |
| 2365 | (multiple-value-bind (lhs rhs type) | |
| 2366 | (if (sort= (term-sort term) *bool-sort*) | |
| 2367 | (simplify-boolean-axiom term const-pat) | |
| 2368 | (values term const-pat :equation)) | |
| 2369 | (when lhs | |
| 2370 | (let ((ax (make-rule :lhs lhs | |
| 2371 | :rhs rhs | |
| 2372 | :condition *bool-true* | |
| 2373 | :type type | |
| 2374 | :labels (list (tactic-name tactic)) | |
| 2375 | :behavioural nil))) | |
| 2376 | (adjoin-axiom-to-module *current-module* ax) | |
| 2377 | (set-operator-rewrite-rule *current-module* ax) | |
| 2378 | (compile-module *current-module*) | |
| 2379 | (push n-goal goals) | |
| 2380 | (setf (goal-targets n-goal) (goal-targets cur-goal)) | |
| 2381 | (setf (goal-assumptions n-goal) | |
| 2382 | (append (goal-assumptions cur-goal) (list ax)))))))))) | |
| 2383 | (with-citp-debug () | |
| 2384 | (format t "~%ctf to constructors generated:") | |
| 2385 | (dolist (g (reverse goals)) | |
| 2386 | (print-next) | |
| 2387 | (pr-goal g))) | |
| 2388 | (if goals | |
| 2389 | (values t (nreverse goals)) | |
| 2390 | (values nil nil))))) | |
| 2391 | ||
| 2392 | (defun do-apply-ctf-to-equation (cur-node equation tactic) | |
| 2393 | (let ((cur-goal (ptree-node-goal cur-node))) | |
| 2394 | (flet ((add-assumption (goal lhs rhs) | |
| 2395 | (let (n-axiom) | |
| 2396 | (multiple-value-bind (n-lhs n-rhs type) | |
| 2397 | (simplify-boolean-axiom lhs rhs) | |
| 2398 | (cond (n-lhs | |
| 2399 | (setq n-axiom (make-rule :lhs n-lhs | |
| 2400 | :rhs n-rhs | |
| 2401 | :condition *bool-true* | |
| 2402 | :type type | |
| 2403 | :behavioural nil | |
| 2404 | :labels (list(tactic-name tactic)))) | |
| 2405 | (with-in-module ((goal-context goal)) | |
| 2406 | (adjoin-axiom-to-module *current-module* n-axiom) | |
| 2407 | (set-operator-rewrite-rule *current-module* n-axiom) | |
| 2408 | (compile-module *current-module*)) | |
| 2409 | (setf (goal-targets goal) (goal-targets cur-goal)) | |
| 2410 | (setf (goal-assumptions goal) | |
| 2411 | (append (goal-assumptions cur-goal) (list n-axiom)))) | |
| 2412 | (t | |
| 2413 | (with-output-chaos-warning () | |
| 2414 | (format t "[ctf] invalid assumption") | |
| 2415 | (print-next) | |
| 2416 | (print-axiom-brief equation) | |
| 2417 | (print-next) | |
| 2418 | (format t "...ignored.") | |
| 2419 | nil))))))) | |
| 2420 | (let ((t-goal (prepare-next-goal cur-node tactic)) | |
| 2421 | (f-goal (prepare-next-goal cur-node tactic))) | |
| 2422 | (with-in-module ((goal-context cur-goal)) | |
| 2423 | (let ((lhs (make-applform-simple *bool-sort* | |
| 2424 | *eql-op* | |
| 2425 | (list (rule-lhs equation) | |
| 2426 | (rule-rhs equation))))) | |
| 2427 | ;; true case | |
| 2428 | (unless (add-assumption t-goal lhs *bool-true*) | |
| 2429 | (setq t-goal nil)) | |
| 2430 | ;; false case | |
| 2431 | (unless (add-assumption f-goal lhs *bool-false*) | |
| 2432 | (setq f-goal nil)))) | |
| 2433 | (with-citp-debug () | |
| 2434 | (format t "~%citp from equation: generated") | |
| 2435 | (print-next) | |
| 2436 | (when t-goal | |
| 2437 | (pr-goal t-goal)) | |
| 2438 | (when f-goal | |
| 2439 | (pr-goal f-goal))) | |
| 2440 | (if (and t-goal f-goal) | |
| 2441 | (values t (list t-goal f-goal)) | |
| 2442 | (if t-goal | |
| 2443 | (values t (list t-goal)) | |
| 2444 | (if f-goal | |
| 2445 | (values t (list f-goal)) | |
| 2446 | (values nil nil)))))))) | |
| 2447 | ||
| 2448 | (defun parse-axiom-or-term (form term?) | |
| 2449 | (if term? | |
| 2450 | (let ((*parse-variables* nil)) | |
| 2451 | (let ((res (simple-parse *current-module* form *cosmos*))) | |
| 2452 | res)) | |
| 2453 | (parse-axiom-declaration (parse-module-element-1 form)))) | |
| 2454 | ||
| 2455 | (defun do-apply-ctf (cur-node term-or-equation &optional (tactic .tactic-ctf.)) | |
| 2456 | (with-citp-env () | |
| 2457 | (let ((cur-goal (ptree-node-goal cur-node))) | |
| 2458 | (when (already-proved? cur-goal) | |
| 2459 | (return-from do-apply-ctf nil)) | |
| 2460 | (if (termp term-or-equation) | |
| 2461 | (do-apply-ctf-with-constructors cur-node term-or-equation tactic) | |
| 2462 | (do-apply-ctf-to-equation cur-node term-or-equation tactic))))) | |
| 2463 | ||
| 2464 | ;;; :ctf(-) toplevel function | |
| 2465 | ;;; | |
| 2466 | (defun apply-ctf (s-form term? dash? &optional (verbose *citp-verbose*)) | |
| 2188 | 2467 | (let ((ptree-node (get-next-proof-context *proof-tree*))) |
| 2189 | (multiple-value-bind (applied next-goals) | |
| 2190 | (do-apply-ctf ptree-node equation) | |
| 2191 | (declare (ignore applied)) | |
| 2192 | (unless next-goals | |
| 2193 | (return-from apply-ctf nil)) | |
| 2194 | (format t "~%** Generated ~d goal~p" (length next-goals) (length next-goals)) | |
| 2195 | ;; apply implicit rd | |
| 2196 | (dolist (ngoal next-goals) | |
| 2197 | (do-apply-rd ngoal 'ctf)) | |
| 2198 | ;; add generated nodes as children | |
| 2199 | (add-ptree-children ptree-node next-goals) | |
| 2200 | (when verbose | |
| 2201 | (dolist (gn (ptree-node-subnodes ptree-node)) | |
| 2202 | (pr-goal (ptree-node-goal gn)))) | |
| 2203 | (ptree-node-subnodes ptree-node)))) | |
| 2468 | (with-in-module ((goal-context (ptree-node-goal ptree-node))) | |
| 2469 | (with-citp-env () | |
| 2470 | (let ((form (parse-axiom-or-term s-form term?))) | |
| 2471 | (multiple-value-bind (applied next-goals) | |
| 2472 | (do-apply-ctf ptree-node form) | |
| 2473 | (declare (ignore applied)) | |
| 2474 | (unless next-goals | |
| 2475 | (return-from apply-ctf nil)) | |
| 2476 | (format t "~%** Generated ~d goal~p" (length next-goals) (length next-goals)) | |
| 2477 | (when *citp-spoiler* | |
| 2478 | ;; apply implicit rd | |
| 2479 | (dolist (ngoal next-goals) | |
| 2480 | (do-apply-rd ngoal nil .tactic-ctf.) | |
| 2481 | (when (and dash? (goal-targets ngoal)) | |
| 2482 | ;; reset target | |
| 2483 | (setf (goal-targets ngoal) | |
| 2484 | (goal-targets (ptree-node-goal ptree-node)))))) | |
| 2485 | ;; add generated nodes as children | |
| 2486 | (add-ptree-children ptree-node next-goals) | |
| 2487 | (when verbose | |
| 2488 | (dolist (gn (ptree-node-subnodes ptree-node)) | |
| 2489 | (pr-goal (ptree-node-goal gn)))) | |
| 2490 | (ptree-node-subnodes ptree-node))))))) | |
| 2204 | 2491 | |
| 2205 | ;;; ----------------------------------------------------- | |
| 2206 | ;;; :csp | |
| 2207 | (defun do-apply-csp (cur-node axs) | |
| 2208 | (let ((*chaos-quiet* t) | |
| 2209 | (*rwl-search-no-state-report* t) | |
| 2210 | (cur-goal (ptree-node-goal cur-node))) | |
| 2211 | (when (goal-is-discharged cur-goal) | |
| 2212 | (with-output-chaos-warning () | |
| 2213 | (format t "** The goal ~s has been proved!." (goal-name (ptree-node-goal cur-node))) | |
| 2214 | (return-from do-apply-csp nil))) | |
| 2215 | (let ((ngoals nil)) | |
| 2216 | (dolist (ax axs) | |
| 2217 | (let ((n-goal (prepare-next-goal cur-node .tactic-csp.))) | |
| 2218 | ;; add a given assumption | |
| 2219 | (with-in-module ((goal-context n-goal)) | |
| 2220 | (adjoin-axiom-to-module *current-module* ax) | |
| 2221 | (set-operator-rewrite-rule *current-module* ax) | |
| 2222 | (compile-module *current-module*)) | |
| 2223 | (setf (goal-targets n-goal) (goal-targets cur-goal)) | |
| 2224 | (setf (goal-assumptions n-goal) (append (goal-assumptions cur-goal) (list ax))) | |
| 2225 | (push n-goal ngoals))) | |
| 2492 | ;;;===================== | |
| 2493 | ;;; :defined :ctf, :ctf- | |
| 2494 | ;;;===================== | |
| 2495 | (defun apply-ctf-tactic (ptree-node tactic) | |
| 2496 | (declare (type ptree-node ptree-node) | |
| 2497 | (type tactic-ctf tactic)) | |
| 2498 | (let ((goal (ptree-node-goal ptree-node))) | |
| 2499 | (with-in-module ((goal-context goal)) | |
| 2500 | (multiple-value-bind (applied next-goals) | |
| 2501 | (do-apply-ctf ptree-node (tactic-ctf-form tactic) tactic) | |
| 2502 | (declare (ignore applied)) | |
| 2503 | (unless next-goals | |
| 2504 | (return-from apply-ctf-tactic nil)) | |
| 2505 | (when *citp-spoiler* | |
| 2506 | ;; apply implicit rd | |
| 2507 | (dolist (ngoal next-goals) | |
| 2508 | (do-apply-rd ngoal nil tactic) | |
| 2509 | (when (and (tactic-ctf-minus tactic) (goal-targets ngoal)) | |
| 2510 | ;; reset target | |
| 2511 | (setf (goal-targets ngoal) (goal-targets goal))))) | |
| 2512 | (values t next-goals))))) | |
| 2513 | ||
| 2514 | ;;;============== | |
| 2515 | ;;; :csp or :csp- | |
| 2516 | ;;;============== | |
| 2517 | (defun do-apply-csp (cur-node axs &optional (tactic .tactic-csp.)) | |
| 2518 | (unless (already-proved? cur-node) | |
| 2519 | (let ((cur-goal (ptree-node-goal cur-node)) | |
| 2520 | (ngoals nil)) | |
| 2521 | ;; add given assumptions with generating child nodes | |
| 2522 | (dolist (ax (mapcar #'(lambda (x) | |
| 2523 | (rule-copy-canonicalized x (goal-context cur-goal) (tactic-name tactic))) | |
| 2524 | axs)) | |
| 2525 | (let ((n-goal (prepare-next-goal cur-node tactic))) | |
| 2526 | (with-in-module ((goal-context n-goal)) | |
| 2527 | (adjoin-axiom-to-module *current-module* ax) | |
| 2528 | (set-operator-rewrite-rule *current-module* ax) | |
| 2529 | (compile-module *current-module*)) | |
| 2530 | (setf (goal-targets n-goal) (goal-targets cur-goal)) | |
| 2531 | (setf (goal-assumptions n-goal) (append (goal-assumptions cur-goal) (list ax))) | |
| 2532 | (push n-goal ngoals))) | |
| 2533 | (with-citp-debug () | |
| 2534 | (format t "~%~a generated:" (tactic-name tactic)) | |
| 2535 | (dolist (g (reverse ngoals)) | |
| 2536 | (print-next) | |
| 2537 | (pr-goal g))) | |
| 2226 | 2538 | (values t (nreverse ngoals))))) |
| 2227 | 2539 | |
| 2228 | (defun apply-csp (axs &optional (verbose *citp-verbose*)) | |
| 2229 | (check-ptree) | |
| 2540 | (defun apply-csp (ax-forms dash? &optional (verbose *citp-verbose*)) | |
| 2230 | 2541 | (let ((ptree-node (get-next-proof-context *proof-tree*))) |
| 2231 | (multiple-value-bind (applied next-goals) | |
| 2232 | (do-apply-csp ptree-node axs) | |
| 2233 | (declare (ignore applied)) | |
| 2234 | (unless next-goals | |
| 2235 | (return-from apply-csp nil)) | |
| 2236 | (format t "~%** Generated ~d goal~p" (length next-goals) (length next-goals)) | |
| 2237 | ;; apply implicit rd | |
| 2238 | (dolist (ngoal next-goals) | |
| 2239 | (do-apply-rd ngoal 'csp)) | |
| 2240 | (add-ptree-children ptree-node next-goals) | |
| 2241 | (when verbose | |
| 2242 | (dolist (gn (ptree-node-subnodes ptree-node)) | |
| 2243 | (pr-goal (ptree-node-goal gn)))) | |
| 2244 | (ptree-node-subnodes ptree-node)))) | |
| 2245 | ||
| 2246 | ;;; ***************************************************** | |
| 2542 | (with-in-module ((goal-context (ptree-node-goal ptree-node))) | |
| 2543 | (with-citp-env () | |
| 2544 | (let ((axs nil)) | |
| 2545 | (dolist (ax ax-forms) | |
| 2546 | (push (parse-axiom-declaration (parse-module-element-1 ax)) axs)) | |
| 2547 | (multiple-value-bind (applied next-goals) | |
| 2548 | (do-apply-csp ptree-node (nreverse axs)) | |
| 2549 | (declare (ignore applied)) | |
| 2550 | (unless next-goals | |
| 2551 | (return-from apply-csp nil)) | |
| 2552 | (format t "~%** Generated ~d goal~p" (length next-goals) (length next-goals)) | |
| 2553 | (when-spoiler-on () | |
| 2554 | ;; apply implicit rd | |
| 2555 | (dolist (ngoal next-goals) | |
| 2556 | (do-apply-rd ngoal nil .tactic-csp.) | |
| 2557 | (when (and dash? (goal-targets ngoal)) | |
| 2558 | ;; reset target | |
| 2559 | (setf (goal-targets ngoal) | |
| 2560 | (goal-targets (ptree-node-goal ptree-node)))))) | |
| 2561 | ;; add generated node as children | |
| 2562 | (add-ptree-children ptree-node next-goals) | |
| 2563 | (when verbose | |
| 2564 | (dolist (gn (ptree-node-subnodes ptree-node)) | |
| 2565 | (pr-goal (ptree-node-goal gn)))) | |
| 2566 | (ptree-node-subnodes ptree-node))))))) | |
| 2567 | ||
| 2568 | ;;;===================== | |
| 2569 | ;;; :defined :csp, :csp- | |
| 2570 | ;;;===================== | |
| 2571 | (defun apply-csp-tactic (ptree-node tactic) | |
| 2572 | (declare (type ptree-node ptree-node) | |
| 2573 | (type tactic-csp tactic)) | |
| 2574 | (let ((goal (ptree-node-goal ptree-node))) | |
| 2575 | (with-in-module ((goal-context goal)) | |
| 2576 | (with-citp-env () | |
| 2577 | (multiple-value-bind (applied next-goals) | |
| 2578 | (do-apply-csp ptree-node (tactic-csp-forms tactic) tactic) | |
| 2579 | (declare (ignore applied)) | |
| 2580 | (unless next-goals | |
| 2581 | (return-from apply-csp-tactic nil)) | |
| 2582 | (when-spoiler-on () | |
| 2583 | ;; apply implicit rd | |
| 2584 | (dolist (ngoal next-goals) | |
| 2585 | (do-apply-rd ngoal nil tactic) | |
| 2586 | (when (and (tactic-csp-minus tactic) (goal-targets ngoal)) | |
| 2587 | ;; reset target | |
| 2588 | (setf (goal-targets ngoal) (goal-targets goal))))) | |
| 2589 | (values t next-goals)))))) | |
| 2590 | ||
| 2591 | ||
| 2592 | ;;; ----------------------------------------------------------- | |
| 2593 | ;;; report-citp-stat | |
| 2594 | ;;; | |
| 2595 | (defun report-citp-stat () | |
| 2596 | (when *show-stats* | |
| 2597 | (format t "~%~a" (generate-statistics-form-rewriting-only)))) | |
| 2598 | ||
| 2599 | ;;; ****** | |
| 2600 | ;;; :apply | |
| 2601 | ;;; ****** | |
| 2602 | ||
| 2247 | 2603 | ;;; APPLY-TACTIC |
| 2248 | 2604 | ;;; apply-tactic : ptree-node tactic -> List(ptree-node) |
| 2249 | 2605 | ;;; returns the list of generated goal nodes. |
| 2250 | ;;; ----------------------------------------------------- | |
| 2251 | ||
| 2606 | ;;; | |
| 2252 | 2607 | (defun apply-tactic (ptree-node tactic &optional (verbose nil)) |
| 2253 | 2608 | (declare (type ptree-node ptree-node) |
| 2254 | (type tactic tactic)) | |
| 2255 | (let ((*chaos-quiet* t) | |
| 2256 | (*rwl-search-no-state-report* t)) | |
| 2609 | (type tactic tactic)) | |
| 2610 | (with-citp-env () | |
| 2257 | 2611 | (when (goal-is-discharged (ptree-node-goal ptree-node)) |
| 2258 | 2612 | (with-output-chaos-warning () |
| 2259 | (format t "** The goal ~s has been proved!." (goal-name (ptree-node-goal ptree-node))) | |
| 2260 | (return-from apply-tactic nil))) | |
| 2261 | ;; | |
| 2262 | (format t "~%~a=> :goal{~a}" tactic (goal-name (ptree-node-goal ptree-node))) | |
| 2613 | (format t "** The goal ~s has already been proved!." (goal-name (ptree-node-goal ptree-node))) | |
| 2614 | (return-from apply-tactic nil))) | |
| 2615 | (format t "~%[~a]=> :goal{~a}" (tactic-name tactic) (goal-name (ptree-node-goal ptree-node))) | |
| 2263 | 2616 | (initialize-ptree-node ptree-node) |
| 2264 | 2617 | (compile-module (goal-context (ptree-node-goal ptree-node)) t) |
| 2618 | (with-citp-debug () | |
| 2619 | (let ((exe (tactic-executor tactic))) | |
| 2620 | (format t "~%Funcalling ~a" exe))) | |
| 2265 | 2621 | (multiple-value-bind (applied next-goals) |
| 2266 | (funcall (tactic-executor tactic) ptree-node) | |
| 2622 | (funcall (tactic-executor tactic) ptree-node tactic) | |
| 2267 | 2623 | (declare (type (or null t) applied) |
| 2268 | (type list next-goals)) | |
| 2624 | (type list next-goals)) | |
| 2269 | 2625 | (unless applied (return-from apply-tactic nil)) |
| 2270 | 2626 | (unless next-goals |
| 2271 | ;; reset the current ptree-node status, | |
| 2272 | ;; i.e., cancel side effects | |
| 2273 | (initialize-ptree-node ptree-node) | |
| 2274 | (return-from apply-tactic nil)) | |
| 2627 | ;; reset the current ptree-node status, | |
| 2628 | ;; i.e., cancel side effects | |
| 2629 | (initialize-ptree-node ptree-node) | |
| 2630 | (return-from apply-tactic nil)) | |
| 2275 | 2631 | (format t "~%** Generated ~d goal~p" (length next-goals) (length next-goals)) |
| 2276 | 2632 | (add-ptree-children ptree-node next-goals) |
| 2277 | 2633 | (when verbose |
| 2278 | (dolist (gn (ptree-node-subnodes ptree-node)) | |
| 2279 | (pr-goal (ptree-node-goal gn)))) | |
| 2634 | (dolist (gn (ptree-node-subnodes ptree-node)) | |
| 2635 | (pr-goal (ptree-node-goal gn)))) | |
| 2280 | 2636 | (ptree-node-subnodes ptree-node)))) |
| 2281 | 2637 | |
| 2282 | ;;; | |
| 2283 | 2638 | ;;; apply-tactics-to-node |
| 2284 | 2639 | ;;; |
| 2285 | 2640 | (defun apply-tactics-to-node (target-node tactics &optional (verbose *citp-verbose*)) |
| 2641 | (declare (type ptree-node target-node)) | |
| 2286 | 2642 | (unless tactics (return-from apply-tactics-to-node nil)) |
| 2287 | 2643 | (let ((subs (apply-tactic target-node (car tactics) verbose))) |
| 2288 | 2644 | (if subs |
| 2289 | (dolist (target subs) | |
| 2290 | (apply-tactics-to-node target (cdr tactics) verbose)) | |
| 2645 | (dolist (target subs) | |
| 2646 | (apply-tactics-to-node target (cdr tactics) verbose)) | |
| 2291 | 2647 | (apply-tactics-to-node target-node (cdr tactics) verbose)))) |
| 2292 | 2648 | |
| 2293 | ;;; | |
| 2649 | ;;; apply-tactic-seq | |
| 2650 | ;;; user defined sequence of tactic | |
| 2651 | ;;; | |
| 2652 | (defun apply-tactic-seq (ptree-node tactic &optional (verbose *citp-verbose*)) | |
| 2653 | (declare (type ptree-node ptree-node) | |
| 2654 | (type tactic-seq tactic)) | |
| 2655 | (apply-tactics-to-node ptree-node (tactic-seq-tactics tactic) verbose)) | |
| 2656 | ||
| 2294 | 2657 | ;;; apply-tactics |
| 2295 | 2658 | ;;; |
| 2659 | (defun flatten-tactic-seq (tactics) | |
| 2660 | (let ((res nil)) | |
| 2661 | (dolist (tactic tactics) | |
| 2662 | (if (tactic-seq-p tactic) | |
| 2663 | (setq res (nconc res (flatten-tactic-seq (tactic-seq-tactics tactic)))) | |
| 2664 | (setq res (nconc res (list tactic))))) | |
| 2665 | res)) | |
| 2666 | ||
| 2296 | 2667 | (defun apply-tactics (ptree tactics &optional (verbose *citp-verbose*)) |
| 2297 | 2668 | (declare (type ptree ptree) |
| 2298 | (type list tactics)) | |
| 2669 | (type list tactics)) | |
| 2299 | 2670 | (let ((target (get-next-proof-context ptree))) |
| 2300 | 2671 | (unless target |
| 2301 | 2672 | (format t "~%**> All goals have been proved!") |
| 2302 | 2673 | (return-from apply-tactics nil)) |
| 2303 | (apply-tactics-to-node target tactics verbose)) | |
| 2304 | (check-success ptree)) | |
| 2305 | ||
| 2306 | ;;; | |
| 2674 | (reset-rewrite-counters) | |
| 2675 | (begin-rewrite) | |
| 2676 | (apply-tactics-to-node target (flatten-tactic-seq tactics) verbose) | |
| 2677 | (end-rewrite) | |
| 2678 | (report-citp-stat) | |
| 2679 | (check-success ptree))) | |
| 2680 | ||
| 2307 | 2681 | ;;; apply-auto |
| 2308 | 2682 | ;;; |
| 2309 | 2683 | (defun apply-auto (ptree &optional (tactics .default-tactics.) (verbose *citp-verbose*)) |
| 2310 | (if (next-proof-target-is-specified?) | |
| 2311 | (apply-tactics-to-node (get-next-proof-context ptree) tactics verbose) | |
| 2312 | (let ((target-nodes (get-unproved-nodes ptree))) | |
| 2313 | (unless target-nodes | |
| 2314 | (format t "~%**> All goals have been proved!") | |
| 2315 | (return-from apply-auto nil)) | |
| 2316 | (dolist (tactic tactics) | |
| 2317 | (dolist (target-node (get-unproved-nodes ptree)) | |
| 2318 | (apply-tactic target-node tactic verbose))))) | |
| 2319 | (check-success ptree)) | |
| 2320 | ||
| 2321 | ;;; | |
| 2684 | (with-citp-env () | |
| 2685 | (with-spoiler-on () | |
| 2686 | (reset-rewrite-counters) | |
| 2687 | (begin-rewrite) | |
| 2688 | (if (next-proof-target-is-specified?) | |
| 2689 | (apply-tactics-to-node (get-next-proof-context ptree) tactics verbose) | |
| 2690 | (let ((target-nodes (get-unproved-nodes ptree))) | |
| 2691 | (unless target-nodes | |
| 2692 | (format t "~%**> All goals have been proved!") | |
| 2693 | (return-from apply-auto nil)) | |
| 2694 | (dolist (tactic tactics) | |
| 2695 | (dolist (target-node (get-unproved-nodes ptree)) | |
| 2696 | (apply-tactic target-node tactic verbose))))) | |
| 2697 | (end-rewrite) | |
| 2698 | (report-citp-stat) | |
| 2699 | (check-success ptree)))) | |
| 2700 | ||
| 2322 | 2701 | ;;; apply-tactics-to-goal |
| 2323 | 2702 | ;;; |
| 2324 | 2703 | (defun apply-tactics-to-goal (ptree name tactics &optional (verbose *citp-verbose*)) |
| 2325 | 2704 | (let ((target-node (find-goal-node ptree name))) |
| 2326 | 2705 | (unless target-node |
| 2327 | 2706 | (with-output-chaos-error ('no-named-goal) |
| 2328 | (format t "There is no goal with name ~s." name))) | |
| 2707 | (format t "There is no goal with name ~s." name))) | |
| 2708 | (reset-rewrite-counters) | |
| 2709 | (begin-rewrite) | |
| 2329 | 2710 | (apply-tactics-to-node target-node tactics verbose) |
| 2711 | (end-rewrite) | |
| 2712 | (report-citp-stat) | |
| 2330 | 2713 | (check-success ptree))) |
| 2331 | 2714 | |
| 2332 | 2715 | ;;; EOF |
| 0 | 0 | ;;;-*- Mode:LISP; Package:CHAOS; Base:10; Syntax:Common-lisp -*- |
| 1 | 1 | ;;; |
| 2 | ;;; Copyright (c) 2000-2014, Toshimi Sawada. All rights reserved. | |
| 2 | ;;; Copyright (c) 2000-2015, Toshimi Sawada. All rights reserved. | |
| 3 | 3 | ;;; |
| 4 | 4 | ;;; Redistribution and use in source and binary forms, with or without |
| 5 | 5 | ;;; modification, are permitted provided that the following conditions |
| 27 | 27 | ;;; |
| 28 | 28 | (in-package :chaos) |
| 29 | 29 | #|============================================================================== |
| 30 | System: CHAOS | |
| 31 | Module: thstuff | |
| 32 | File: basics.lisp | |
| 30 | System: CHAOS | |
| 31 | Module: thstuff | |
| 32 | File: basics.lisp | |
| 33 | 33 | ==============================================================================|# |
| 34 | 34 | #-:chaos-debug |
| 35 | 35 | (declaim (optimize (speed 3) (safety 0) #-GCL (debug 0))) |
| 57 | 57 | |
| 58 | 58 | (defun command-display () |
| 59 | 59 | (if $$action-stack |
| 60 | (format t "~&-- condition(~s) " (length $$action-stack)) | |
| 60 | (format t "~%-- condition(~s) " (length $$action-stack)) | |
| 61 | 61 | (format t "~&result ")) |
| 62 | 62 | (disp-term $$term)) |
| 63 | 63 | |
| 69 | 69 | (if (term-is-similar? $$term *bool-true*) |
| 70 | 70 | (progn |
| 71 | 71 | (command-display) |
| 72 | (format t "~&-- condition is satisfied, applying rule") | |
| 72 | (format t "~%-- condition is satisfied, applying rule") | |
| 73 | 73 | (format t "~&-- shifiting focus back to previous context") |
| 74 | 74 | (let ((cur (car $$action-stack))) |
| 75 | 75 | (setq $$term (car cur)) |
| 79 | 79 | (if (term-is-similar? $$term *bool-false*) |
| 80 | 80 | (progn |
| 81 | 81 | (command-display) |
| 82 | (format t "~&-- condition is not satisfied, rule not applied") | |
| 82 | (format t "~%-- condition is not satisfied, rule not applied") | |
| 83 | 83 | (format t "~&-- shifting focus back to previous context") |
| 84 | 84 | (setq $$term (caar $$action-stack)) |
| 85 | 85 | (setq $$action-stack (cdr $$action-stack)) |
| 87 | 87 | nil)))) |
| 88 | 88 | |
| 89 | 89 | (defun disp-term (x) |
| 90 | (with-in-module (*last-module*) | |
| 90 | (with-in-module ((get-context-module)) | |
| 91 | 91 | (term-print x) |
| 92 | 92 | (princ " : ") |
| 93 | 93 | (print-sort-name (term-sort x) *current-module*))) |
| 101 | 101 | ;;; apply-help |
| 102 | 102 | ;;; |
| 103 | 103 | (defun apply-help () |
| 104 | (format t "~&Apply a selected rule, possibly with an instantiation,") | |
| 104 | (format t "~%Apply a selected rule, possibly with an instantiation,") | |
| 105 | 105 | (format t " to selected subterm(s).") |
| 106 | 106 | (format t "~&Syntax:") |
| 107 | 107 | (format t "~& apply { reduction | red | print | bred | exec | <RuleSpec> [ <VarSubst> ] }") |
| 477 | 477 | ;;; |
| 478 | 478 | ;;; FOR := |
| 479 | 479 | ;;; |
| 480 | (declaim (special *m-pattern-subst*)) | |
| 481 | ||
| 480 | 482 | (defun match-m-pattern (pat term) |
| 481 | 483 | (multiple-value-bind (res subst) |
| 482 | 484 | (@pat-match pat term) |
| 483 | 485 | (when res |
| 484 | 486 | (dolist (sub subst) |
| 485 | (push sub *m-pattern-subst*)) | |
| 487 | (push sub *m-pattern-subst*)) | |
| 486 | 488 | (return-from match-m-pattern t)) |
| 487 | 489 | nil)) |
| 488 | 490 | |
| 513 | 515 | trmtoks |
| 514 | 516 | avar |
| 515 | 517 | aterm) |
| 516 | ;; (!setup-parse *last-module*) | |
| 517 | (with-in-module (*last-module*) | |
| 518 | (with-in-module ((get-context-module)) | |
| 518 | 519 | (loop (when (null substtoks) (return)) |
| 519 | 520 | ;; <varid> = <term> |
| 520 | 521 | (setq varnm (cadr substtoks)) |
| 0 | ;;;-*-Mode:LISP; Package: CHAOS; Base:10; Syntax:Common-lisp -*- | |
| 1 | ;;; | |
| 2 | ;;; Copyright (c) 2000-2015, Toshimi Sawada. All rights reserved. | |
| 3 | ;;; | |
| 4 | ;;; Redistribution and use in source and binary forms, with or without | |
| 5 | ;;; modification, are permitted provided that the following conditions | |
| 6 | ;;; are met: | |
| 7 | ;;; | |
| 8 | ;;; * Redistributions of source code must retain the above copyright | |
| 9 | ;;; notice, this list of conditions and the following disclaimer. | |
| 10 | ;;; | |
| 11 | ;;; * Redistributions in binary form must reproduce the above | |
| 12 | ;;; copyright notice, this list of conditions and the following | |
| 13 | ;;; disclaimer in the documentation and/or other materials | |
| 14 | ;;; provided with the distribution. | |
| 15 | ;;; | |
| 16 | ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED | |
| 17 | ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED | |
| 18 | ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE | |
| 19 | ;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY | |
| 20 | ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL | |
| 21 | ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE | |
| 22 | ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS | |
| 23 | ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, | |
| 24 | ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING | |
| 25 | ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS | |
| 26 | ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. | |
| 27 | ;;; | |
| 28 | (in-package :chaos) | |
| 29 | #|============================================================================= | |
| 30 | System:CHAOS | |
| 31 | Module:thstuff | |
| 32 | File:bool-term.lisp | |
| 33 | =============================================================================|# | |
| 34 | #-:chaos-debug | |
| 35 | (declaim (optimize (speed 3) (safety 0) #-GCL (debug 0))) | |
| 36 | #+:chaos-debug | |
| 37 | (declaim (optimize (speed 1) (safety 3) #-GCL (debug 3))) | |
| 38 | ||
| 39 | (defvar *debug-bterm* nil) | |
| 40 | ;;;============================================================================= | |
| 41 | ;;; Utilities to support investigating big boolean term of xor-and normal form. | |
| 42 | ;;;============================================================================= | |
| 43 | ||
| 44 | (defvar .bterm-assoc-table. nil) | |
| 45 | (defvar .bvar-num. 0) | |
| 46 | (declaim (type fixnum .bvar-num.)) | |
| 47 | ||
| 48 | (defun clear-bterm-memo-table () | |
| 49 | (setq .bterm-assoc-table. nil)) | |
| 50 | ||
| 51 | (defun reset-bvar () | |
| 52 | (setq .bvar-num. 0) | |
| 53 | (clear-bterm-memo-table)) | |
| 54 | ||
| 55 | (defun make-bterm-variable () | |
| 56 | (let ((varname (intern (format nil "P-~d" (incf .bvar-num.))))) | |
| 57 | (make-variable-term *bool-sort* varname))) | |
| 58 | ||
| 59 | (defun get-bterm-variable (term) | |
| 60 | (let ((ent (assoc term .bterm-assoc-table. :test #'term-equational-equal))) | |
| 61 | (if ent | |
| 62 | (cdr ent) | |
| 63 | (let ((var (make-bterm-variable))) | |
| 64 | (push (cons term var) .bterm-assoc-table.) | |
| 65 | var)))) | |
| 66 | ||
| 67 | ;;; ======================================================================= | |
| 68 | ;;; Abstracted representation of a _xor_-_and_ normal form of boolean term. | |
| 69 | ||
| 70 | ;;; ABS-BTERM: | |
| 71 | ;;; abstracted boolean term. | |
| 72 | ;;; each non _and_ or _xor_ boolean sub-term is abstracted by a | |
| 73 | ;;; variable. | |
| 74 | (defstruct (abst-bterm) | |
| 75 | (module nil) ; context module | |
| 76 | (term nil) ; the original term | |
| 77 | (subst nil) ; list of substitution | |
| 78 | ; or instance of abst-bterm(for _and_ abstraction) | |
| 79 | ) | |
| 80 | ||
| 81 | (defstruct (abst-and (:include abst-bterm))) | |
| 82 | ||
| 83 | (defun print-abst-bterm (bt &optional (stream *standard-output*) &rest ignore) | |
| 84 | (declare (ignore ignore)) | |
| 85 | (with-in-module ((abst-bterm-module bt)) | |
| 86 | (if (abst-and-p bt) | |
| 87 | (princ ":and[" stream) | |
| 88 | (princ ":xor[" stream)) | |
| 89 | (let ((*print-indent* (+ 2 *print-indent*)) | |
| 90 | (num 0)) | |
| 91 | (declare (type fixnum *print-indent* num)) | |
| 92 | (dolist (sub (abst-bterm-subst bt)) | |
| 93 | (print-next nil *print-indent* stream) | |
| 94 | (format stream "(~d) " (incf num)) | |
| 95 | (if (abst-bterm-p sub) | |
| 96 | (print-abst-bterm sub stream) | |
| 97 | (progn | |
| 98 | (let ((var (car sub)) | |
| 99 | (term (cdr sub))) | |
| 100 | (term-print var) | |
| 101 | (princ " |-> ") | |
| 102 | (term-print term)))))) | |
| 103 | (princ " ]" stream))) | |
| 104 | ||
| 105 | ;;;=========================================================================== | |
| 106 | ;;; make abst-bterm from a term of sort 'Bool' | |
| 107 | ||
| 108 | ;;; xtract-xor-subterms : term | |
| 109 | ;;; returns ac subterms of the given term iff the top op is _xor_ | |
| 110 | ;;; | |
| 111 | (defun xtract-xor-subterms (term) | |
| 112 | (if (method= (term-head term) *bool-xor*) | |
| 113 | (list-ac-subterms term *bool-xor*) | |
| 114 | nil)) | |
| 115 | ||
| 116 | ;;; xtract-and-subterms : term | |
| 117 | ;;; returns ac subterms of the given term iff the top op is _and_ | |
| 118 | ;;; | |
| 119 | (defun xtract-and-subterms (term) | |
| 120 | (if (method= (term-head term) *bool-and*) | |
| 121 | (list-ac-subterms term *bool-and*) | |
| 122 | nil)) | |
| 123 | ||
| 124 | ;;; abstract-boolen-term : bool-term -> abst-bterm | |
| 125 | ;;; | |
| 126 | (defun make-and-abstraction (term subterms module) | |
| 127 | (let ((subst nil)) | |
| 128 | (dolist (sub subterms) | |
| 129 | (push (cons (get-bterm-variable sub) sub) subst)) | |
| 130 | (make-abst-and :term term :subst (nreverse subst) :module module))) | |
| 131 | ||
| 132 | ;;; assign-tf | |
| 133 | ;;; make all posssible variable substitutions with the domain {'true' ,'false'}. | |
| 134 | ;;; | |
| 135 | (defun make-tf-combination (rows columns) | |
| 136 | (let ((assignment nil) | |
| 137 | (subst (make-array (list rows columns)))) | |
| 138 | (flet ((change-parity () | |
| 139 | (if (is-true? assignment) | |
| 140 | (setq assignment *bool-false*) | |
| 141 | (setq assignment *bool-true*)))) | |
| 142 | (dotimes (c columns) | |
| 143 | (setq assignment nil) | |
| 144 | (let ((cycle (expt 2 c))) | |
| 145 | (dotimes (r rows) | |
| 146 | (if (not assignment) | |
| 147 | (setq assignment *bool-true*) | |
| 148 | (if (= 0 (mod r cycle)) | |
| 149 | (change-parity))) | |
| 150 | (setf (aref subst r c) assignment)))) | |
| 151 | subst))) | |
| 152 | ||
| 153 | (defun assign-tf (list-vars) | |
| 154 | (let* ((columns (length list-vars)) | |
| 155 | (rows (expt 2 columns)) | |
| 156 | (assignments (make-tf-combination rows columns)) | |
| 157 | (l-subst nil)) | |
| 158 | (dotimes (r rows) | |
| 159 | (let ((subst nil)) | |
| 160 | (dotimes (c columns) | |
| 161 | (push (cons (nth c list-vars) (aref assignments r c)) subst)) | |
| 162 | (push (nreverse subst) l-subst))) | |
| 163 | (when *debug-bterm* | |
| 164 | (with-in-module ((get-context-module)) | |
| 165 | (let ((num 0)) | |
| 166 | (dolist (sub (reverse l-subst)) | |
| 167 | (format t "~%(~d): " (incf num)) | |
| 168 | (print-substitution sub))))) | |
| 169 | (nreverse l-subst))) | |
| 170 | ||
| 171 | ;;; make-abst-boolean-term : term -> Values (abst-bterm List(substitution)) | |
| 172 | ;;; | |
| 173 | (defvar *abst-bterm* nil) | |
| 174 | (defvar *abst-bterm-representation* nil) | |
| 175 | ||
| 176 | (defun make-abst-boolean-term (term module) | |
| 177 | (unless (sort= (term-sort term) *bool-sort*) | |
| 178 | (with-output-chaos-warning () | |
| 179 | (format t "Given term is not of sort Bool. Ignored.") | |
| 180 | (return-from make-abst-boolean-term nil))) | |
| 181 | (!setup-reduction module) | |
| 182 | (with-in-module (module) | |
| 183 | (reset-reduced-flag term) | |
| 184 | (when *citp-verbose* | |
| 185 | (format t "~%-- computing normal form.")) | |
| 186 | (let* ((*always-memo* t) | |
| 187 | (target (reducer-no-stat term module :red))) | |
| 188 | (format t "~%--> ") | |
| 189 | (term-print term) | |
| 190 | ;; abstract | |
| 191 | (when *citp-verbose* | |
| 192 | (format t "~%-- starting abstraction")) | |
| 193 | (let ((bterm (abstract-boolean-term target module))) | |
| 194 | (setq *abst-bterm* bterm) | |
| 195 | (setq *abst-bterm-representation* | |
| 196 | (make-bterm-representation bterm)) | |
| 197 | (let ((*print-indent* (+ 2 *print-indent*))) | |
| 198 | (format t "~%** Abstracted boolean term:") | |
| 199 | (with-in-module (module) | |
| 200 | (print-next) | |
| 201 | (term-print *abst-bterm-representation*) | |
| 202 | (when *citp-verbose* | |
| 203 | (print-term-horizontal *abst-bterm-representation* module)) | |
| 204 | (print-bterm-substitution bterm *abst-bterm-representation*))))))) | |
| 205 | ||
| 206 | ;;; find-bvar-subst : variable abst-bterm -> assigned term | |
| 207 | ;;; returns the assigned term of the variable. | |
| 208 | ;;; | |
| 209 | (defun find-bvar-subst (var bterm) | |
| 210 | (declare (type abst-bterm bterm)) | |
| 211 | (dolist (sub (abst-bterm-subst bterm)) | |
| 212 | (if (abst-bterm-p sub) | |
| 213 | (let ((subst (find-bvar-subst var sub))) | |
| 214 | (when subst (return-from find-bvar-subst subst))) | |
| 215 | (when (variable= var (car sub)) | |
| 216 | (return-from find-bvar-subst (cdr sub)))))) | |
| 217 | ||
| 218 | (defun print-bterm-substitution (bterm &optional | |
| 219 | (term-representation *abst-bterm-representation*)) | |
| 220 | (declare (type abst-bterm bterm)) | |
| 221 | (with-in-module ((abst-bterm-module bterm)) | |
| 222 | (print-next) | |
| 223 | (princ "where") | |
| 224 | (let ((*print-indent* (+ 2 *print-indent*))) | |
| 225 | (dolist (var (nreverse (term-variables term-representation))) | |
| 226 | (let ((mapping (find-bvar-subst var bterm))) | |
| 227 | (unless mapping | |
| 228 | (with-output-chaos-error ('internal-err) | |
| 229 | (format t "Could not find the mapping of variable ~a." (variable-name var)))) | |
| 230 | (print-next) | |
| 231 | (term-print var) | |
| 232 | (princ " |-> ") | |
| 233 | (term-print mapping))))) | |
| 234 | (terpri)) | |
| 235 | ||
| 236 | (defun abstract-boolean-term (term module) | |
| 237 | (let ((bterm (make-abst-bterm :term term :module module)) | |
| 238 | (xor-subs (xtract-xor-subterms term)) | |
| 239 | (subst nil)) | |
| 240 | ;; reset variable number & term hash | |
| 241 | (reset-bvar) | |
| 242 | (if xor-subs | |
| 243 | ;; top operator is _xor_ | |
| 244 | ;; we further decompose by _and_ | |
| 245 | (dolist (xs xor-subs) | |
| 246 | (let ((as (xtract-and-subterms xs))) | |
| 247 | (if as | |
| 248 | (push (make-and-abstraction xs as module) subst) | |
| 249 | (push (cons (get-bterm-variable xs) xs) subst)))) | |
| 250 | ;; top operator is not xor | |
| 251 | (let ((as (xtract-and-subterms term))) | |
| 252 | (if as | |
| 253 | (push (make-and-abstraction term as module) subst) | |
| 254 | ;; we anly accept xor-and formal form | |
| 255 | (with-output-chaos-error ('invalid-term) | |
| 256 | (format t "Given term is not xor-and normal form."))))) | |
| 257 | (setf (abst-bterm-subst bterm) (nreverse subst)) | |
| 258 | bterm)) | |
| 259 | ||
| 260 | ;;; make-bterm-representation : bterm -> boolen term | |
| 261 | ;;; from bterm make a concrete representation of abstracted boolean term | |
| 262 | ;;; | |
| 263 | (defun make-and-representation (abst-and) | |
| 264 | (declare (type abst-and abst-and)) | |
| 265 | (let ((repre (make-right-assoc-normal-form *bool-and* | |
| 266 | (mapcar #'car (abst-and-subst abst-and))))) | |
| 267 | (update-lowest-parse repre) | |
| 268 | repre)) | |
| 269 | ||
| 270 | (defun make-xor-representation (bterm) | |
| 271 | (declare (type abst-bterm bterm)) | |
| 272 | (let ((repre (make-right-assoc-normal-form *bool-xor* | |
| 273 | (mapcar #'(lambda (x) (if (abst-and-p x) | |
| 274 | (make-and-representation x) | |
| 275 | (car x))) | |
| 276 | (abst-bterm-subst bterm))))) | |
| 277 | (update-lowest-parse repre) | |
| 278 | repre)) | |
| 279 | ||
| 280 | (defun make-bterm-representation (bterm) | |
| 281 | (let ((subst (abst-bterm-subst bterm))) | |
| 282 | ;; no _xor nor _and_ ops in original term | |
| 283 | (unless subst | |
| 284 | (return-from make-bterm-representation (abst-bterm-term bterm))) | |
| 285 | ;; sole _and_ term. | |
| 286 | (when (and (null (cdr subst)) | |
| 287 | (abst-and-p (car subst))) | |
| 288 | (return-from make-bterm-representation (make-and-representation (car subst)))) | |
| 289 | ;; _xor_ normal form | |
| 290 | (make-xor-representation bterm))) | |
| 291 | ||
| 292 | ;;; =========================================================================================== | |
| 293 | ;;; PRINTERS | |
| 294 | ;;; abst-bterm printers | |
| 295 | ||
| 296 | ;;; simple-print-bterm : bterm -> void | |
| 297 | (defun simple-print-bterm (bterm) | |
| 298 | (declare (type abst-bterm bterm)) | |
| 299 | (let ((aterm (make-bterm-representation bterm))) | |
| 300 | (term-print-with-sort aterm))) | |
| 301 | ||
| 302 | ;;; print-bterm-tree : bterm -> void | |
| 303 | (defun print-bterm-tree (bterm &optional (mode :vertical)) | |
| 304 | (declare (type abst-bterm bterm)) | |
| 305 | (with-in-module ((abst-bterm-module bterm)) | |
| 306 | (let ((aterm (make-bterm-representation bterm))) | |
| 307 | (if (eq mode :vertical) | |
| 308 | (print-term-graph aterm *chaos-verbose*) | |
| 309 | (print-term-horizontal (make-bterm-representation bterm) *current-module*))))) | |
| 310 | ||
| 311 | ;;; print-abs-bterm : bterm &key mode | |
| 312 | ;;; mode :simple print term representation | |
| 313 | ;;; :tree print term representation as vertical tree structure | |
| 314 | ;;; :horizontal print term representation horizontal tree structure | |
| 315 | ;;; also shows a substitution used for abstruction. | |
| 316 | ;;; | |
| 317 | (defun print-abs-bterm (bterm &key (mode :simple)) | |
| 318 | (case mode | |
| 319 | (:simple (simple-print-bterm bterm)) | |
| 320 | (:tree (print-bterm-tree bterm)) | |
| 321 | (:horizontal (print-bterm-tree bterm :horizontal)) | |
| 322 | (otherwise | |
| 323 | (with-output-chaos-error ('invalid-mode) | |
| 324 | (format t "Invalid print mode ~a." mode))))) | |
| 325 | ||
| 326 | ||
| 327 | ;;; =========================================================================================== | |
| 328 | ;;; RESOLVER | |
| 329 | ;;; computes possible solutions (assignments) which makes abstracted boolean term to be 'true.' | |
| 330 | ;;; | |
| 331 | ||
| 332 | ;;; resolve-abst-bterm : bterm | |
| 333 | ;;; retuns a list of substitution which makes bterm to be true. | |
| 334 | ;;; | |
| 335 | (defun resolve-abst-bterm (bterm &optional (module (get-context-module))) | |
| 336 | (declare (type abst-bterm bterm)) | |
| 337 | (with-in-module (module) | |
| 338 | (let* ((abst-term (make-bterm-representation bterm)) | |
| 339 | (variables (term-variables abst-term)) | |
| 340 | (answers nil)) | |
| 341 | (dolist (subst (assign-tf variables)) | |
| 342 | (let ((target (substitution-image-cp subst abst-term))) | |
| 343 | (reset-reduced-flag target) | |
| 344 | (let ((*always-memo* t)) | |
| 345 | (setq target (reducer-no-stat target module :red))) | |
| 346 | (when (is-true? $$term) | |
| 347 | (push subst answers)))) | |
| 348 | (nreverse answers)))) | |
| 349 | ||
| 350 | ;;; try-resolve-bterm | |
| 351 | ;;; finds all variable assignments which makes *abst-bterm* 'true'. | |
| 352 | ;;; | |
| 353 | (defun try-resolve-bterm () | |
| 354 | (unless *abst-bterm* | |
| 355 | (with-output-chaos-error ('no-bterm) | |
| 356 | (format t "No abstracted boolean term is specified. ~%Please do :binspect or binspect first."))) | |
| 357 | (let ((bterm *abst-bterm*) | |
| 358 | (module (abst-bterm-module *abst-bterm*))) | |
| 359 | ;; find answers | |
| 360 | (let ((ans (resolve-abst-bterm bterm module))) | |
| 361 | (cond (ans | |
| 362 | (with-in-module (module) | |
| 363 | (format t "~%** The following assignment(s) can make the term 'true'.") | |
| 364 | (let ((num 0)) | |
| 365 | (declare (type fixnum num)) | |
| 366 | (let ((*print-indent* (+ 2 *print-indent*))) | |
| 367 | (dolist (sub ans) | |
| 368 | (print-next) | |
| 369 | (format t "(~d): " (incf num)) | |
| 370 | (print-substitution sub)))))) | |
| 371 | (t | |
| 372 | (format t "~%** No solution was found."))) | |
| 373 | (values bterm ans)))) | |
| 374 | ||
| 375 | ;;; binspect-in-goal : goal-name term-form | |
| 376 | ;;; abstract boolean term in the context of the goal given by goal-name. | |
| 377 | ;;; | |
| 378 | (defun binspect-in-goal (goal-name preterm) | |
| 379 | (let* ((goal-node (get-target-goal-node goal-name)) | |
| 380 | (context-module (goal-context (ptree-node-goal goal-node))) | |
| 381 | (target (do-parse-term* preterm context-module))) | |
| 382 | (make-abst-boolean-term target context-module))) | |
| 383 | ||
| 384 | ;;; binspect-in-module | |
| 385 | ;;; abstract boolean term in the context of a module | |
| 386 | ;;; | |
| 387 | (defun binspect-in-module (mod-name preterm) | |
| 388 | (multiple-value-bind (target context-module) | |
| 389 | (do-parse-term* preterm mod-name) | |
| 390 | (make-abst-boolean-term target context-module))) | |
| 391 | ||
| 392 | ;;;========================================================================= | |
| 393 | ;;; TOP LEVEL FUNCTION | |
| 394 | ;;; | |
| 395 | ||
| 396 | ;;; binspect-in | |
| 397 | ;;; make abstracted boolean term. | |
| 398 | ;;; :binspect [in <goal-name> :] <boolean-term> . | |
| 399 | ;;; binspect [in <module-name> :] <boolean-term> . | |
| 400 | ;;; | |
| 401 | (defun binspect-in (mode goal-or-module-name preterm) | |
| 402 | (cond ((eq mode :citp) | |
| 403 | (binspect-in-goal goal-or-module-name preterm)) | |
| 404 | (t | |
| 405 | (binspect-in-module goal-or-module-name preterm)))) | |
| 406 | ||
| 407 | ;;; bresolve | |
| 408 | ;;; finds variable assignments which make abst bterm 'true'. | |
| 409 | ;;; | |
| 410 | (defun bresolve () | |
| 411 | (try-resolve-bterm)) | |
| 412 | ||
| 413 | ;;; bshow | |
| 414 | ;;; print out abst bterm. | |
| 415 | ;;; bshow [tree] | |
| 416 | (defun bshow (tree?) | |
| 417 | (unless *abst-bterm* | |
| 418 | (return-from bshow nil)) | |
| 419 | (with-in-module ((abst-bterm-module *abst-bterm*)) | |
| 420 | (if (equal tree? "tree") | |
| 421 | (print-term-horizontal *abst-bterm-representation* *current-module*) | |
| 422 | (if (equal tree? ".") | |
| 423 | (term-print *abst-bterm-representation*) | |
| 424 | (with-output-chaos-error ('invalid-parameter) | |
| 425 | (format t "Unknown option ~s" tree?)))) | |
| 426 | (print-bterm-substitution *abst-bterm* *abst-bterm-representation*))) | |
| 427 | ||
| 428 | ;;; EOF |
| 0 | 0 | ;;;-*- Mode:LISP; Package:CHAOS; Base:10; Syntax:Common-lisp -*- |
| 1 | 1 | ;;; |
| 2 | ;;; Copyright (c) 2000-2014, Toshimi Sawada. All rights reserved. | |
| 2 | ;;; Copyright (c) 2000-2015, Toshimi Sawada. All rights reserved. | |
| 3 | 3 | ;;; |
| 4 | 4 | ;;; Redistribution and use in source and binary forms, with or without |
| 5 | 5 | ;;; modification, are permitted provided that the following conditions |
| 27 | 27 | ;;; |
| 28 | 28 | (in-package :chaos) |
| 29 | 29 | #|============================================================================== |
| 30 | System: CHAOS | |
| 31 | Module: thstuff | |
| 32 | File: base.lisp | |
| 30 | System: CHAOS | |
| 31 | Module: thstuff | |
| 32 | File: base.lisp | |
| 33 | 33 | ==============================================================================|# |
| 34 | 34 | |
| 35 | 35 | (defparameter .case-module-true. (%module-decl* "true-dummy" :object :user nil)) |
| 39 | 39 | |
| 40 | 40 | (defun perform-case-reduction (ast) |
| 41 | 41 | (let ((bool-term (%scase-bool-term ast)) |
| 42 | (module (%scase-module ast)) | |
| 43 | (name (%scase-name ast)) | |
| 44 | (body (parse-module-elements (%scase-body ast))) | |
| 45 | (goal-term (%scase-goal-term ast))) | |
| 42 | (module (%scase-module ast)) | |
| 43 | (name (%scase-name ast)) | |
| 44 | (body (parse-module-elements (%scase-body ast))) | |
| 45 | (goal-term (%scase-goal-term ast))) | |
| 46 | 46 | ;; prepare modules |
| 47 | 47 | (setf (%module-decl-name .case-module-true.) (concatenate 'string name "-#T")) |
| 48 | 48 | (setf (%module-decl-name .case-module-false.) (concatenate 'string name "-#F")) |
| 54 | 54 | (setf (%module-decl-elements .case-module-false.) (append body (list .case-false-axiom.))) |
| 55 | 55 | ;; |
| 56 | 56 | (let ((org-mod (eval-modexp module)) |
| 57 | (true-mod (eval-ast .case-module-true.)) | |
| 58 | (false-mod (eval-ast .case-module-false.))) | |
| 57 | (true-mod (eval-ast .case-module-true.)) | |
| 58 | (false-mod (eval-ast .case-module-false.))) | |
| 59 | 59 | (when (modexp-is-error org-mod) |
| 60 | (with-output-chaos-error ('no-such-module) | |
| 61 | (format t "No such module or invalid module expression ~s" module))) | |
| 60 | (with-output-chaos-error ('no-such-module) | |
| 61 | (format t "No such module or invalid module expression ~s" module))) | |
| 62 | 62 | |
| 63 | 63 | ;; CASE TRUE |
| 64 | 64 | (with-in-module (true-mod) |
| 65 | (compile-module *current-module*) | |
| 66 | ;; | |
| 67 | (with-output-simple-msg () | |
| 68 | (format t "===================~%") | |
| 69 | (format t ">>* CASE: true *<<~%") | |
| 70 | (format t "===================")) | |
| 71 | (perform-reduction* goal-term true-mod :red)) | |
| 65 | (compile-module *current-module*) | |
| 66 | ;; | |
| 67 | (with-output-simple-msg () | |
| 68 | (format t "===================~%") | |
| 69 | (format t ">>* CASE: true *<<~%") | |
| 70 | (format t "===================")) | |
| 71 | (perform-reduction* goal-term true-mod :red)) | |
| 72 | 72 | |
| 73 | 73 | ;; CASE FALSE |
| 74 | 74 | (with-in-module (false-mod) |
| 75 | (compile-module *current-module*) | |
| 76 | ;; | |
| 77 | (with-output-simple-msg () | |
| 78 | (format t "===================~%") | |
| 79 | (format t ">>* CASE: false *<<~%") | |
| 80 | (format t "===================")) | |
| 81 | (perform-reduction* goal-term false-mod :red))))) | |
| 75 | (compile-module *current-module*) | |
| 76 | ;; | |
| 77 | (with-output-simple-msg () | |
| 78 | (format t "===================~%") | |
| 79 | (format t ">>* CASE: false *<<~%") | |
| 80 | (format t "===================")) | |
| 81 | (perform-reduction* goal-term false-mod :red))))) | |
| 82 | 82 | |
| 83 | 83 | |
| 84 | 84 | |
| 85 | 85 | ;;; EOF |
| 86 | ||
| 86 | ||
| 0 | 0 | ;;;-*-Mode:LISP; Package: CHAOS; Base:10; Syntax:Common-lisp -*- |
| 1 | 1 | ;;; |
| 2 | ;;; Copyright (c) 2000-2014, Toshimi Sawada. All rights reserved. | |
| 2 | ;;; Copyright (c) 2000-2015, Toshimi Sawada. All rights reserved. | |
| 3 | 3 | ;;; |
| 4 | 4 | ;;; Redistribution and use in source and binary forms, with or without |
| 5 | 5 | ;;; modification, are permitted provided that the following conditions |
| 36 | 36 | #+:chaos-debug |
| 37 | 37 | (declaim (optimize (speed 1) (safety 3) #-GCL (debug 3))) |
| 38 | 38 | |
| 39 | ;;; set t if you want a debug mode --> set debug exec on. | |
| 40 | ;;; (defvar *cexec-debug* nil) | |
| 41 | ||
| 42 | 39 | ;;; |
| 43 | 40 | (declaim (special $$cexec-term)) ; the target term |
| 44 | 41 | |
| 53 | 50 | ;;; - SUBST: the substitution |
| 54 | 51 | ;;; |
| 55 | 52 | (defstruct (rule-pat (:print-function print-rule-pattern)) |
| 56 | (pos nil :type list) ; matched position | |
| 57 | (rule nil) ; matched rule | |
| 58 | (subst nil) ; variable substitution | |
| 59 | (cond-ok t) ; t iff condition part of the rule is satisfied | |
| 60 | (condition nil) ; resulting condition part ('if') when cond-ok = nil | |
| 61 | (num 0 :type fixnum) ; sequential #, used for debugging | |
| 53 | (pos nil :type list) ; matched position | |
| 54 | (rule nil) ; matched rule | |
| 55 | (subst nil) ; variable substitution | |
| 56 | (cond-ok t) ; t iff condition part of the rule is satisfied | |
| 57 | (condition nil) ; resulting condition part ('if') when cond-ok = nil | |
| 58 | (num 0 :type fixnum) ; sequential #, used for debugging | |
| 62 | 59 | ) |
| 63 | 60 | |
| 64 | 61 | (defvar .rules-so-far. 0) |
| 73 | 70 | |
| 74 | 71 | (defun make-rule-pat-with-check (pos rule subst sch-context) |
| 75 | 72 | (when (rule-non-exec rule) |
| 73 | ;; the rule is marked as non-executable | |
| 76 | 74 | (return-from make-rule-pat-with-check nil)) |
| 77 | 75 | (let ((condition (rule-condition rule))) |
| 78 | (unless condition | |
| 79 | (return-from make-rule-pat-with-check (make-rule-pat :pos pos :rule rule :subst subst))) | |
| 80 | ;; pre check the condition part is satisfied or not | |
| 76 | ;; pre check whether the condition part is satisfied or not | |
| 81 | 77 | (when (and (is-true? condition) |
| 82 | 78 | (null (rule-id-condition rule))) |
| 79 | ;; rule is not conditional | |
| 83 | 80 | (return-from make-rule-pat-with-check |
| 84 | 81 | (make-rule-pat :pos pos :rule rule :subst subst :num (incf .rules-so-far.)))) |
| 82 | ;; check the condition | |
| 85 | 83 | (let (($$term nil) |
| 86 | ($$cond (set-term-color | |
| 87 | #|| | |
| 88 | (substitution-image-simplifying subst | |
| 89 | condition | |
| 90 | t | |
| 91 | :slow) | |
| 92 | ||# | |
| 93 | (substitution-image-cp subst condition) | |
| 94 | ))) | |
| 84 | ($$cond (set-term-color (substitution-image-cp subst condition)))) | |
| 85 | ||
| 95 | 86 | (when *cexec-debug* |
| 96 | (format t "~%rule: cond ") (term-print-with-sort $$cond) | |
| 97 | (format t "~% subst") (print-substitution subst) | |
| 98 | (let ((vars (term-variables $$cond))) | |
| 99 | (dolist (v vars) | |
| 100 | (format t "~% var ") (term-print-with-sort v)))) | |
| 87 | (format t "~%rule: cond ") (term-print-with-sort $$cond) | |
| 88 | (format t "~% subst") (print-substitution subst) | |
| 89 | (let ((vars (term-variables $$cond))) | |
| 90 | (dolist (v vars) | |
| 91 | (format t "~% var ") (term-print-with-sort v)))) | |
| 101 | 92 | |
| 102 | 93 | (catch 'rule-failure |
| 103 | (if (and (or (null (rule-id-condition rule)) | |
| 94 | (if (and (or (null (rule-id-condition rule)) | |
| 104 | 95 | (rule-eval-id-condition subst |
| 105 | 96 | (rule-id-condition rule) |
| 106 | 97 | :slow)) |
| 107 | 98 | (is-true? (progn (normalize-term $$cond) $$cond))) |
| 108 | ;; the condition is satisfied | |
| 109 | (return-from make-rule-pat-with-check | |
| 110 | (make-rule-pat :pos pos :rule rule :subst subst :cond-ok t :condition $$cond :num (incf .rules-so-far.))) | |
| 111 | (if (rwl-sch-context-if sch-context) | |
| 112 | ;; rule condition fail & there exists 'if' | |
| 113 | (return-from make-rule-pat-with-check | |
| 114 | (make-rule-pat :pos pos :rule rule :subst subst :cond-ok nil :condition $$cond :num (incf .rules-so-far.))) | |
| 115 | (return-from make-rule-pat-with-check nil)))) | |
| 99 | ;; the condition is satisfied | |
| 100 | (return-from make-rule-pat-with-check | |
| 101 | (make-rule-pat :pos pos :rule rule :subst subst :cond-ok t :condition $$cond :num (incf .rules-so-far.))) | |
| 102 | (if (rwl-sch-context-if sch-context) | |
| 103 | ;; rule condition fail & there exists 'if' | |
| 104 | (return-from make-rule-pat-with-check | |
| 105 | (make-rule-pat :pos pos :rule rule :subst subst :cond-ok nil :condition $$cond :num (incf .rules-so-far.))) | |
| 106 | (return-from make-rule-pat-with-check nil)))) | |
| 116 | 107 | nil))) |
| 117 | ||
| 118 | #|| | |
| 119 | (defmacro rule-pat-pos (pat) `(car ,pat)) | |
| 120 | (defmacro rule-pat-rule (pat) `(cadr ,pat)) | |
| 121 | (defmacro rule-pat-subst (pat) `(caddr ,pat)) | |
| 122 | ||# | |
| 123 | 108 | |
| 124 | 109 | (defun rule-pat-equal (pat1 pat2) |
| 125 | 110 | (and (equal (rule-pat-pos pat1) (rule-pat-pos pat2)) |
| 138 | 123 | (state 0 :type fixnum) ; fixnum value identifying this state |
| 139 | 124 | (term nil) ; a term |
| 140 | 125 | (trans-rules nil) ; applicable rules to this state |
| 141 | (rule-pat nil) ; the rule-pat which derived this state | |
| 126 | (rule-pat nil) ; the rule-pat which derived this state | |
| 142 | 127 | (subst nil) ; list of substitution !! |
| 143 | 128 | (is-final nil) ; t iff the state is a final state |
| 144 | 129 | (loop nil) ; t iff the same state occurs more than once |
| 145 | (condition nil) ; | |
| 130 | (condition nil) ; | |
| 146 | 131 | ) |
| 147 | 132 | |
| 148 | 133 | (defun state-is-valid-transition (state) |
| 149 | 134 | (let ((cond (rwl-state-condition state))) |
| 150 | 135 | (and (not (rwl-state-loop state)) |
| 151 | (or (null cond) | |
| 152 | (is-true? cond))))) | |
| 136 | (or (null cond) | |
| 137 | (is-true? cond))))) | |
| 153 | 138 | |
| 154 | 139 | (defun pr-rwl-state (state &optional (stream *standard-output*) &rest ignore) |
| 155 | 140 | (declare (ignore ignore)) |
| 168 | 153 | (type rwl-state state) |
| 169 | 154 | (type stream stream)) |
| 170 | 155 | (let ((*standard-output* stream)) |
| 171 | (format t "~&[state ~D] " (rwl-state-state state)) | |
| 156 | (format t "~%[state ~D] " (rwl-state-state state)) | |
| 172 | 157 | (let ((*print-indent* (+ 4 *print-indent*))) |
| 173 | 158 | (term-print-with-sort (rwl-state-term state)) |
| 174 | 159 | (when *cexec-trace* |
| 175 | 160 | (format t "~& matched with the substitution ")) |
| 176 | 161 | (let ((*print-indent* (+ 4 *print-indent*))) |
| 177 | (dolist (subst (rwl-state-subst state)) | |
| 178 | (print-next) | |
| 179 | (print-substitution subst))) | |
| 162 | (dolist (subst (rwl-state-subst state)) | |
| 163 | (print-next) | |
| 164 | (print-substitution subst))) | |
| 180 | 165 | (flush-all)))) |
| 181 | 166 | |
| 182 | 167 | (defun print-state-transition (state sub-states &optional (stream *standard-output*)) |
| 186 | 171 | (let ((*standard-output* stream) |
| 187 | 172 | (arc-num 0)) |
| 188 | 173 | (declare (type fixnum arc-num)) |
| 189 | (format t "~&[state ~D] " (rwl-state-state state)) | |
| 174 | (format t "~%[state ~D] " (rwl-state-state state)) | |
| 190 | 175 | (term-print-with-sort (rwl-state-term state)) |
| 191 | 176 | (dolist (sub sub-states) |
| 192 | 177 | (format t "~& arc ~D --> [state ~D] " arc-num (rwl-state-state sub)) |
| 193 | 178 | (let ((*print-indent* (+ 4 *print-indent*))) |
| 194 | 179 | (print-next) |
| 195 | 180 | (print-axiom-brief (rule-pat-rule (rwl-state-rule-pat sub)))) |
| 196 | (incf arc-num)) | |
| 197 | )) | |
| 181 | (incf arc-num)))) | |
| 198 | 182 | |
| 199 | 183 | ;;; *********** |
| 200 | 184 | ;;; SEARCH TREE |
| 218 | 202 | (let ((*standard-output* stream)) |
| 219 | 203 | (format t "SCH-NODE:~A" (dag-node-datum node)))) |
| 220 | 204 | |
| 205 | ;;; ****************** | |
| 221 | 206 | ;;; RWL-SCH-NODE utils |
| 222 | ;;; | |
| 207 | ;;; ****************** | |
| 223 | 208 | |
| 224 | 209 | ;;; print the rule & state |
| 225 | 210 | ;;; |
| 234 | 219 | (princ " ") |
| 235 | 220 | (let ((*print-indent* (+ 8 *print-indent*))) |
| 236 | 221 | (print-axiom-brief rl))) |
| 237 | (format t "~&[state ~D] " state) | |
| 222 | (format t "~%[state ~D] " state) | |
| 238 | 223 | (term-print-with-sort term) |
| 239 | 224 | (dolist (sub (rwl-state-subst st)) |
| 240 | 225 | (format t "~& ") |
| 241 | 226 | (print-substitution sub) |
| 242 | 227 | (when bind-pattern |
| 243 | (let ((bimage (substitution-image-simplifying sub bind-pattern))) | |
| 244 | (normalize-term bimage) | |
| 245 | (format t "~% => ") | |
| 246 | (term-print-with-sort bimage)))))) | |
| 228 | (let ((bimage (substitution-image-simplifying sub bind-pattern))) | |
| 229 | (normalize-term bimage) | |
| 230 | (format t "~% => ") | |
| 231 | (term-print-with-sort bimage)))))) | |
| 247 | 232 | |
| 248 | 233 | ;;; print the label of a rule which derived a state |
| 249 | 234 | ;;; that denode contains. |
| 285 | 270 | (state-predicate nil) ; STATE equality predicate |
| 286 | 271 | (answers nil) ; list of STATEs satisfying specified |
| 287 | 272 | ; conditions. |
| 288 | (bind nil) ; .... | |
| 289 | (if nil) ; | |
| 290 | (pr-out? nil) ; | |
| 273 | (bind nil) ; .... | |
| 274 | (if nil) ; | |
| 275 | (pr-out? nil) ; | |
| 291 | 276 | ) |
| 292 | 277 | |
| 293 | 278 | (defun print-sch-context (ctxt &optional (stream *standard-output*) &rest ignore) |
| 295 | 280 | (let ((*standard-output* stream) |
| 296 | 281 | (mod (rwl-sch-context-module ctxt))) |
| 297 | 282 | (with-in-module (mod) |
| 298 | (format t "~&<< sch context >>") | |
| 283 | (format t "~%<< sch context >>") | |
| 299 | 284 | (format t "~% module: ") |
| 300 | 285 | (print-chaos-object (rwl-sch-context-module ctxt)) |
| 301 | 286 | (format t "~% term: ") |
| 322 | 307 | (dolist (x (reverse (rwl-sch-context-answers ctxt))) |
| 323 | 308 | (term-print-with-sort (rwl-state-term x))) |
| 324 | 309 | (when (rwl-sch-context-bind ctxt) |
| 325 | (format t "~% bind pattern: ") | |
| 326 | (term-print-with-sort (rwl-sch-context-bind ctxt))) | |
| 310 | (format t "~% bind pattern: ") | |
| 311 | (term-print-with-sort (rwl-sch-context-bind ctxt))) | |
| 327 | 312 | (when (rwl-sch-context-if ctxt) |
| 328 | (format t "~% if: ") | |
| 329 | (term-print-with-sort (rwl-sch-context-if ctxt)))))) | |
| 313 | (format t "~% if: ") | |
| 314 | (term-print-with-sort (rwl-sch-context-if ctxt)))))) | |
| 330 | 315 | |
| 331 | 316 | ;;; .RWL-SCH-CONTEXT. |
| 332 | 317 | ;;; moved to comlib/globals.lisp |
| 333 | 318 | ;;; (defvar .rwl-sch-context. nil) |
| 334 | 319 | |
| 320 | ;;; ********************* | |
| 335 | 321 | ;;; SEARCH CONTEXT UTILS |
| 336 | ;;; | |
| 322 | ;;; ********************* | |
| 337 | 323 | |
| 338 | 324 | ;;; show-rwl-sch-graph |
| 339 | 325 | ;;; |
| 340 | 326 | (defun show-rwl-sch-graph (&optional num) |
| 341 | 327 | (let ((c-num (if num |
| 342 | (read-from-string num) | |
| 343 | 0)) | |
| 344 | (sch-context nil)) | |
| 328 | (read-from-string num) | |
| 329 | 0)) | |
| 330 | (sch-context nil)) | |
| 345 | 331 | (unless (integerp c-num) |
| 346 | 332 | (with-output-chaos-error ('invalid-context-number) |
| 347 | (format t "invalid search graph number ~s" num))) | |
| 333 | (format t "invalid search graph number ~s" num))) | |
| 348 | 334 | (setq sch-context (nth c-num (reverse .rwl-context-stack.))) |
| 349 | 335 | (unless sch-context |
| 350 | 336 | (with-output-chaos-error ('no-such-context) |
| 351 | (format t "no such search graph ~d" num))) | |
| 337 | (format t "no such search graph ~d" num))) | |
| 352 | 338 | (let ((mod (rwl-sch-context-module sch-context)) |
| 353 | (root (rwl-sch-context-root sch-context))) | |
| 339 | (root (rwl-sch-context-root sch-context))) | |
| 354 | 340 | (unless mod |
| 355 | (with-output-chaos-error ('no-context) | |
| 356 | (format t "no context module..."))) | |
| 341 | (with-output-chaos-error ('no-context) | |
| 342 | (format t "no context module..."))) | |
| 357 | 343 | (unless root |
| 358 | (with-output-chaos-error ('no-root) | |
| 359 | (format t "no search result exists..."))) | |
| 344 | (with-output-chaos-error ('no-root) | |
| 345 | (format t "no search result exists..."))) | |
| 360 | 346 | (when (and *current-module* |
| 361 | (not (eq *current-module* mod))) | |
| 362 | (with-output-chaos-warning () | |
| 363 | (format t "the context(module) of search graph is different from the current module."))) | |
| 347 | (not (eq *current-module* mod))) | |
| 348 | (with-output-chaos-warning () | |
| 349 | (format t "the context(module) of search graph is different from the current module."))) | |
| 364 | 350 | ;; |
| 365 | 351 | (with-in-module (mod) |
| 366 | (let ((state-hash (make-hash-table))) | |
| 367 | (dag-wfs root | |
| 368 | #'(lambda (d) | |
| 369 | (let* ((state-node (dag-node-datum d)) | |
| 370 | (state (rwl-state-state state-node))) | |
| 371 | (unless (gethash state state-hash) | |
| 372 | (setf (gethash state state-hash) t) | |
| 373 | (print-state-transition | |
| 374 | state-node | |
| 375 | (mapcar #'(lambda (sd) | |
| 376 | (dag-node-datum sd)) | |
| 377 | (dag-node-subnodes d)))))))))))) | |
| 352 | (let ((state-hash (make-hash-table))) | |
| 353 | (dag-wfs root | |
| 354 | #'(lambda (d) | |
| 355 | (let* ((state-node (dag-node-datum d)) | |
| 356 | (state (rwl-state-state state-node))) | |
| 357 | (unless (gethash state state-hash) | |
| 358 | (setf (gethash state state-hash) t) | |
| 359 | (print-state-transition | |
| 360 | state-node | |
| 361 | (mapcar #'(lambda (sd) | |
| 362 | (dag-node-datum sd)) | |
| 363 | (dag-node-subnodes d)))))))))))) | |
| 378 | 364 | |
| 379 | 365 | (defun find-rwl-sch-state (num &optional (sch-context .rwl-sch-context.)) |
| 380 | 366 | (declare (type fixnum num)) |
| 400 | 386 | |
| 401 | 387 | (defun show-rwl-sch-path (num-tok &optional (label? nil) |
| 402 | 388 | (sch-context .rwl-sch-context.) |
| 403 | (state-only? nil)) | |
| 389 | (state-only? nil)) | |
| 404 | 390 | (unless num-tok |
| 405 | 391 | (return-from show-rwl-sch-path |
| 406 | 392 | (format t "~%nothing to be reported..."))) |
| 412 | 398 | (with-output-chaos-error () |
| 413 | 399 | (format t "state must be a positive integer value."))) |
| 414 | 400 | (multiple-value-bind (sch-context dag) |
| 415 | (find-rwl-sch-state-globally num) | |
| 401 | (find-rwl-sch-state-globally num) | |
| 416 | 402 | (unless dag |
| 417 | 403 | (with-output-chaos-error ('no-state) |
| 418 | 404 | (format t "no such state ~D" num))) |
| 422 | 408 | (with-output-chaos-warning () |
| 423 | 409 | (format t "the context(module) of search result is different from the current module."))) |
| 424 | 410 | (with-in-module (mod) |
| 425 | (cond (state-only? (show-rwl-sch-state dag nil (rwl-sch-context-bind sch-context))) | |
| 426 | (t (let ((parents (get-bdag-parents dag))) | |
| 427 | (cond (label? | |
| 428 | (dolist (p (cdr parents)) ;root has no transition | |
| 429 | (show-rwl-sch-label p)) | |
| 430 | (show-rwl-sch-label dag)) | |
| 431 | (t (dolist (p parents) | |
| 432 | (show-rwl-sch-state p t (rwl-sch-context-bind sch-context))) | |
| 433 | (show-rwl-sch-state dag t (rwl-sch-context-bind sch-context)))))))))))) | |
| 411 | (cond (state-only? (show-rwl-sch-state dag nil (rwl-sch-context-bind sch-context))) | |
| 412 | (t (let ((parents (get-bdag-parents dag))) | |
| 413 | (cond (label? | |
| 414 | (dolist (p (cdr parents)) ;root has no transition | |
| 415 | (show-rwl-sch-label p)) | |
| 416 | (show-rwl-sch-label dag)) | |
| 417 | (t (dolist (p parents) | |
| 418 | (show-rwl-sch-state p t (rwl-sch-context-bind sch-context))) | |
| 419 | (show-rwl-sch-state dag t (rwl-sch-context-bind sch-context)))))))))))) | |
| 434 | 420 | |
| 435 | 421 | |
| 436 | 422 | ;;; ************* |
| 437 | 423 | ;;; PATTERN MATCH |
| 438 | 424 | ;;; ************* |
| 439 | ||
| 440 | ;;; matcher | |
| 441 | ;;; | |
| 442 | #|| not used | |
| 443 | (defun cexec-pat-match (pat target) | |
| 444 | (multiple-value-bind (gs sub no eeq) | |
| 445 | (@matcher pat target :match) | |
| 446 | (declare (ignore eeq)) | |
| 447 | (null no))) | |
| 448 | ||# | |
| 449 | 425 | |
| 450 | 426 | ;;; finds all transition rules possibly applicable to the given target term |
| 451 | 427 | ;;; |
| 453 | 429 | (let ((module (rwl-sch-context-module sch-context))) |
| 454 | 430 | (when start-pos |
| 455 | 431 | (setq target (get-target-subterm target start-pos))) |
| 456 | ;; | |
| 457 | 432 | (with-in-module (module) |
| 458 | 433 | (let* ((*module-all-rules-every* t) |
| 459 | (rules (get-module-axioms *current-module* t)) | |
| 460 | (rls nil) | |
| 461 | (res nil)) | |
| 462 | (dolist (rule rules) | |
| 463 | (when (rule-is-rule rule) | |
| 464 | (push rule rls) | |
| 465 | ;; add extensions also if any | |
| 466 | ;; needless because 'apply-rule' applies extensions | |
| 467 | #|| | |
| 468 | (let ((a-extensions (give-A-extensions rule)) | |
| 469 | (ac-extension (give-ac-extension rule))) | |
| 470 | (dolist (rl a-extensions) | |
| 471 | (when rl | |
| 472 | (push rl rls))) | |
| 473 | (dolist (rl ac-extension) | |
| 474 | (when rl | |
| 475 | (push rl rls)))) | |
| 476 | ||# | |
| 477 | )) | |
| 478 | ;; gather rules | |
| 479 | ;; (clean-rule-table) | |
| 480 | (setq res (find-matching-rules-for-exec* target rls start-pos sch-context)) | |
| 481 | (setq res (delete-duplicates res | |
| 482 | :test #'rule-pat-equal)) | |
| 483 | ;; | |
| 484 | (when *cexec-debug* | |
| 485 | (format t "~%** ~D rules were found for term: " | |
| 486 | (length res)) | |
| 487 | (term-print target) | |
| 488 | (terpri) | |
| 489 | (dolist (r res) | |
| 490 | (print-rule-pattern r))) | |
| 491 | ;; | |
| 492 | res )))) | |
| 434 | (rules (get-module-axioms *current-module* t)) | |
| 435 | (rls nil) | |
| 436 | (res nil)) | |
| 437 | (dolist (rule rules) | |
| 438 | (when (rule-is-rule rule) | |
| 439 | (push rule rls))) | |
| 440 | ;; gather rules | |
| 441 | (setq res (find-matching-rules-for-exec* target rls start-pos sch-context)) | |
| 442 | (setq res (delete-duplicates res | |
| 443 | :test #'rule-pat-equal)) | |
| 444 | (when *cexec-debug* | |
| 445 | (format t "~%** ~D rules were found for term: " | |
| 446 | (length res)) | |
| 447 | (term-print target) | |
| 448 | (terpri) | |
| 449 | (dolist (r res) | |
| 450 | (print-rule-pattern r))) | |
| 451 | res )))) | |
| 493 | 452 | |
| 494 | 453 | (defun find-matching-rules-for-exec* (target rules pos sch-context) |
| 495 | 454 | (when *cexec-debug* |
| 496 | (format t "~&find matching rules. ") | |
| 455 | (format t "~%find matching rules. ") | |
| 497 | 456 | (term-print target) |
| 498 | 457 | (terpri)) |
| 499 | 458 | (if (term-is-application-form? target) |
| 507 | 466 | (head (if (term-is-variable? lhs) |
| 508 | 467 | nil |
| 509 | 468 | (term-head lhs)))) |
| 510 | ;;:: | |
| 511 | ;;(unless rule (break "HANA !!!")) | |
| 512 | 469 | (push rule patterns) |
| 513 | ;; #|| ------- apply-rule always applies extensions | |
| 470 | ;; ------- apply-rule always applies extensions | |
| 514 | 471 | (when head |
| 515 | 472 | (when (method-is-associative head) |
| 516 | 473 | (if (method-is-commutative head) |
| 523 | 480 | ;; |
| 524 | 481 | (let ((a-exts (give-A-extensions rule))) |
| 525 | 482 | (dolist (r a-exts) |
| 526 | ;; (unless r (break "HANA 2")) | |
| 527 | 483 | (when r |
| 528 | 484 | (push r patterns))))))) |
| 529 | ;; ------------ ||# | |
| 530 | ;; | |
| 485 | ;; ------------ | |
| 531 | 486 | (dolist (pat patterns) |
| 532 | 487 | (block next |
| 533 | ;; (break) | |
| 534 | 488 | (unless pat (break "HANA my")) |
| 535 | #|| | |
| 536 | (when (cexec-pat-match (axiom-lhs pat) target) | |
| 537 | (push (make-rule-pat-with-check pos pat) res)) | |
| 538 | ||# | |
| 539 | 489 | ;; find all possible subst |
| 540 | 490 | (multiple-value-bind (gs sub no-match eeq) |
| 541 | 491 | (@matcher (axiom-lhs pat) target :match) |
| 550 | 500 | (when no-match (return-from next)) |
| 551 | 501 | (setq rule-pat (make-rule-pat-with-check pos pat sub sch-context)) |
| 552 | 502 | (when rule-pat |
| 553 | (push rule-pat res)))) | |
| 554 | )) | |
| 503 | (push rule-pat res)))))) | |
| 555 | 504 | )) ; done for all rules |
| 556 | 505 | ;; recursively find rules for subterms |
| 557 | 506 | (dotimes (x (length (term-subterms target))) |
| 558 | 507 | (let ((r (find-matching-rules-for-exec* (term-arg-n target x) |
| 559 | rules | |
| 560 | (append pos (list x)) | |
| 561 | sch-context))) | |
| 508 | rules | |
| 509 | (append pos (list x)) | |
| 510 | sch-context))) | |
| 562 | 511 | (when r (setq res (nconc res r))))) |
| 563 | 512 | ;; |
| 564 | 513 | res) |
| 569 | 518 | ;;; **************** |
| 570 | 519 | |
| 571 | 520 | (defun if-binding-should-be-printed (sch-context) |
| 572 | #|| | |
| 573 | (when *cexec-debug* | |
| 574 | (format t "~%++ checking print or not:~% if = ~s, current depth = ~d, max = ~d" | |
| 575 | (rwl-sch-context-if sch-context) | |
| 576 | (rwl-sch-context-cur-depth sch-context) | |
| 577 | (rwl-sch-context-max-depth sch-context))) | |
| 578 | ||# | |
| 579 | 521 | (and (rwl-sch-context-if sch-context) |
| 522 | ;; (not *rwl-search-no-state-report*) | |
| 580 | 523 | (<= (rwl-sch-context-cur-depth sch-context) (rwl-sch-context-max-depth sch-context)))) |
| 581 | 524 | |
| 582 | 525 | ;;; rwl-sch-check-conditions (node rwl-sch-context) |
| 587 | 530 | (declare (type rwl-sch-node node) |
| 588 | 531 | (type rwl-sch-context sch-context)) |
| 589 | 532 | (flet ((condition-check-ok (subst) |
| 590 | (let ((cond (rwl-sch-context-condition sch-context)) | |
| 591 | ($$term nil) | |
| 592 | ($$cond nil) | |
| 593 | (*rewrite-exec-mode* (if *rewrite-exec-condition* | |
| 594 | *rewrite-exec-mode* | |
| 595 | nil))) | |
| 596 | (if (null cond) | |
| 597 | (setq $$cond *bool-true*) | |
| 598 | (setq $$cond (set-term-color | |
| 599 | (substitution-image-cp subst cond)))) | |
| 600 | (when *cexec-debug* | |
| 601 | (format t "~& subst: ") (print-substitution subst) | |
| 602 | (format t "~& suchThat: ") (term-print $$cond)) | |
| 603 | (or (is-true? $$cond) | |
| 604 | (is-true? (progn | |
| 605 | (normalize-term $$cond) | |
| 606 | (when *cexec-debug* | |
| 607 | (format t " ---> ") (term-print $$cond) | |
| 608 | (format t "~& = ~s" (is-true? $$cond))) | |
| 609 | $$cond)))))) | |
| 533 | (let ((cond (rwl-sch-context-condition sch-context)) | |
| 534 | ($$term nil) | |
| 535 | ($$cond nil) | |
| 536 | (*rewrite-exec-mode* (if *rewrite-exec-condition* | |
| 537 | *rewrite-exec-mode* | |
| 538 | nil))) | |
| 539 | (if (null cond) | |
| 540 | (setq $$cond *bool-true*) | |
| 541 | (setq $$cond (set-term-color | |
| 542 | (substitution-image-cp subst cond)))) | |
| 543 | (when *cexec-debug* | |
| 544 | (format t "~% subst :") (print-substitution subst) | |
| 545 | (format t "~& suchThat :") (term-print $$cond)) | |
| 546 | (or (is-true? $$cond) | |
| 547 | (is-true? (progn | |
| 548 | (if *cexec-debug* | |
| 549 | (let (($$trace-rewrite t)) | |
| 550 | (print-term-tree $$cond t) | |
| 551 | (normalize-term $$cond)) | |
| 552 | (normalize-term $$cond)) | |
| 553 | (when *cexec-debug* | |
| 554 | (format t " -C-> ") (term-print $$cond) | |
| 555 | (format t "~% = ~s" (is-true? $$cond))) | |
| 556 | $$cond)))))) | |
| 610 | 557 | ;; if checked already, we return immediately as non. |
| 611 | 558 | (when (and (sch-node-done node) (null (rwl-sch-context-if sch-context))) |
| 612 | 559 | (return-from rwl-sch-check-conditions nil)) |
| 613 | 560 | ;; |
| 614 | 561 | (let* ((state (dag-node-datum node)) |
| 615 | (if-var (rwl-sch-context-if sch-context)) | |
| 616 | (rule-pat (rwl-state-rule-pat state))) | |
| 562 | (if-var (rwl-sch-context-if sch-context)) | |
| 563 | (rule-pat (rwl-state-rule-pat state))) | |
| 617 | 564 | (declare (type rwl-state state)) |
| 618 | ;; | |
| 565 | ||
| 619 | 566 | (when *chaos-verbose* |
| 620 | 567 | (format t " ~D" (rwl-state-state state))) |
| 621 | ;; | |
| 568 | ||
| 622 | 569 | (setf (sch-node-done node) t) ; mark checked already |
| 623 | ;; | |
| 624 | ;; *** | |
| 625 | ;; (return-from rwl-sch-check-conditions nil) | |
| 570 | ||
| 626 | 571 | (when *cexec-debug* |
| 627 | (when (rwl-sch-context-condition sch-context) | |
| 628 | (format t "~%** check condition ") | |
| 629 | (term-print-with-sort (rwl-sch-context-condition sch-context)) | |
| 630 | (if rule-pat | |
| 631 | (print-rule-pattern rule-pat) | |
| 632 | (format t "~% no rule-pat.")))) | |
| 572 | (when (rwl-sch-context-condition sch-context) | |
| 573 | (format t "~%** check condition ") | |
| 574 | (term-print-with-sort (rwl-sch-context-condition sch-context)) | |
| 575 | (if rule-pat | |
| 576 | (print-rule-pattern rule-pat) | |
| 577 | (format t "~% no rule-pat.")))) | |
| 633 | 578 | ;; 0 transition? |
| 634 | 579 | (when (and (not (rwl-sch-context-zero-trans-allowed sch-context)) |
| 635 | ;; (= 0 (rwl-sch-context-cur-depth sch-context)) | |
| 636 | (= 0 (rwl-sch-context-trans-so-far sch-context))) | |
| 637 | ;; (format t "~%Wow!") | |
| 638 | (when *cexec-debug* | |
| 639 | (format t "~%.check condition return with 0 transition.")) | |
| 580 | (= 0 (rwl-sch-context-trans-so-far sch-context))) | |
| 581 | (when *cexec-debug* | |
| 582 | (format t "~%.check condition return with 0 transition.")) | |
| 640 | 583 | (return-from rwl-sch-check-conditions nil)) |
| 641 | 584 | ;; check with target pattern. |
| 642 | 585 | (multiple-value-bind (gs sub no-match eeq) |
| 645 | 588 | :match) |
| 646 | 589 | (declare (ignore eeq)) |
| 647 | 590 | (when no-match |
| 648 | (when *cexec-debug* | |
| 649 | (format t "~%.check condition return with no-match.")) | |
| 591 | (when *cexec-debug* | |
| 592 | (format t "~%.check condition return with no-match.")) | |
| 650 | 593 | (return-from rwl-sch-check-conditions nil)) |
| 651 | ;; expand subst with | |
| 652 | (when rule-pat | |
| 653 | (setq sub (append sub (rule-pat-subst rule-pat)))) | |
| 654 | ;; additionaly expand subst 'if' part bindings | |
| 655 | (when if-var | |
| 656 | (setq sub (substitution-add sub if-var (or (rwl-state-condition state) | |
| 657 | *bool-true*)))) | |
| 658 | (when (condition-check-ok sub) | |
| 659 | (when (if-binding-should-be-printed sch-context) ; if-var | |
| 660 | (pr-used-rule state) | |
| 661 | (print-subst-if-binding-result state sub sch-context)) | |
| 662 | (when (state-is-valid-transition state) | |
| 663 | (push sub (rwl-state-subst state)))) | |
| 594 | ;; expand subst with | |
| 595 | (when rule-pat | |
| 596 | (setq sub (append sub (rule-pat-subst rule-pat)))) | |
| 597 | ;; additionaly expand subst 'if' part bindings | |
| 598 | (when if-var | |
| 599 | (setq sub (substitution-add sub if-var (or (rwl-state-condition state) | |
| 600 | *bool-true*)))) | |
| 601 | (when (condition-check-ok sub) | |
| 602 | (when (if-binding-should-be-printed sch-context) ; if-var | |
| 603 | (pr-used-rule state) | |
| 604 | (print-subst-if-binding-result state sub sch-context)) | |
| 605 | (when (state-is-valid-transition state) | |
| 606 | (push sub (rwl-state-subst state)))) | |
| 664 | 607 | ;; try other patterns untill there's no hope |
| 665 | 608 | (loop |
| 666 | 609 | (multiple-value-setq (gs sub no-match) |
| 667 | 610 | (next-match gs)) |
| 668 | 611 | (when no-match (return)) |
| 669 | ;; expand subst with | |
| 670 | (setq sub (append sub (rule-pat-subst rule-pat))) | |
| 671 | (when if-var | |
| 672 | (setq sub (substitution-add sub if-var (or (rwl-state-condition state) | |
| 673 | *bool-true*)))) | |
| 674 | (when (condition-check-ok sub) | |
| 675 | (when (if-binding-should-be-printed sch-context) ; if-var | |
| 676 | (when (pr-used-rule state) | |
| 677 | (print-subst-if-binding-result state sub sch-context))) | |
| 678 | (when (state-is-valid-transition state) | |
| 679 | (push sub (rwl-state-subst state)))))) | |
| 612 | ;; expand subst with | |
| 613 | (setq sub (append sub (rule-pat-subst rule-pat))) | |
| 614 | (when if-var | |
| 615 | (setq sub (substitution-add sub if-var (or (rwl-state-condition state) | |
| 616 | *bool-true*)))) | |
| 617 | (when (condition-check-ok sub) | |
| 618 | (when (if-binding-should-be-printed sch-context) ; if-var | |
| 619 | (when (pr-used-rule state) | |
| 620 | (print-subst-if-binding-result state sub sch-context))) | |
| 621 | (when (state-is-valid-transition state) | |
| 622 | (push sub (rwl-state-subst state)))))) | |
| 680 | 623 | (not (null (rwl-state-subst state)))))) |
| 681 | 624 | |
| 682 | 625 | (defun pr-used-rule (state) |
| 683 | 626 | (let ((rule-pat (rwl-state-rule-pat state)) |
| 684 | (rule nil)) | |
| 627 | (rule nil)) | |
| 685 | 628 | (unless rule-pat (return-from pr-used-rule nil)) |
| 686 | 629 | (setq rule (rule-pat-rule rule-pat)) |
| 687 | 630 | (unless *print-exec-rule* |
| 688 | 631 | (when (member (axiom-kind rule) .ext-rule-kinds.) |
| 689 | (return-from pr-used-rule nil))) | |
| 690 | (format t "~%=> ") | |
| 691 | (print-axiom-brief rule) | |
| 632 | (return-from pr-used-rule nil))) | |
| 633 | (unless *rwl-search-no-state-report* | |
| 634 | (format t "~%=> ") | |
| 635 | (print-axiom-brief rule)) | |
| 692 | 636 | t)) |
| 693 | 637 | |
| 694 | 638 | (defun print-subst-if-binding-result (state sub sch-context) |
| 695 | 639 | (declare (ignore state)) |
| 696 | 640 | (setf (rwl-sch-context-pr-out? sch-context) t) |
| 697 | (format t "~% ") (print-substitution sub) | |
| 698 | (when (rwl-sch-context-bind sch-context) | |
| 699 | (let ((bimg (substitution-image-simplifying sub (rwl-sch-context-bind sch-context)))) | |
| 700 | (normalize-term bimg) | |
| 701 | (format t "~% --> ") | |
| 702 | (term-print-with-sort bimg)))) | |
| 641 | (unless *rwl-search-no-state-report* | |
| 642 | (format t "~% ") (print-substitution sub) | |
| 643 | (when (rwl-sch-context-bind sch-context) | |
| 644 | (let ((bimg (substitution-image-simplifying sub (rwl-sch-context-bind sch-context)))) | |
| 645 | (normalize-term bimg) | |
| 646 | (format t "~% --> ") | |
| 647 | (term-print-with-sort bimg))))) | |
| 703 | 648 | |
| 704 | 649 | ;;; ****************** |
| 705 | 650 | ;;; SOME UTILs on TERM |
| 769 | 714 | (res nil)) |
| 770 | 715 | ;; make substittion |
| 771 | 716 | (if (sort<= (term-sort term) (term-sort (car vars)) *current-sort-order*) |
| 772 | (push (cons (car vars) term) subst) | |
| 717 | (push (cons (car vars) term) subst) | |
| 773 | 718 | (with-output-chaos-error ('invalid-state) |
| 774 | (format t "withStateEq: sort of term does not match with variable:") | |
| 775 | (format t "~% variable: ") | |
| 776 | (term-print-with-sort (car vars)) | |
| 777 | (format t "~% term: ") | |
| 778 | (term-print-with-sort term))) | |
| 719 | (format t "withStateEq: sort of term does not match with variable:") | |
| 720 | (format t "~% variable: ") | |
| 721 | (term-print-with-sort (car vars)) | |
| 722 | (format t "~% term: ") | |
| 723 | (term-print-with-sort term))) | |
| 779 | 724 | (if (sort<= (term-sort term) (term-sort (cadr vars)) *current-sort-order*) |
| 780 | (push (cons (cadr vars) t1) subst) | |
| 725 | (push (cons (cadr vars) t1) subst) | |
| 781 | 726 | (with-output-chaos-error ('invalid-state) |
| 782 | (format t "withStateEq: sort of term does not match with variable:") | |
| 783 | (format t "~% variable: ") | |
| 784 | (term-print-with-sort (cadr vars)) | |
| 785 | (format t "~% term: ") | |
| 786 | (term-print-with-sort t1))) | |
| 727 | (format t "withStateEq: sort of term does not match with variable:") | |
| 728 | (format t "~% variable: ") | |
| 729 | (term-print-with-sort (cadr vars)) | |
| 730 | (format t "~% term: ") | |
| 731 | (term-print-with-sort t1))) | |
| 787 | 732 | |
| 788 | 733 | ;; apply subst with coping pred |
| 789 | 734 | ;; then reduce |
| 798 | 743 | (normalize-term $$cond) |
| 799 | 744 | $$cond))) |
| 800 | 745 | (when (and res *cexec-trace*) |
| 801 | (format t "~&state predicate returned `true'.")) | |
| 746 | (format t "~%** state predicate returned `true'.")) | |
| 802 | 747 | res)) |
| 803 | 748 | |
| 804 | 749 | (defun cexec-loop-check (term sch-context) |
| 818 | 763 | ;;; |
| 819 | 764 | (defun make-rwl-state-with-hash (target rule-pat sch-context) |
| 820 | 765 | (let* ((ostate-num (cexec-loop-check target sch-context)) |
| 821 | ;; (rule (rule-pat-rule rule-pat)) | |
| 822 | (condition (rule-pat-condition rule-pat)) | |
| 823 | (new-state nil)) | |
| 766 | ;; (rule (rule-pat-rule rule-pat)) | |
| 767 | (condition (rule-pat-condition rule-pat)) | |
| 768 | (new-state nil)) | |
| 824 | 769 | (cond (ostate-num |
| 825 | ;; this means the same state has alredy been generated | |
| 826 | ;; from a node other than this node. | |
| 827 | ;; we create brand new state with the same state number | |
| 828 | (setq new-state (make-rwl-state :state ostate-num | |
| 829 | :term target | |
| 830 | :rule-pat rule-pat | |
| 831 | :subst nil | |
| 832 | :condition condition)) | |
| 833 | (when (or *cexec-trace* *chaos-verbose*) | |
| 834 | (format t "~&* loop")) | |
| 835 | (setf (rwl-state-loop new-state) t)) | |
| 836 | (t (let (;; (state-num (incf (rwl-sch-context-states-so-far sch-context))) | |
| 837 | (state-num (incf .rwl-states-so-far.))) | |
| 770 | ;; this means the same state has alredy been generated | |
| 771 | ;; from a node other than this node. | |
| 772 | ;; we create brand new state with the same state number | |
| 773 | (setq new-state (make-rwl-state :state ostate-num | |
| 774 | :term target | |
| 775 | :rule-pat rule-pat | |
| 776 | :subst nil | |
| 777 | :condition condition)) | |
| 778 | (when (or *cexec-trace* *chaos-verbose*) | |
| 779 | (format t "~%* loop")) | |
| 780 | (setf (rwl-state-loop new-state) t)) | |
| 781 | (t (let ((state-num (incf .rwl-states-so-far.))) | |
| 838 | 782 | (setq new-state (make-rwl-state :state state-num |
| 839 | 783 | :term target |
| 840 | 784 | :rule-pat rule-pat |
| 841 | 785 | :subst nil |
| 842 | :condition condition)) | |
| 786 | :condition condition)) | |
| 843 | 787 | ;; register the term |
| 844 | (when *cexec-debug* | |
| 845 | (format t "~%** hasing state ~D" state-num)) | |
| 788 | (when *cexec-debug* | |
| 789 | (format t "~%** hashing state ~D" state-num)) | |
| 846 | 790 | (cexec-set-hashed-term target state-num)))) |
| 847 | 791 | ;; |
| 848 | 792 | new-state)) |
| 863 | 807 | ;;; APPLY-RULE-CEXEC: rule target -> Bool |
| 864 | 808 | ;;; |
| 865 | 809 | (defun apply-rule-cexec (rule term subst) |
| 866 | (let ((condition (rule-condition rule)) | |
| 867 | (builtin-failure nil)) | |
| 868 | (when (and (is-true? condition) | |
| 869 | (null (rule-id-condition rule))) | |
| 870 | (setq builtin-failure | |
| 871 | (catch 'rule-failure | |
| 872 | (progn | |
| 873 | (term-replace-dd-simple | |
| 874 | term | |
| 875 | (set-term-color | |
| 876 | (substitution-image-simplifying subst | |
| 877 | (rule-rhs rule) | |
| 878 | (rule-need-copy rule) | |
| 879 | :slow))) | |
| 880 | (return-from apply-rule-cexec t))))) | |
| 881 | (when builtin-failure | |
| 882 | (return-from apply-rule-cexec nil)) | |
| 883 | ;; check condition | |
| 884 | (catch 'rule-failure | |
| 885 | (when t | |
| 886 | #|| because we already check the condition is satisfied or not | |
| 887 | ||
| 888 | (and (or (null (rule-id-condition rule)) | |
| 889 | (rule-eval-id-condition subst | |
| 890 | (rule-id-condition rule) | |
| 891 | :slow)) | |
| 892 | (is-true? | |
| 893 | (let (($$cond (set-term-color | |
| 894 | (substitution-image-simplifying subst condition t :slow)))) | |
| 895 | (normalize-term $$cond) | |
| 896 | $$cond))) | |
| 897 | ||# | |
| 898 | ;; the condition is satisfied | |
| 899 | (progn | |
| 900 | (term-replace-dd-simple | |
| 901 | term | |
| 902 | (set-term-color | |
| 903 | (substitution-image-simplifying subst | |
| 904 | (rule-rhs rule) | |
| 905 | (rule-need-copy rule) | |
| 906 | :slow))) | |
| 907 | (return-from apply-rule-cexec t)) | |
| 908 | )) | |
| 909 | ;; failure | |
| 910 | nil)) | |
| 810 | (catch 'rule-failure | |
| 811 | (progn | |
| 812 | (term-replace-dd-simple | |
| 813 | term | |
| 814 | (set-term-color | |
| 815 | (substitution-image-simplifying subst | |
| 816 | (rule-rhs rule) | |
| 817 | (rule-need-copy rule) | |
| 818 | :slow))) | |
| 819 | (return-from apply-rule-cexec t))) | |
| 820 | nil) | |
| 911 | 821 | |
| 912 | 822 | ;;; CEXEC-TERM-1 (state-as-dag) |
| 913 | 823 | ;;; |
| 945 | 855 | (if (rwl-sch-context-zero-trans-allowed sch-context) |
| 946 | 856 | "*" |
| 947 | 857 | "+")))) |
| 948 | (state-is-valid? (state) | |
| 949 | (let ((cond (rwl-state-condition state))) | |
| 950 | (or (null cond) (is-true? cond))))) | |
| 858 | (state-is-valid? (state) | |
| 859 | (let ((cond (rwl-state-condition state))) | |
| 860 | (or (null cond) (is-true? cond))))) | |
| 951 | 861 | ;; |
| 952 | 862 | (unless (state-is-valid? state) |
| 953 | (return-from cexec-term-1 nil)) | |
| 863 | (return-from cexec-term-1 nil)) | |
| 954 | 864 | ;; |
| 955 | 865 | (let ((xterm term) |
| 956 | 866 | (ptrans? (dag-node-subnodes dag))) |
| 967 | 877 | (let ((rule-pats (rwl-state-trans-rules state)) |
| 968 | 878 | (*rewrite-exec-mode* t) |
| 969 | 879 | (sub-states nil) |
| 970 | (real-pats nil)) | |
| 971 | (setq real-pats (remove-if #'(lambda (x) (not (rule-pat-cond-ok x))) rule-pats)) | |
| 972 | (when *cexec-debug* | |
| 973 | (format t "~%++ ~D rule patterns for state" (length rule-pats)) | |
| 974 | (pr-rwl-state state)) | |
| 975 | (when *chaos-verbose* | |
| 976 | (format t "~&-- from [state ~D] " | |
| 977 | (rwl-state-state state)) | |
| 978 | (format t "~D possible transitions....." | |
| 880 | (real-pats nil)) | |
| 881 | (setq real-pats (remove-if #'(lambda (x) (not (rule-pat-cond-ok x))) rule-pats)) | |
| 882 | (when *cexec-debug* | |
| 883 | (format t "~%++ ~D rule patterns for state" (length rule-pats)) | |
| 884 | (pr-rwl-state state)) | |
| 885 | (when *chaos-verbose* | |
| 886 | (format t "~%-- from [state ~D] " | |
| 887 | (rwl-state-state state)) | |
| 888 | (format t "~D possible transitions....." | |
| 979 | 889 | (length real-pats))) |
| 980 | ;; | |
| 890 | ;; | |
| 981 | 891 | (unless rule-pats |
| 982 | 892 | ;; no rules |
| 983 | 893 | (no-more-transition) |
| 994 | 904 | (do* ((rls rule-pats (cdr rls)) |
| 995 | 905 | (rule-pat (car rls) (car rls))) |
| 996 | 906 | ;; ((endp rls)) |
| 997 | ((null rule-pat)) | |
| 907 | ((null rule-pat)) | |
| 998 | 908 | (let* ((target-whole (simple-copy-term xterm)) |
| 999 | 909 | (target (get-target-subterm target-whole |
| 1000 | 910 | (rule-pat-pos rule-pat)))) |
| 1007 | 917 | (when (apply-rule-cexec (rule-pat-rule rule-pat) |
| 1008 | 918 | target |
| 1009 | 919 | (rule-pat-subst rule-pat)) |
| 1010 | #|| | |
| 1011 | (when (rule-pat-cond-ok rule-pat) | |
| 1012 | (incf (rwl-sch-context-trans-so-far sch-context))) | |
| 1013 | ||# | |
| 1014 | (incf (rwl-sch-context-trans-so-far sch-context)) | |
| 920 | #|| | |
| 921 | (when (rule-pat-cond-ok rule-pat) | |
| 922 | (incf (rwl-sch-context-trans-so-far sch-context))) | |
| 923 | ||# | |
| 924 | (incf (rwl-sch-context-trans-so-far sch-context)) | |
| 1015 | 925 | ;; |
| 1016 | 926 | (when *cexec-normalize* |
| 1017 | 927 | (when *cexec-debug* |
| 1018 | (format t "~&.. start doing normalization because cexec normalize is on.~% -- ") | |
| 928 | (format t "~%.. start doing normalization because cexec normalize is on.~% -- ") | |
| 1019 | 929 | (term-print target-whole)) |
| 1020 | 930 | (let ((*rewrite-exec-mode* nil) |
| 1021 | 931 | (xterm (if (and *cexec-trace* *chaos-verbose*) |
| 1022 | 932 | (simple-copy-term target-whole) |
| 1023 | 933 | nil))) |
| 1024 | (mark-term-as-not-lowest-parsed target-whole) | |
| 934 | (mark-term-as-not-lowest-parsed target-whole) | |
| 1025 | 935 | (reset-reduced-flag target-whole) |
| 1026 | 936 | (rewrite* target-whole) |
| 1027 | 937 | (when *cexec-debug* |
| 1044 | 954 | rule-pat |
| 1045 | 955 | sch-context))) |
| 1046 | 956 | (when (and sub-state |
| 1047 | ;; (rule-pat-cond-ok rule-pat) | |
| 1048 | t | |
| 1049 | ) | |
| 1050 | (when *cexec-debug* | |
| 1051 | (format t "~%** used rule pat = ~d" (rule-pat-num rule-pat))) | |
| 957 | ;; (rule-pat-cond-ok rule-pat) | |
| 958 | t | |
| 959 | ) | |
| 960 | (when *cexec-debug* | |
| 961 | (format t "~%** used rule pat = ~d" (rule-pat-num rule-pat))) | |
| 1052 | 962 | (when *cexec-trace* |
| 1053 | 963 | (print-next) |
| 1054 | 964 | (flush-all) |
| 1058 | 968 | (exec-trace-form) |
| 1059 | 969 | (format t " [state ~D] " (rwl-state-state sub-state)) |
| 1060 | 970 | (term-print-with-sort target-whole) |
| 1061 | (print-next) | |
| 1062 | (print-axiom-brief (rule-pat-rule rule-pat)) | |
| 1063 | (print-next) | |
| 1064 | (print-substitution (rule-pat-subst rule-pat))) ; *** | |
| 971 | (print-next) | |
| 972 | (print-axiom-brief (rule-pat-rule rule-pat)) | |
| 973 | (print-next) | |
| 974 | (print-substitution (rule-pat-subst rule-pat))) ; *** | |
| 1065 | 975 | (flush-all)) |
| 1066 | ;; | |
| 1067 | (push sub-state sub-states))))) | |
| 1068 | ) ; done apply all rules | |
| 1069 | ;; | |
| 976 | (push sub-state sub-states)))))) ; done apply all rules | |
| 1070 | 977 | (if sub-states |
| 1071 | 978 | (progn |
| 1072 | 979 | (when *chaos-verbose* |
| 1092 | 999 | (let ((to-do (rwl-sch-context-last-siblings sch-context)) |
| 1093 | 1000 | (found? nil)) |
| 1094 | 1001 | (when *chaos-verbose* |
| 1095 | (format t "~&-- ~D state(s) to be examined --" (length to-do))) | |
| 1002 | (format t "~%-- ~D state(s) to be examined --" (length to-do))) | |
| 1096 | 1003 | ;; |
| 1097 | 1004 | ;; 1. check for each state if it satisfies the target conditions |
| 1098 | 1005 | ;; |
| 1123 | 1030 | (rwl-sch-context-answers sch-context)) |
| 1124 | 1031 | ;; |
| 1125 | 1032 | (unless *rwl-search-no-state-report* |
| 1126 | (format t "~&~%** Found [state ~D] " (rwl-state-state state)) | |
| 1033 | (format t "~%** Found [state ~D] " (rwl-state-state state)) | |
| 1127 | 1034 | (term-print-with-sort (rwl-state-term state)) |
| 1128 | (dolist (sub (rwl-state-subst state)) | |
| 1129 | (print-subst-if-binding-result state sub sch-context) | |
| 1130 | ) | |
| 1035 | (dolist (sub (rwl-state-subst state)) | |
| 1036 | (print-subst-if-binding-result state sub sch-context) | |
| 1037 | ) | |
| 1131 | 1038 | (format t "~&")) |
| 1132 | 1039 | (setf (sch-node-is-solution node) t) ; mark the node as solution |
| 1133 | 1040 | (incf (rwl-sch-context-sol-found sch-context)) |
| 1138 | 1045 | ;; reaches to the # solutions required. |
| 1139 | 1046 | ;; mesg |
| 1140 | 1047 | (unless *rwl-search-no-state-report* |
| 1141 | (format t "~&-- found required number of solutions ~D." | |
| 1048 | (format t "~%-- found required number of solutions ~D." | |
| 1142 | 1049 | (rwl-sch-context-max-sol sch-context))) |
| 1143 | 1050 | (return-from rwl-step-forward-1 (values :max-solutions nil)))))) |
| 1144 | 1051 | ) ; continue |
| 1147 | 1054 | ;; 2. perform the next transitions for each node |
| 1148 | 1055 | ;; |
| 1149 | 1056 | (when *chaos-verbose* |
| 1150 | (format t "~&** precompute the next all states......")) | |
| 1057 | (format t "~%** precompute the next all states......")) | |
| 1151 | 1058 | ;; increment depth |
| 1152 | 1059 | (incf (rwl-sch-context-cur-depth sch-context)) |
| 1153 | 1060 | ;; |
| 1163 | 1070 | (if (rwl-state-loop state) |
| 1164 | 1071 | ;; mark `done' if the state is already |
| 1165 | 1072 | ;; visited before.. |
| 1166 | (progn | |
| 1167 | (setf (sch-node-done dag) t) | |
| 1168 | (when (rwl-sch-context-if sch-context) | |
| 1169 | (when *cexec-debug* | |
| 1170 | (format t "~%** calling check condition for reporting only.")) | |
| 1171 | (rwl-sch-check-conditions dag sch-context))) ; for reporting only | |
| 1073 | (progn | |
| 1074 | (setf (sch-node-done dag) t) | |
| 1075 | (when (rwl-sch-context-if sch-context) | |
| 1076 | (when *cexec-debug* | |
| 1077 | (format t "~%** calling check condition for reporting only.")) | |
| 1078 | (rwl-sch-check-conditions dag sch-context))) ; for reporting only | |
| 1172 | 1079 | (push dag nexts)))) |
| 1173 | ;; (format t "~&nexts=~a" nexts) | |
| 1174 | 1080 | (setq next-subs (nconc next-subs nexts)))) |
| 1175 | 1081 | ;; |
| 1176 | 1082 | ;; 3. lastly, set the next states as `last-siblings' |
| 1177 | 1083 | ;; |
| 1178 | 1084 | (setf (rwl-sch-context-last-siblings sch-context) next-subs) |
| 1179 | 1085 | ;; |
| 1180 | ;; (or found? next-subs :no-more) | |
| 1181 | 1086 | (values found? (if next-subs |
| 1182 | 1087 | nil |
| 1183 | 1088 | :no-more))))) |
| 1184 | 1089 | |
| 1185 | 1090 | ;;; ********* |
| 1186 | ;;; TOP LEVEL | |
| 1091 | ;;; TOP LEVEL functions | |
| 1187 | 1092 | ;;; ********* |
| 1188 | 1093 | (defun make-anything-is-ok-term () |
| 1189 | 1094 | (make-variable-term *cosmos* (gensym "Univ"))) |
| 1192 | 1097 | &optional cond |
| 1193 | 1098 | pred-pat |
| 1194 | 1099 | module |
| 1195 | bind | |
| 1196 | if) | |
| 1100 | bind | |
| 1101 | if) | |
| 1197 | 1102 | (with-in-module (module) |
| 1198 | 1103 | (unless t2 |
| 1199 | 1104 | (setq t2 (make-anything-is-ok-term))) |
| 1200 | (let ((svars (term-variables t1)) ; variables in source | |
| 1201 | (pvars (term-variables t2)) ; variables in pattern | |
| 1202 | (cvars (if cond ; variables in suchThat | |
| 1203 | (term-variables cond) | |
| 1204 | nil)) | |
| 1205 | (predvars (if pred-pat ; variables in stateEq | |
| 1206 | (term-variables pred-pat) | |
| 1207 | nil)) | |
| 1208 | (ifvars (if if | |
| 1209 | (term-variables if) | |
| 1210 | nil)) | |
| 1211 | (allvars nil) | |
| 1212 | (.rules-so-far. 0)) | |
| 1105 | ;; t1 and t2 must be in the same connected component | |
| 1106 | (let ((t1-sort (term-sort t1)) | |
| 1107 | (t2-sort (term-sort t2))) | |
| 1108 | (unless (is-in-same-connected-component t1-sort t2-sort *current-sort-order*) | |
| 1109 | (with-output-chaos-error ('invalid-sort) | |
| 1110 | (format t "Sorts of the source term and the target pattern must be in the same connected component.") | |
| 1111 | (format t "~% Source term : ") | |
| 1112 | (term-print-with-sort t1) | |
| 1113 | (format t "~& Target pattern: ") | |
| 1114 | (term-print-with-sort t2)))) | |
| 1115 | (let ((svars (term-variables t1)) ; variables in source | |
| 1116 | (pvars (term-variables t2)) ; variables in pattern | |
| 1117 | (cvars (if cond ; variables in suchThat | |
| 1118 | (term-variables cond) | |
| 1119 | nil)) | |
| 1120 | (predvars (if pred-pat ; variables in stateEq | |
| 1121 | (term-variables pred-pat) | |
| 1122 | nil)) | |
| 1123 | (ifvars (if if | |
| 1124 | (term-variables if) | |
| 1125 | nil)) | |
| 1126 | (allvars nil) | |
| 1127 | (.rules-so-far. 0)) | |
| 1213 | 1128 | (setq allvars (union svars (union pvars ifvars))) |
| 1214 | 1129 | ;; check suchThat |
| 1215 | 1130 | (when cvars |
| 1216 | (unless (subsetp cvars allvars) | |
| 1217 | (with-output-chaos-error ('invalid-such-that) | |
| 1218 | (format t "`suchThat' introduces new variable(s).")))) | |
| 1131 | (unless (subsetp cvars allvars) | |
| 1132 | (with-output-chaos-error ('invalid-such-that) | |
| 1133 | (format t "`suchThat' introduces new variable(s).")))) | |
| 1219 | 1134 | ;; check variables |
| 1220 | 1135 | (dolist (v svars) |
| 1221 | (when (memq v pvars) | |
| 1222 | (with-output-chaos-error ('subject-var-occus) | |
| 1223 | (format t "Variable ") | |
| 1224 | (term-print-with-sort v) | |
| 1225 | ;; (format t " in subject term occurs in target pattern or coditions..") | |
| 1226 | (format t " in subject term occurs in target pattern.") | |
| 1227 | (format t "~& subject: ") | |
| 1228 | (term-print-with-sort t1) | |
| 1229 | (format t "~& pattern: ") | |
| 1230 | (term-print-with-sort t2)))) | |
| 1136 | (when (memq v pvars) | |
| 1137 | (with-output-chaos-error ('subject-var-occus) | |
| 1138 | (format t "Variable ") | |
| 1139 | (term-print-with-sort v) | |
| 1140 | ;; (format t " in subject term occurs in target pattern or coditions..") | |
| 1141 | (format t " in subject term occurs in target pattern.") | |
| 1142 | (format t "~& subject: ") | |
| 1143 | (term-print-with-sort t1) | |
| 1144 | (format t "~& pattern: ") | |
| 1145 | (term-print-with-sort t2)))) | |
| 1231 | 1146 | (dolist (v predvars) |
| 1232 | (when (or (memq v svars) | |
| 1233 | (memq v pvars) | |
| 1234 | (memq v cvars)) | |
| 1235 | (with-output-chaos-error ('invalid-stateEq) | |
| 1236 | (format t "Variable ") | |
| 1237 | (term-print-with-sort v) | |
| 1238 | (format t " in 'stateEq' occurs in subject term or target pattern or 'suchThat'..")))) | |
| 1147 | (when (or (memq v svars) | |
| 1148 | (memq v pvars) | |
| 1149 | (memq v cvars)) | |
| 1150 | (with-output-chaos-error ('invalid-stateEq) | |
| 1151 | (format t "Variable ") | |
| 1152 | (term-print-with-sort v) | |
| 1153 | (format t " in 'stateEq' occurs in subject term or target pattern or 'suchThat'..")))) | |
| 1239 | 1154 | ;; |
| 1240 | 1155 | (let ((sch-context (make-rwl-sch-context |
| 1241 | :module module | |
| 1242 | :term t1 | |
| 1243 | :pattern t2 | |
| 1244 | :condition cond | |
| 1245 | :zero-trans-allowed zero? | |
| 1246 | :final-check final? | |
| 1247 | :max-sol max-result | |
| 1248 | :max-depth max-depth | |
| 1249 | :state-predicate nil | |
| 1250 | :bind bind | |
| 1251 | :if if)) | |
| 1252 | (root nil) | |
| 1253 | (res nil) | |
| 1254 | (no-more nil) | |
| 1255 | (found? nil)) | |
| 1256 | (flet ((make-state-pred-pat () | |
| 1257 | (cond (pred-pat | |
| 1258 | (let ((vars (term-variables pred-pat))) | |
| 1259 | (unless (sort= (term-sort pred-pat) | |
| 1260 | *Bool-sort*) | |
| 1261 | (with-output-chaos-error ('invalid-sort) | |
| 1262 | (format t "state equality must be of a term of sort Bool."))) | |
| 1263 | (unless (= 2 (length vars)) | |
| 1264 | (with-output-chaos-error ('number-of-variables) | |
| 1265 | (format t "state equality pattern must have exactly 2 different variables in it, but ~D given." (length vars)))) | |
| 1266 | #|| | |
| 1267 | (when (variable= (car vars) (cadr vars)) | |
| 1268 | (with-output-chaos-error ('invalid-variables) | |
| 1269 | (format t "variables in state equality pattern must be diffrent from each other."))) | |
| 1270 | ||# | |
| 1271 | (unless (sort= (variable-sort (car vars)) | |
| 1272 | (variable-sort (cadr vars))) | |
| 1273 | (with-output-chaos-error ('different-variable-sort) | |
| 1274 | (format t "variables in state equality pattern must be of the same sort."))) | |
| 1275 | (unless (sort<= (term-sort t2) (term-sort (car vars)) | |
| 1276 | *current-sort-order*) | |
| 1277 | (with-output-chaos-error ('invalid-variable-sort) | |
| 1278 | (format t "invalid sort of variable in state equality pattern."))) | |
| 1279 | (cons pred-pat vars))) | |
| 1280 | (t nil)))) | |
| 1281 | ;; | |
| 1282 | ;; initialize search context | |
| 1283 | ;; | |
| 1284 | (setf (rwl-sch-context-cur-depth sch-context) 0) | |
| 1285 | (setf (rwl-sch-context-sol-found sch-context) 0) | |
| 1286 | ;; (setf (rwl-sch-context-states-so-far sch-context) 0) | |
| 1287 | (setf (rwl-sch-context-trans-so-far sch-context) 0) | |
| 1288 | (setq root (create-sch-node (make-rwl-state :state 0 :term t1))) | |
| 1289 | (setf (rwl-sch-context-root sch-context) root) | |
| 1290 | (setf (rwl-sch-context-last-siblings sch-context) (list root)) | |
| 1291 | (setf (rwl-sch-context-answers sch-context) nil) | |
| 1292 | ;; state equality predicate | |
| 1293 | (setf (rwl-sch-context-state-predicate sch-context) | |
| 1294 | (make-state-pred-pat)) | |
| 1295 | ;; bind context to global for later use... | |
| 1296 | (setq .rwl-sch-context. sch-context) | |
| 1297 | (push sch-context .rwl-context-stack.) | |
| 1298 | ;; term hash | |
| 1299 | (initialize-cexec-term-hash) | |
| 1300 | (cexec-set-hashed-term t1 0) | |
| 1301 | ;; | |
| 1302 | ;; do the search | |
| 1303 | ;; | |
| 1304 | (when *cexec-debug* | |
| 1305 | (print sch-context)) | |
| 1306 | (loop | |
| 1307 | (when *chaos-verbose* | |
| 1308 | (format t "~&** << level ~D >>" (rwl-sch-context-cur-depth sch-context))) | |
| 1309 | ;; | |
| 1310 | (multiple-value-setq (res no-more) | |
| 1311 | (rwl-step-forward-1 sch-context)) | |
| 1312 | ;; (setq res (rwl-step-forward-1 sch-context)) | |
| 1313 | (case res | |
| 1314 | (:max-transitions (return nil)) ; exit loop | |
| 1315 | (:max-solutions | |
| 1316 | (setq found? t) | |
| 1317 | (return nil)) ; exit loop | |
| 1318 | (:found | |
| 1319 | (setq found? t)) ; continue.. | |
| 1320 | (otherwise nil)) | |
| 1321 | (when no-more | |
| 1322 | (unless *rwl-search-no-state-report* | |
| 1323 | (format t "~&~%** No more possible transitions.")) | |
| 1324 | (return nil)) ; exit if no more ... | |
| 1325 | ;; one step deeper | |
| 1326 | (when (> (rwl-sch-context-cur-depth sch-context) | |
| 1327 | (rwl-sch-context-max-depth sch-context)) | |
| 1328 | (format t "~&-- reached to the specified search depth ~D." | |
| 1329 | (rwl-sch-context-max-depth sch-context)) | |
| 1330 | (return-from rwl-search* | |
| 1331 | (if (rwl-sch-context-if sch-context) | |
| 1332 | (if (rwl-sch-context-pr-out? sch-context) | |
| 1333 | :found | |
| 1334 | nil) | |
| 1335 | (if found? :found :max-depth)))) | |
| 1336 | ) ; end loop | |
| 1337 | ;; any solution? | |
| 1338 | (cond ((rwl-sch-context-if sch-context) | |
| 1339 | (if (rwl-sch-context-pr-out? sch-context) | |
| 1340 | :found | |
| 1341 | nil)) | |
| 1342 | (t (if found? | |
| 1343 | ;; yes | |
| 1344 | :found | |
| 1345 | ;; no | |
| 1346 | res)))))))) | |
| 1156 | :module module | |
| 1157 | :term t1 | |
| 1158 | :pattern t2 | |
| 1159 | :condition cond | |
| 1160 | :zero-trans-allowed zero? | |
| 1161 | :final-check final? | |
| 1162 | :max-sol max-result | |
| 1163 | :max-depth max-depth | |
| 1164 | :state-predicate nil | |
| 1165 | :bind bind | |
| 1166 | :if if)) | |
| 1167 | (root nil) | |
| 1168 | (res nil) | |
| 1169 | (no-more nil) | |
| 1170 | (found? nil)) | |
| 1171 | (flet ((make-state-pred-pat () | |
| 1172 | (cond (pred-pat | |
| 1173 | (let ((vars (term-variables pred-pat))) | |
| 1174 | (unless (sort= (term-sort pred-pat) | |
| 1175 | *Bool-sort*) | |
| 1176 | (with-output-chaos-error ('invalid-sort) | |
| 1177 | (format t "state equality must be of a term of sort Bool."))) | |
| 1178 | (unless (= 2 (length vars)) | |
| 1179 | (with-output-chaos-error ('number-of-variables) | |
| 1180 | (format t "state equality pattern must have exactly 2 different variables in it, but ~D given." (length vars)))) | |
| 1181 | (unless (sort= (variable-sort (car vars)) | |
| 1182 | (variable-sort (cadr vars))) | |
| 1183 | (with-output-chaos-error ('different-variable-sort) | |
| 1184 | (format t "variables in state equality pattern must be of the same sort."))) | |
| 1185 | (unless (sort<= (term-sort t2) (term-sort (car vars)) | |
| 1186 | *current-sort-order*) | |
| 1187 | (with-output-chaos-error ('invalid-variable-sort) | |
| 1188 | (format t "invalid sort of variable in state equality pattern."))) | |
| 1189 | (cons pred-pat vars))) | |
| 1190 | (t nil)))) | |
| 1191 | ;; | |
| 1192 | ;; initialize search context | |
| 1193 | ;; | |
| 1194 | (setf (rwl-sch-context-cur-depth sch-context) 0 | |
| 1195 | (rwl-sch-context-sol-found sch-context) 0 | |
| 1196 | (rwl-sch-context-trans-so-far sch-context) 0 | |
| 1197 | root (create-sch-node (make-rwl-state :state 0 :term t1))) | |
| 1198 | (setf (rwl-sch-context-root sch-context) root | |
| 1199 | (rwl-sch-context-last-siblings sch-context) (list root) | |
| 1200 | (rwl-sch-context-answers sch-context) nil) | |
| 1201 | ;; state equality predicate | |
| 1202 | (setf (rwl-sch-context-state-predicate sch-context) (make-state-pred-pat)) | |
| 1203 | ;; bind context to global for later use... | |
| 1204 | (setf .rwl-sch-context. sch-context) | |
| 1205 | (push sch-context .rwl-context-stack.) | |
| 1206 | ;; term hash | |
| 1207 | (initialize-cexec-term-hash) | |
| 1208 | (cexec-set-hashed-term t1 0) | |
| 1209 | ;; | |
| 1210 | ;; do the search | |
| 1211 | ;; | |
| 1212 | (when *cexec-debug* | |
| 1213 | (print sch-context)) | |
| 1214 | (loop | |
| 1215 | (when *chaos-verbose* | |
| 1216 | (format t "~%** << level ~D >>" (rwl-sch-context-cur-depth sch-context))) | |
| 1217 | (multiple-value-setq (res no-more) | |
| 1218 | (rwl-step-forward-1 sch-context)) | |
| 1219 | (case res | |
| 1220 | (:max-transitions (return nil)) ; exit loop | |
| 1221 | (:max-solutions | |
| 1222 | (setq found? t) | |
| 1223 | (return nil)) ; exit loop | |
| 1224 | (:found | |
| 1225 | (setq found? t)) ; continue.. | |
| 1226 | (otherwise nil)) | |
| 1227 | (when no-more | |
| 1228 | (unless *rwl-search-no-state-report* | |
| 1229 | (format t "~%** No more possible transitions.")) | |
| 1230 | (return nil)) ; exit if no more ... | |
| 1231 | ;; one step deeper | |
| 1232 | (when (> (rwl-sch-context-cur-depth sch-context) | |
| 1233 | (rwl-sch-context-max-depth sch-context)) | |
| 1234 | (unless *rwl-search-no-state-report* | |
| 1235 | (format t "~%-- reached to the specified search depth ~D." | |
| 1236 | (rwl-sch-context-max-depth sch-context))) | |
| 1237 | (return-from rwl-search* | |
| 1238 | (if (rwl-sch-context-if sch-context) | |
| 1239 | (if (rwl-sch-context-pr-out? sch-context) | |
| 1240 | :found | |
| 1241 | nil) | |
| 1242 | (if found? :found :max-depth))))) ; end loop | |
| 1243 | ;; any solution? | |
| 1244 | (cond ((rwl-sch-context-if sch-context) | |
| 1245 | (if (rwl-sch-context-pr-out? sch-context) | |
| 1246 | :found | |
| 1247 | nil)) | |
| 1248 | (t (if found? | |
| 1249 | ;; yes | |
| 1250 | :found | |
| 1251 | ;; no | |
| 1252 | res)))))))) | |
| 1347 | 1253 | |
| 1348 | 1254 | ;;; report-rwl-result |
| 1349 | 1255 | ;;; |
| 1401 | 1307 | (setq found? t)) |
| 1402 | 1308 | (otherwise nil)) |
| 1403 | 1309 | ;; one step deeper |
| 1404 | (incf (rwl-sch-context-cur-depth sch-context)) | |
| 1405 | ) ; end loop | |
| 1310 | (incf (rwl-sch-context-cur-depth sch-context))) ; end loop | |
| 1406 | 1311 | (if found? |
| 1407 | 1312 | :found |
| 1408 | 1313 | res)))) |
| 1417 | 1322 | (final? nil) |
| 1418 | 1323 | (cond nil) |
| 1419 | 1324 | (pred nil) |
| 1420 | (bind nil) | |
| 1421 | ;; the followings are experimental | |
| 1422 | (if nil)) | |
| 1423 | (let ((module (or *current-module* *last-module*)) | |
| 1325 | (bind nil) | |
| 1326 | ;; the followings are experimental | |
| 1327 | (if nil)) | |
| 1328 | (let ((module (get-context-module)) | |
| 1424 | 1329 | max-r |
| 1425 | 1330 | max-d) |
| 1426 | (unless module | |
| 1427 | (with-output-chaos-error ('no-context) | |
| 1428 | (format t "no context module.."))) | |
| 1429 | 1331 | (if (integerp max-result) |
| 1430 | 1332 | (setq max-r max-result) |
| 1431 | 1333 | (if (term-is-builtin-constant? max-result) |
| 1438 | 1340 | (setq max-d most-positive-fixnum))) |
| 1439 | 1341 | (when (and if (not (term-is-variable? if))) |
| 1440 | 1342 | (with-output-chaos-warning () |
| 1441 | (format t "The `if' part is not a varible of sort BOOL, `if' binding is ignored : ") | |
| 1442 | (print-next) | |
| 1443 | (term-print if) | |
| 1444 | (setq if nil))) | |
| 1343 | (format t "The `if' part is not a varible of sort BOOL, `if' binding is ignored : ") | |
| 1344 | (print-next) | |
| 1345 | (term-print if) | |
| 1346 | (setq if nil))) | |
| 1445 | 1347 | ;; *** |
| 1446 | 1348 | ;; (clear-term-memo-table *term-memo-table*) |
| 1447 | 1349 | ;; *** |
| 1451 | 1353 | (rewrite* term))) |
| 1452 | 1354 | ;; |
| 1453 | 1355 | (when *cexec-debug* |
| 1454 | (format t "~&* CEXEC: ") | |
| 1356 | (format t "~%* CEXEC: ") | |
| 1455 | 1357 | (term-print-with-sort term)) |
| 1456 | 1358 | ;; |
| 1457 | 1359 | (let ((*clean-memo-in-normalize* nil)) |
| 1458 | 1360 | (report-rwl-result |
| 1459 | 1361 | (rwl-search* term pattern max-r max-d zero? final? cond pred module bind if))))) |
| 1460 | 1362 | |
| 1461 | ;;; | |
| 1462 | 1363 | ;;; rwl-check-one-step-reachability : term term -> { t | nil } |
| 1463 | 1364 | ;;; working hourse of => |
| 1464 | 1365 | ;;; |
| 1465 | 1366 | (defun rwl-check-one-step-reachability (X Y) |
| 1466 | 1367 | (declare (type term X Y)) |
| 1467 | 1368 | (let ((*clean-memo-in-normalize* nil) |
| 1468 | (*chaos-quiet* t)) | |
| 1369 | (*chaos-quiet* t)) | |
| 1469 | 1370 | (report-rwl-result |
| 1470 | 1371 | (rwl-search* X Y 1 1 t nil nil nil *current-module* nil nil)))) |
| 1471 | 1372 | |
| 1483 | 1384 | (defun rwl-cont (ast) |
| 1484 | 1385 | (rwl-continue+ (%continue-num ast))) |
| 1485 | 1386 | |
| 1486 | ;;; | |
| 1487 | 1387 | ;;; for downward compatibility |
| 1488 | 1388 | ;;; |
| 1489 | 1389 | (defun nat*-to-max-option (term &optional (infinite most-positive-fixnum)) |
| 1495 | 1395 | (multiple-value-bind (max sym) |
| 1496 | 1396 | (nat*-to-max-option max-depth) |
| 1497 | 1397 | (let ((final? nil) |
| 1498 | (zero? nil) | |
| 1499 | ) | |
| 1398 | (zero? nil)) | |
| 1500 | 1399 | (case-equal sym |
| 1501 | 1400 | ("!" (setq final? t)) |
| 1502 | 1401 | ("*" (setq zero? t)) |
| 0 | 0 | ;;;-*-Mode:LISP; Package: CHAOS; Base:10; Syntax:Common-lisp -*- |
| 1 | 1 | ;;; |
| 2 | ;;; Copyright (c) 2000-2014, Toshimi Sawada. All rights reserved. | |
| 2 | ;;; Copyright (c) 2000-2015, Toshimi Sawada. All rights reserved. | |
| 3 | 3 | ;;; |
| 4 | 4 | ;;; Redistribution and use in source and binary forms, with or without |
| 5 | 5 | ;;; modification, are permitted provided that the following conditions |
| 27 | 27 | ;;; |
| 28 | 28 | (in-package :chaos) |
| 29 | 29 | #|============================================================================= |
| 30 | System:CHAOS | |
| 31 | Module:thstuff | |
| 32 | File:citp.lisp | |
| 30 | System:CHAOS | |
| 31 | Module:thstuff | |
| 32 | File:citp.lisp | |
| 33 | 33 | =============================================================================|# |
| 34 | 34 | #-:chaos-debug |
| 35 | 35 | (declaim (optimize (speed 3) (safety 0) #-GCL (debug 0))) |
| 71 | 71 | ;;; |
| 72 | 72 | (defun citp-parse-apply (args) |
| 73 | 73 | (let ((tactic-forms nil) |
| 74 | (tactics nil) | |
| 75 | (target nil)) | |
| 74 | (tactics nil) | |
| 75 | (target nil)) | |
| 76 | 76 | (cond ((string-equal (car (second args)) "to") |
| 77 | (setq target (car (second (second args)))) | |
| 78 | (setq tactic-forms (second (third args)))) | |
| 79 | (t (setq tactic-forms (second (second args))))) | |
| 77 | (setq target (car (second (second args)))) | |
| 78 | (setq tactic-forms (second (third args)))) | |
| 79 | (t (setq tactic-forms (second (second args))))) | |
| 80 | 80 | (dolist (tac tactic-forms) |
| 81 | 81 | (let ((tactic (get-tactic tac))) |
| 82 | (setq tactics (nconc tactics tactic)))) | |
| 82 | (setq tactics (nconc tactics tactic)))) | |
| 83 | 83 | (cons target tactics))) |
| 84 | 84 | |
| 85 | 85 | ;;; citp-parse-ind-on |
| 91 | 91 | (with-in-module (*current-module*) |
| 92 | 92 | (let ((vars nil)) |
| 93 | 93 | (dolist (var-decl (fourth args)) |
| 94 | (let ((var (simple-parse-from-string var-decl))) | |
| 95 | (when (term-ill-defined var) | |
| 96 | (with-output-chaos-error ('no-parse) | |
| 97 | (format t "Illegal variable form: ~s" var-decl))) | |
| 98 | (unless (term-is-variable? var) | |
| 99 | (with-output-chaos-error ('no-var) | |
| 100 | (format t "Invalid argument to ':ind' command: ~s" var-decl))) | |
| 101 | (push var vars))) | |
| 94 | (let ((var (simple-parse-from-string var-decl))) | |
| 95 | (when (term-ill-defined var) | |
| 96 | (with-output-chaos-error ('no-parse) | |
| 97 | (format t "Illegal variable form: ~s" var-decl))) | |
| 98 | (unless (term-is-variable? var) | |
| 99 | (with-output-chaos-error ('no-var) | |
| 100 | (format t "Invalid argument to ':ind' command: ~s" var-decl))) | |
| 101 | (push var vars))) | |
| 102 | 102 | (nreverse vars)))) |
| 103 | 103 | |
| 104 | 104 | ;;; |
| 125 | 125 | |
| 126 | 126 | (defun citp-parse-init (args) |
| 127 | 127 | (let ((target-form (make-axiom-pattern (second args))) |
| 128 | (subst-list (fifth args)) | |
| 129 | (subst-pairs nil)) | |
| 128 | (subst-list (fifth args)) | |
| 129 | (subst-pairs nil)) | |
| 130 | 130 | (dolist (subst-form subst-list) |
| 131 | 131 | (unless (atom subst-form) |
| 132 | (push (cons (first subst-form) (third subst-form)) subst-pairs))) | |
| 132 | (push (cons (first subst-form) (third subst-form)) subst-pairs))) | |
| 133 | 133 | (with-citp-debug () |
| 134 | 134 | (format t "~%[:init] target = ~s" target-form) |
| 135 | 135 | (format t "~% subst = ~s" subst-pairs)) |
| 136 | 136 | (list target-form subst-pairs))) |
| 137 | 137 | |
| 138 | ;;; :imply [<label>] by { <var> <- <term>; ...<var> <- <term>; } | |
| 139 | ;;; | |
| 140 | (defun citp-parse-imp (args) | |
| 141 | (citp-parse-init args)) | |
| 142 | (defun eval-citp-imp (arg) | |
| 143 | (declare (ignore arg)) | |
| 144 | nil) | |
| 145 | ||
| 138 | 146 | ;;; :cp |
| 139 | 147 | ;;; (":cp" ("[" ("label-1") "]") "><" ("[" ("label-2") "]")) |
| 140 | 148 | ;;; (":cp" ("(" ("ceq" ("LHS") "=" ("RHS") "if" ("C") ".") ")") |
| 142 | 150 | ;;; |
| 143 | 151 | (defun citp-parse-critical-pair (args) |
| 144 | 152 | (let ((pat-1 (make-axiom-pattern (second args))) |
| 145 | (pat-2 (make-axiom-pattern (fourth args)))) | |
| 153 | (pat-2 (make-axiom-pattern (fourth args)))) | |
| 146 | 154 | (with-citp-debug () |
| 147 | 155 | (format t "~%[cp] ~s" pat-1) |
| 148 | 156 | (format t "~% ~s" pat-2)) |
| 173 | 181 | ;;; |
| 174 | 182 | (defun citp-parse-red (e) |
| 175 | 183 | (let (goal-name |
| 176 | preterm | |
| 177 | mode) | |
| 184 | preterm | |
| 185 | mode) | |
| 178 | 186 | (case-equal (first e) |
| 179 | ((":red" ":lred" "lred") (setq mode :red)) | |
| 180 | ((":exec") (setq mode :exec)) | |
| 181 | ((":bred") (setq mode :bred))) | |
| 187 | ((":red" ":lred" "lred") (setq mode :red)) | |
| 188 | ((":exec") (setq mode :exec)) | |
| 189 | ((":bred") (setq mode :bred))) | |
| 182 | 190 | (if (= 4 (length e)) |
| 183 | (progn | |
| 184 | (setq goal-name (cadr (cadr e))); (find-goal-node *proof-tree* (cadr (cadr e))) | |
| 185 | (setq preterm (nth 2 e))) | |
| 191 | (progn | |
| 192 | (setq goal-name (cadr (cadr e))) | |
| 193 | (setq preterm (nth 2 e))) | |
| 186 | 194 | (progn |
| 187 | (setq goal-name nil) | |
| 188 | (setq preterm (nth 1 e)))) | |
| 195 | (setq goal-name nil) | |
| 196 | (setq preterm (nth 1 e)))) | |
| 189 | 197 | (list mode goal-name preterm))) |
| 190 | 198 | |
| 191 | 199 | ;;; |
| 195 | 203 | (second args)) |
| 196 | 204 | |
| 197 | 205 | ;;; |
| 206 | ;;; citp-parse-normalize-init | |
| 207 | ;;; :normalize {on | off} | |
| 208 | (defun citp-parse-normalize (args) | |
| 209 | (second args)) | |
| 210 | ||
| 198 | 211 | ;;; citp-parse-ctf |
| 199 | 212 | ;;; :ctf { eq <term> = <term> .} |
| 213 | ;;; (":ctf" ("{" ("eq" ("1" ">" "2") "=" ("true") ".") "}")) | |
| 214 | ;;; :ctf [ <term> . ] | |
| 215 | ;;; (":ctf" ("[" ("1" ">" "2") "." "]")) | |
| 216 | ;;; ==> (form . (term? . :ctf-?)) | |
| 200 | 217 | ;;; |
| 201 | 218 | (defun citp-parse-ctf (args) |
| 202 | (let ((ax nil)) | |
| 203 | (setq ax (parse-module-element-1 (third args))) | |
| 204 | ax)) | |
| 219 | (let ((form (second (second args))) | |
| 220 | (term? (equal (first (second args)) "["))) | |
| 221 | (if (equal (first args) ":ctf-") | |
| 222 | (cons form (cons term? :dash)) | |
| 223 | (cons form (cons term? nil))))) | |
| 205 | 224 | |
| 206 | 225 | ;;; citp-parse-csp |
| 207 | 226 | ;;; :csp { <axiom> ... } |
| 208 | 227 | ;;; |
| 209 | 228 | (defun citp-parse-csp (args) |
| 210 | (let ((ax-decls nil)) | |
| 229 | (let ((ax-decls nil) | |
| 230 | (dash? (equal (car args) ":csp-"))) | |
| 211 | 231 | (dolist (elem (third args)) |
| 212 | (push (parse-module-element-1 elem) ax-decls)) | |
| 213 | (nreverse ax-decls))) | |
| 214 | ||
| 215 | ;;; | |
| 232 | (push elem ax-decls)) | |
| 233 | (cons (nreverse ax-decls) dash?))) | |
| 234 | ||
| 235 | ;;; citp-parse-define | |
| 236 | ;;; :def <symbol> = <ctf> | <csp> | |
| 237 | ;;; | |
| 238 | ;;; (":def" "cf1" "=" (":ctf" ("[" (<Term>) "." "]"))) | |
| 239 | ;;; ==> (:ctf "cf1" nil (:term (<Term>))) | |
| 240 | ;;; (":def" "cf2" "=" (":ctf-" ("{" (<Equation>) "." "}"))) | |
| 241 | ;;; ==> (:ctf "cf2" t (:eq (<Equation>))) | |
| 242 | ;;; (":def" "sp1" "=" (":csp" "{" ((<Equation> ".") (<Equation> ".")) "}")) | |
| 243 | ;;; ==> (:csp "sp1" nil ((<Equation> ".") (<Equation> "."))) | |
| 244 | ;;; (":def" "tactic-1" "=" ("(" ("si" "rd" "tc") ")")) | |
| 245 | ;;; ==> (:seq "tactic-1" ("si" "rd" "tc")) | |
| 246 | ;;; | |
| 247 | (defun citp-parse-define (args) | |
| 248 | (flet ((name-to-com (name) | |
| 249 | (cond ((equal name "(") | |
| 250 | :seq) | |
| 251 | ((equal (subseq name 0 4) ":ctf") | |
| 252 | :ctf) | |
| 253 | ((equal (subseq name 0 4) ":csp") | |
| 254 | :csp) | |
| 255 | (t (with-output-chaos-error ('invalid-def) | |
| 256 | (format t "Internal error, :def accepted ~a" name)))))) | |
| 257 | (let* ((name (second args)) | |
| 258 | (com-name (first (fourth args))) | |
| 259 | (command (name-to-com com-name)) | |
| 260 | (dash (> (length com-name) 4)) | |
| 261 | (body-form (if (eq command :ctf) | |
| 262 | (if (equal "[" (first (second (fourth args)))) | |
| 263 | (list :term (second (second (fourth args)))) | |
| 264 | (list :eq (second (second (fourth args))))) | |
| 265 | (if (eq command :csp) | |
| 266 | (third (fourth args)) | |
| 267 | ;; :seq | |
| 268 | (second (fourth args)))))) | |
| 269 | (list command name dash body-form)))) | |
| 270 | ||
| 216 | 271 | ;;; { :show | :describe } <something> |
| 217 | 272 | ;;; |
| 218 | 273 | (defun citp-parse-show (inp) |
| 219 | 274 | (let ((tag (car inp)) |
| 220 | (args (cdr inp)) | |
| 221 | (com nil)) | |
| 275 | (args (cdr inp)) | |
| 276 | (com nil)) | |
| 222 | 277 | (cond ((member tag '(":show" ":sh") :test #'equal) |
| 223 | (setq com :show)) | |
| 224 | ((member tag '(":describe" ":desc") :test #'equal) | |
| 225 | (setq com :describe)) | |
| 226 | (t (with-output-chaos-error ('internal) | |
| 227 | (format t "Internal error, unknown citp command ~s" tag)))) | |
| 278 | (setq com :show)) | |
| 279 | ((member tag '(":describe" ":desc") :test #'equal) | |
| 280 | (setq com :describe)) | |
| 281 | (t (with-output-chaos-error ('internal) | |
| 282 | (format t "Internal error, unknown citp command ~s" tag)))) | |
| 228 | 283 | (cons com args))) |
| 284 | ||
| 285 | ;;; :spoiler { on | off } | |
| 286 | ;;; | |
| 287 | (defun citp-parse-spoiler (form) | |
| 288 | (let* ((on-off (second form)) | |
| 289 | (value (if (equal on-off '("on")) | |
| 290 | t | |
| 291 | (if (equal on-off '("off")) | |
| 292 | nil | |
| 293 | (progn (format t "~&:spoiler flag is ~s" (if *citp-spoiler* "on" "off")) | |
| 294 | (return-from citp-parse-spoiler nil)))))) | |
| 295 | (setq *citp-spoiler* value) | |
| 296 | (setf (citp-flag citp-spoiler) value) | |
| 297 | t)) | |
| 298 | ||
| 299 | ;;; | |
| 300 | ;;; {:binspect | binspect} [in <goal-name> : ] <boolean-term> . | |
| 301 | ;;; | |
| 302 | (defun parse-citp-binspect (args) | |
| 303 | (let (mode | |
| 304 | goal-name | |
| 305 | preterm) | |
| 306 | (if (equal (first args) ":binspect") | |
| 307 | (setq mode :citp) | |
| 308 | (setq mode :general)) | |
| 309 | (if (= 4 (length args)) | |
| 310 | (progn | |
| 311 | (setq goal-name (cadr (cadr args))) | |
| 312 | (setq preterm (nth 2 args))) | |
| 313 | (progn | |
| 314 | (setq goal-name nil) | |
| 315 | (setq preterm (nth 1 args)))) | |
| 316 | (list mode goal-name preterm))) | |
| 317 | ||
| 318 | ;;; bshow | :bshow | |
| 319 | ;;; | |
| 320 | (defun citp-parse-bshow (args) | |
| 321 | (let ((param (cadr args))) | |
| 322 | (or param "."))) | |
| 323 | ||
| 324 | ;;; :set(<name>, {on | off | show | ? }) | |
| 325 | ;;; | |
| 326 | (defun citp-parse-set (inp) | |
| 327 | (declare (type list inp)) | |
| 328 | (let ((name (third inp)) | |
| 329 | (value (fifth inp))) | |
| 330 | (list name value))) | |
| 331 | ||
| 332 | ||
| 229 | 333 | |
| 230 | 334 | ;;; ================================ |
| 231 | 335 | ;;; CITP related command evaluators |
| 238 | 342 | (with-in-module (*current-module*) |
| 239 | 343 | (let ((axs nil)) |
| 240 | 344 | (dolist (a-decl goal-ax-decls) |
| 241 | (push (parse-axiom-declaration a-decl) axs)) | |
| 345 | (cond ((eq (car a-decl) '%fax) | |
| 346 | (push (parse-fax-declaration a-decl) axs)) | |
| 347 | (t (push (parse-axiom-declaration a-decl) axs)))) | |
| 242 | 348 | (begin-proof *current-module* (nreverse axs))))) |
| 243 | 349 | |
| 244 | 350 | ;;; :apply/:auto |
| 245 | 351 | (defun eval-citp-apply (list-tactic) |
| 246 | 352 | (check-ptree) |
| 247 | 353 | (let ((target (car list-tactic)) |
| 248 | (tactics (cdr list-tactic))) | |
| 354 | (tactics (cdr list-tactic))) | |
| 249 | 355 | (let ((*chaos-verbose* nil) |
| 250 | (*chaos-quiet* t)) | |
| 356 | (*chaos-quiet* t)) | |
| 251 | 357 | (if target |
| 252 | (case target | |
| 253 | (:auto (apply-auto *proof-tree*)) | |
| 254 | (otherwise | |
| 255 | (apply-tactics-to-goal *proof-tree* target tactics))) | |
| 256 | (apply-tactics *proof-tree* tactics))))) | |
| 358 | (case target | |
| 359 | (:auto (apply-auto *proof-tree*)) | |
| 360 | (otherwise | |
| 361 | (apply-tactics-to-goal *proof-tree* target tactics))) | |
| 362 | (apply-tactics *proof-tree* tactics))))) | |
| 257 | 363 | |
| 258 | 364 | ;;; :ind on |
| 259 | 365 | ;;; |
| 275 | 381 | (defun eval-citp-init (args) |
| 276 | 382 | (check-ptree) |
| 277 | 383 | (with-in-module (*current-module*) |
| 278 | (instanciate-axiom (first args) ; target | |
| 279 | (second args)))) ; variable-term pairs | |
| 384 | (instanciate-axiom (first args) ; target | |
| 385 | (second args)))) ; variable-term pairs | |
| 280 | 386 | |
| 281 | 387 | ;;; :cp |
| 282 | 388 | (defun eval-citp-critical-pair (args) |
| 303 | 409 | (defun eval-citp-red (token-seq) |
| 304 | 410 | (check-ptree) |
| 305 | 411 | (let ((mode (first token-seq)) |
| 306 | (goal-name (second token-seq)) | |
| 307 | (pre-term (third token-seq))) | |
| 412 | (goal-name (second token-seq)) | |
| 413 | (pre-term (third token-seq))) | |
| 308 | 414 | (reduce-in-goal mode goal-name pre-term))) |
| 309 | 415 | |
| 310 | 416 | ;;; :verbose |
| 312 | 418 | (if (string-equal token "on") |
| 313 | 419 | (setq *citp-verbose* t) |
| 314 | 420 | (if (string-equal token "off") |
| 315 | (setq *citp-verbose* nil) | |
| 316 | (with-output-chaos-error ('invlid-value) | |
| 317 | (format t "Unknown parameter ~s." token))))) | |
| 421 | (setq *citp-verbose* nil) | |
| 422 | (if (string-equal token ".") | |
| 423 | (format t "~&:verbose flag is ~s" (if *citp-verbose* "on" "off")) | |
| 424 | (with-output-chaos-error ('invlid-value) | |
| 425 | (format t "Unknown parameter ~s." token)))))) | |
| 426 | ||
| 427 | ;;; :normalize init | |
| 428 | (defun eval-citp-normalize (token) | |
| 429 | (if (string-equal token "on") | |
| 430 | (setq *citp-normalize-instance* t) | |
| 431 | (if (string-equal token "off") | |
| 432 | (setq *citp-normalize-instance* nil) | |
| 433 | (if (string-equal token ".") | |
| 434 | (format t "~&:normalize flag is ~s" (if *citp-normalize-instance* "on" "off")) | |
| 435 | (with-output-chaos-error ('invalid-value) | |
| 436 | (format t ":nomalize instance: unknown parameter ~s." token)))))) | |
| 318 | 437 | |
| 319 | 438 | ;;; :ctf |
| 320 | ;;; | |
| 321 | (defun eval-citp-ctf (equation) | |
| 322 | (check-context-module) | |
| 323 | (with-in-module (*current-module*) | |
| 324 | (let ((ax (parse-axiom-declaration equation))) | |
| 325 | (apply-ctf ax) | |
| 326 | (check-success *proof-tree*)))) | |
| 439 | ;;; ax-form ::= (form . (term? . :ctf-?)) | |
| 440 | ;;; | |
| 441 | (defun eval-citp-ctf (ax-form) | |
| 442 | (check-ptree) | |
| 443 | (with-in-module (*current-module*) | |
| 444 | (reset-rewrite-counters) | |
| 445 | (begin-rewrite) | |
| 446 | (apply-ctf (car ax-form) (cadr ax-form) (cddr ax-form)) | |
| 447 | (end-rewrite) | |
| 448 | (report-citp-stat) | |
| 449 | (check-success *proof-tree*))) | |
| 327 | 450 | |
| 328 | 451 | ;;; :csp |
| 329 | 452 | (defun eval-citp-csp (goal-ax-decls) |
| 330 | (check-context-module) | |
| 331 | (with-in-module (*current-module*) | |
| 332 | (let ((axs nil)) | |
| 333 | (dolist (a-decl goal-ax-decls) | |
| 334 | (push (parse-axiom-declaration a-decl) axs)) | |
| 335 | (apply-csp (nreverse axs)) | |
| 336 | (check-success *proof-tree*)))) | |
| 453 | (check-ptree) | |
| 454 | (with-in-module (*current-module*) | |
| 455 | (reset-rewrite-counters) | |
| 456 | (begin-rewrite) | |
| 457 | (apply-csp (car goal-ax-decls) (cdr goal-ax-decls)) | |
| 458 | (end-rewrite) | |
| 459 | (report-citp-stat) | |
| 460 | (check-success *proof-tree*))) | |
| 337 | 461 | |
| 338 | 462 | ;;; :show, :describe |
| 339 | 463 | (defun eval-citp-show (token) |
| 340 | 464 | (let* ((com (car token)) |
| 341 | (describe (eq com :describe)) | |
| 342 | (target (cadr token)) | |
| 343 | (rest-args (cddr token))) | |
| 465 | (describe (eq com :describe)) | |
| 466 | (target (cadr token)) | |
| 467 | (rest-args (cddr token))) | |
| 344 | 468 | (cond ((member target '("unproved" "unp") :test #'equal) |
| 345 | (check-ptree) | |
| 346 | (print-unproved-goals *proof-tree*)) | |
| 347 | ((equal target "goal") | |
| 348 | (check-ptree) | |
| 349 | (let ((name (car rest-args))) | |
| 350 | (print-named-goal *proof-tree* name))) | |
| 351 | ((equal target "proof") | |
| 352 | (let ((name (car rest-args))) | |
| 353 | (when (or (null name) (equal name ".")) | |
| 354 | (setq name "root")) | |
| 355 | (print-proof-tree name describe))) | |
| 356 | ((member target '("." "current") :test #'equal) | |
| 357 | (check-ptree) | |
| 358 | (print-current-goal describe)) | |
| 359 | (t (with-output-chaos-error ('unknown) | |
| 360 | (format t "Unknown parameter to :show/:describe ~S" target)))))) | |
| 469 | (check-ptree) | |
| 470 | (print-unproved-goals *proof-tree*)) | |
| 471 | ((equal target "goal") | |
| 472 | (check-ptree) | |
| 473 | (let ((name (car rest-args))) | |
| 474 | (print-named-goal *proof-tree* name))) | |
| 475 | ((equal target "proof") | |
| 476 | (let ((name (car rest-args))) | |
| 477 | (when (or (null name) (equal name ".")) | |
| 478 | (setq name "root")) | |
| 479 | (print-proof-tree name describe))) | |
| 480 | ((member target '("." "current") :test #'equal) | |
| 481 | (check-ptree) | |
| 482 | (print-current-goal describe)) | |
| 483 | ((member target '(":def" ":define" "def" "define" ":defs" "defs") :test #'equal) | |
| 484 | (check-ptree) | |
| 485 | (let ((goal-name (first rest-args))) | |
| 486 | (print-defs describe goal-name))) | |
| 487 | (t (with-output-chaos-error ('unknown) | |
| 488 | (format t "Unknown parameter to :show/:describe ~S" target)))))) | |
| 489 | ||
| 490 | ;;; :binspect | |
| 491 | ;;; | |
| 492 | (defun eval-citp-binspect (args) | |
| 493 | (let ((mode (first args)) | |
| 494 | (goal-or-mod (second args)) | |
| 495 | (preterm (third args))) | |
| 496 | (binspect-in mode goal-or-mod preterm))) | |
| 497 | ||
| 498 | ;;; eval-citp-define : arg -> tactic-ctf or tactic-csp | |
| 499 | ;;; (:ctf "cf1" nil (:term (<Term>))) | |
| 500 | ;;; (:ctf "cf2" t (:eq (<Equation>))) | |
| 501 | ;;; (:csp "sp1" nil ((<Equation> ".") ...)) | |
| 502 | ;;; (:csp "sp2" t ((<Equation> ".") ...)) | |
| 503 | ;;; (:seq "tactic-1" nil (<tactic-name> ....)) | |
| 504 | ;;; | |
| 505 | (defun eval-citp-define (arg) | |
| 506 | (check-ptree) | |
| 507 | (let ((tactic-name (first arg)) | |
| 508 | (name (second arg)) | |
| 509 | (dash (third arg)) | |
| 510 | (form (fourth arg)) | |
| 511 | (tactic nil)) | |
| 512 | (when (tactic-name-is-builtin? name) | |
| 513 | (with-output-chaos-error ('invalid-name) | |
| 514 | (format t "You can not use the name of builtin tactic ~a." name))) | |
| 515 | (when (existing-def-name? *proof-tree* name) | |
| 516 | (with-output-chaos-warning () | |
| 517 | (format t "The name ~a is already defined in the current proof context." name) | |
| 518 | (format t "~%Please use the different name.") | |
| 519 | (return-from eval-citp-define nil))) | |
| 520 | (let ((current (get-next-proof-context *proof-tree*)) | |
| 521 | (goal nil)) | |
| 522 | (unless current | |
| 523 | (with-output-chaos-error ('no-context) | |
| 524 | (format t "No target goal."))) | |
| 525 | (setq goal (ptree-node-goal current)) | |
| 526 | (with-in-module ((goal-context goal)) | |
| 527 | (let ((*chaos-quiet* t)) | |
| 528 | (cond ((eq tactic-name :ctf) | |
| 529 | ;; ctf | |
| 530 | (setq tactic (make-tactic-ctf :name name | |
| 531 | :form (parse-axiom-or-term (second form) | |
| 532 | (eq :term (first form))) | |
| 533 | :context *current-module* | |
| 534 | :minus dash))) | |
| 535 | ((eq tactic-name :csp) | |
| 536 | ;; csp | |
| 537 | (let ((forms nil)) | |
| 538 | (dolist (ax form) | |
| 539 | (push (parse-axiom-declaration (parse-module-element-1 ax)) forms)) | |
| 540 | (setq tactic (make-tactic-csp :name name | |
| 541 | :forms (nreverse forms) | |
| 542 | :minus dash | |
| 543 | :context *current-module*)))) | |
| 544 | ((eq tactic-name :seq) | |
| 545 | (setq tactic (make-tactic-seq :name name | |
| 546 | :tactics (mapcar #'(lambda (x) | |
| 547 | (or (get-defined-tactic goal x) | |
| 548 | (get-builtin-tactic x) | |
| 549 | (with-output-chaos-error ('no-such-tactic) | |
| 550 | (format t "No such tactic ~a" x)))) | |
| 551 | form)))) | |
| 552 | (t ;; internal error | |
| 553 | (with-output-chaos-error ('internal-error) | |
| 554 | (format t "Invalid :def parameter ~s" tactic-name)))) | |
| 555 | (format t "~&~a defined as " name) | |
| 556 | (princ tactic) | |
| 557 | (setf (goal-defs goal) | |
| 558 | (nconc (goal-defs goal) (list tactic))))) | |
| 559 | (push (canonicalize-tactic-name name) (ptree-defs-so-far *proof-tree*))))) | |
| 560 | ||
| 561 | ;;; | |
| 562 | ;;; SET-FLAG/CLEAR-FLAG | |
| 563 | ;;; | |
| 564 | (defun citp-eval-set (args) | |
| 565 | (let ((name (first args)) | |
| 566 | (given-value (second args))) | |
| 567 | (let ((value nil) | |
| 568 | (index (find-citp-flag-index name))) | |
| 569 | (unless index | |
| 570 | (with-output-chaos-error ('no-such-flag) | |
| 571 | (format t "No such flag ~a" name))) | |
| 572 | (cond ((or (equal given-value "on") | |
| 573 | (equal given-value "set")) | |
| 574 | (setq value t)) | |
| 575 | ((equal given-value "show") | |
| 576 | (print-citp-flag index) | |
| 577 | (return-from citp-eval-set nil)) | |
| 578 | ((equal given-value "?") | |
| 579 | (help-citp-flag index) | |
| 580 | (return-from citp-eval-set nil))) | |
| 581 | (when (citp-flag citp-print-message) | |
| 582 | (with-output-msg () | |
| 583 | (format t "setting flag ~a to ~a" name given-value))) | |
| 584 | (if (= citp-all index) | |
| 585 | (dotimes (x *citp-max-flags*) | |
| 586 | (setf (citp-flag x) value)) | |
| 587 | (setf (citp-flag index) value)) | |
| 588 | ;; run hook | |
| 589 | (funcall (citp-flag-hook index) name value)))) | |
| 361 | 590 | |
| 362 | 591 | ;;; EOF |
| 0 | 0 | ;;;-*- Mode:LISP; Package:CHAOS; Base:10; Syntax:Common-lisp -*- |
| 1 | 1 | ;;; |
| 2 | ;;; Copyright (c) 2000-2014, Toshimi Sawada. All rights reserved. | |
| 2 | ;;; Copyright (c) 2000-2015, Toshimi Sawada. All rights reserved. | |
| 3 | 3 | ;;; |
| 4 | 4 | ;;; Redistribution and use in source and binary forms, with or without |
| 5 | 5 | ;;; modification, are permitted provided that the following conditions |
| 27 | 27 | ;;; |
| 28 | 28 | (in-package :chaos) |
| 29 | 29 | #|============================================================================== |
| 30 | System: CHAOS | |
| 31 | Module: thstuff | |
| 32 | File: eval-apply.lisp | |
| 30 | System: CHAOS | |
| 31 | Module: thstuff | |
| 32 | File: eval-apply.lisp | |
| 33 | 33 | ==============================================================================|# |
| 34 | 34 | #-:chaos-debug |
| 35 | 35 | (declaim (optimize (speed 3) (safety 0) #-GCL (debug 0))) |
| 41 | 41 | ;;; ***** |
| 42 | 42 | |
| 43 | 43 | (defun eval-start-command (ast) |
| 44 | (do-eval-start-th (%start-target ast) *last-module*)) | |
| 44 | (do-eval-start-th (%start-target ast) (get-context-module))) | |
| 45 | 45 | |
| 46 | 46 | (defun do-eval-start-th (pre-term &optional context) |
| 47 | 47 | (catch 'apply-context-error |
| 48 | 48 | (let ((mod (if context |
| 49 | 49 | (eval-modexp context) |
| 50 | *last-module*))) | |
| 50 | (get-context-module)))) | |
| 51 | 51 | (if (or (null mod) (modexp-is-error mod)) |
| 52 | 52 | (if (null mod) |
| 53 | 53 | (with-output-chaos-error ('invalid-module) |
| 64 | 64 | (setq target (get-bound-value (car pre-term)))) |
| 65 | 65 | (unless target |
| 66 | 66 | (return-from do-eval-start-th nil)) |
| 67 | (when (eq mod *last-module*) | |
| 68 | (setq $$action-stack nil)) | |
| 67 | (setq $$action-stack nil) | |
| 69 | 68 | (reset-reduced-flag target) |
| 70 | (reset-target-term target *last-module* mod))) | |
| 69 | (reset-target-term target *current-module* mod))) | |
| 71 | 70 | (t |
| 72 | 71 | (let ((*parse-variables* nil)) |
| 73 | 72 | (let ((res (simple-parse *current-module* |
| 74 | pre-term | |
| 73 | pre-term | |
| 75 | 74 | *cosmos*))) |
| 76 | 75 | (when (term-is-an-error res) |
| 77 | 76 | (return-from do-eval-start-th nil)) |
| 78 | (when (eq *last-module* mod) | |
| 79 | (setq $$action-stack nil)) | |
| 80 | (reset-target-term res *last-module* mod)))))) | |
| 77 | (setq $$action-stack nil) | |
| 78 | (reset-target-term res *current-module* mod)))))) | |
| 81 | 79 | ;; try use $$term |
| 82 | 80 | (progn |
| 83 | 81 | (when (or (null $$term) (eq 'void $$term)) |
| 85 | 83 | (format t "no target term is given!") |
| 86 | 84 | (return-from do-eval-start-th nil))) |
| 87 | 85 | (check-apply-context mod) |
| 88 | (when (eq *last-module* mod) | |
| 89 | (setq $$action-stack nil)) | |
| 86 | (setq $$action-stack nil) | |
| 90 | 87 | (reset-reduced-flag $$term) |
| 91 | (reset-target-term $$term *last-module* mod) | |
| 92 | ))) | |
| 93 | ;; (clear-found-rules) | |
| 88 | (reset-target-term $$term (get-context-module) mod)))) | |
| 94 | 89 | (when (command-final) (command-display)) |
| 95 | 90 | t))) |
| 96 | 91 | |
| 111 | 106 | (setq $$subterm $$term) |
| 112 | 107 | (setq $$selection-stack nil) |
| 113 | 108 | (return-from eval-choose-command nil)) |
| 114 | (with-in-module (*last-module*) | |
| 109 | (with-in-module ((get-context-module)) | |
| 115 | 110 | (multiple-value-bind (subterm-sort subterm) |
| 116 | 111 | (compute-selection $$subterm selectors) |
| 117 | 112 | (declare (ignore subterm-sort)) |
| 148 | 143 | (where-spec (%apply-where-spec ast)) |
| 149 | 144 | (selectors (%apply-selectors ast))) |
| 150 | 145 | (catch 'apply-context-error |
| 151 | (if (eq action :help) | |
| 152 | (apply-help) | |
| 153 | (progn | |
| 154 | ;; check some evaluation env | |
| 155 | (when (or (null $$term) (eq 'void $$term)) | |
| 156 | (with-output-chaos-error ('invalid-term) | |
| 157 | (princ "term to be applied is not defined.") | |
| 158 | )) | |
| 159 | (unless *last-module* | |
| 160 | (with-output-chaos-error ('no-context-module) | |
| 161 | (princ "no current module.") | |
| 162 | )) | |
| 163 | ;; real work begins here ------------------------------ | |
| 164 | (with-in-module (*last-module*) | |
| 165 | (multiple-value-bind (subterm-sort subterm) | |
| 166 | (compute-selection $$term selectors) | |
| 167 | (setq *-applied-* t) | |
| 168 | (case action | |
| 169 | (:reduce ; full reduction on selections. | |
| 170 | (!setup-reduction *last-module*) | |
| 171 | (let ((*rewrite-semantic-reduce* | |
| 172 | (module-has-behavioural-axioms *last-module*)) | |
| 173 | (*rewrite-exec-mode* nil)) | |
| 174 | (term-replace subterm (@copy-term subterm)) | |
| 175 | (reset-reduced-flag subterm) | |
| 176 | (rewrite subterm *last-module*))) | |
| 177 | (:breduce | |
| 178 | (!setup-reduction *last-module*) | |
| 179 | (let ((*rewrite-semantic-reduce* nil) | |
| 180 | (*rewrite-exec-mode* nil)) | |
| 181 | (term-replace subterm (@copy-term subterm)) | |
| 182 | (reset-reduced-flag subterm) | |
| 183 | (rewrite subterm *last-module*))) | |
| 184 | (:exec | |
| 185 | (!setup-reduction *last-module*) | |
| 186 | (let ((*rewrite-semantic-reduce* | |
| 187 | (module-has-behavioural-axioms *last-module*)) | |
| 188 | (*rewrite-exec-mode* t)) | |
| 189 | (term-replace subterm (@copy-term subterm)) | |
| 190 | (reset-reduced-flag subterm) | |
| 191 | (rewrite subterm *last-module*))) | |
| 192 | ;; | |
| 193 | (:print ; print selections. | |
| 194 | (format t "~&term ") | |
| 195 | (disp-term subterm) | |
| 196 | (format t "~&tree form") | |
| 197 | (print-term-tree subterm)) | |
| 198 | (:apply ; apply specified rule. | |
| 199 | (setq *-applied-* nil) | |
| 200 | (let* ((actrule (compute-action-rule rule-spec | |
| 201 | substitution | |
| 202 | selectors)) | |
| 203 | (*-inside-apply-with-extensions-* | |
| 204 | (and | |
| 205 | (let ((arlhs (rule-lhs actrule))) | |
| 206 | (and (term-is-application-form? arlhs) | |
| 207 | (method-is-associative (term-head arlhs))))))) | |
| 208 | (if (eq :within where-spec) | |
| 209 | (let ((*-inside-apply-all-* t)) | |
| 210 | (catch 'apply-all-quit | |
| 211 | (@apply-all actrule subterm-sort subterm))) | |
| 212 | (@apply-rule actrule subterm-sort subterm))) | |
| 213 | (when *-applied-* | |
| 214 | (update-lowest-parse $$term) | |
| 215 | (when (nth 2 rule-spec) ; reverse order | |
| 216 | (setq $$term (@copy-term $$term))) | |
| 217 | (reset-target-term $$term *last-module* *last-module*)) | |
| 218 | ) ; end :apply | |
| 219 | (t (with-output-panic-message () | |
| 220 | (format t "unknown apply action : ~a" action) | |
| 221 | (chaos-error 'unknown-action)))) | |
| 222 | ;; | |
| 223 | (unless *-applied-* | |
| 224 | (with-output-chaos-warning () | |
| 225 | (princ "rule not applied"))) | |
| 226 | ;; | |
| 227 | (command-final) | |
| 228 | (command-display)))))))) | |
| 146 | (when (eq action :help) | |
| 147 | (apply-help) | |
| 148 | (return-from eval-apply-command nil)) | |
| 149 | ;; check some evaluation env | |
| 150 | (when (or (null $$term) (eq 'void $$term)) | |
| 151 | (with-output-chaos-error ('invalid-term) | |
| 152 | (princ "term to be applied is not defined."))) | |
| 153 | ;; real work begins here ------------------------------ | |
| 154 | (with-in-module ((get-context-module)) | |
| 155 | (multiple-value-bind (subterm-sort subterm) | |
| 156 | (compute-selection $$term selectors) | |
| 157 | (setq *-applied-* t) | |
| 158 | (case action | |
| 159 | (:reduce ; full reduction on selections. | |
| 160 | (!setup-reduction *current-module*) | |
| 161 | (let ((*rewrite-semantic-reduce* | |
| 162 | (module-has-behavioural-axioms *current-module*)) | |
| 163 | (*rewrite-exec-mode* nil)) | |
| 164 | (term-replace subterm (@copy-term subterm)) | |
| 165 | (reset-reduced-flag subterm) | |
| 166 | (rewrite subterm *current-module*))) | |
| 167 | (:breduce | |
| 168 | (!setup-reduction *current-module*) | |
| 169 | (let ((*rewrite-semantic-reduce* nil) | |
| 170 | (*rewrite-exec-mode* nil)) | |
| 171 | (term-replace subterm (@copy-term subterm)) | |
| 172 | (reset-reduced-flag subterm) | |
| 173 | (rewrite subterm *current-module*))) | |
| 174 | (:exec | |
| 175 | (!setup-reduction *current-module*) | |
| 176 | (let ((*rewrite-semantic-reduce* | |
| 177 | (module-has-behavioural-axioms *current-module*)) | |
| 178 | (*rewrite-exec-mode* t)) | |
| 179 | (term-replace subterm (@copy-term subterm)) | |
| 180 | (reset-reduced-flag subterm) | |
| 181 | (rewrite subterm *current-module*))) | |
| 182 | ;; | |
| 183 | (:print ; print selections. | |
| 184 | (format t "~%term ") | |
| 185 | (disp-term subterm) | |
| 186 | (format t "~&tree form") | |
| 187 | (print-term-tree subterm)) | |
| 188 | (:apply ; apply specified rule. | |
| 189 | (setq *-applied-* nil) | |
| 190 | (let* ((actrule (compute-action-rule rule-spec | |
| 191 | substitution | |
| 192 | selectors)) | |
| 193 | (*-inside-apply-with-extensions-* | |
| 194 | (and | |
| 195 | (let ((arlhs (rule-lhs actrule))) | |
| 196 | (and (term-is-application-form? arlhs) | |
| 197 | (method-is-associative (term-head arlhs))))))) | |
| 198 | (if (eq :within where-spec) | |
| 199 | (let ((*-inside-apply-all-* t)) | |
| 200 | (catch 'apply-all-quit | |
| 201 | (@apply-all actrule subterm-sort subterm))) | |
| 202 | (@apply-rule actrule subterm-sort subterm))) | |
| 203 | (when *-applied-* | |
| 204 | (update-lowest-parse $$term) | |
| 205 | (when (nth 2 rule-spec) ; reverse order | |
| 206 | (setq $$term (@copy-term $$term))) | |
| 207 | (reset-target-term $$term *current-module* *current-module*))) ; end :apply | |
| 208 | (t (with-output-panic-message () | |
| 209 | (format t "unknown apply action : ~a" action) | |
| 210 | (chaos-error 'unknown-action)))) | |
| 211 | ;; | |
| 212 | (unless *-applied-* | |
| 213 | (with-output-chaos-warning () | |
| 214 | (princ "rule not applied"))) | |
| 215 | ;; | |
| 216 | (command-final) | |
| 217 | (command-display)))))) | |
| 229 | 218 | |
| 230 | 219 | (defvar *copy-conditions*) |
| 231 | 220 | (declaim (special *copy-conditons*)) |
| 235 | 224 | (when *apply-debug* |
| 236 | 225 | (princ "* @apply-one-rule : rule = ") |
| 237 | 226 | (print-chaos-object rule) |
| 238 | (format t "~&- sort = ") (print-sort-name sort) | |
| 227 | (format t "~%- sort = ") (print-sort-name sort) | |
| 239 | 228 | (format t "~&- term = ") (term-print term)) |
| 240 | 229 | (let ((*self* term)) |
| 241 | 230 | (let ((cond (rule-condition rule))) |
| 274 | 263 | (when eeq (setq sub nil)) |
| 275 | 264 | (unless no |
| 276 | 265 | (setq *-applied-* t) |
| 277 | (format t "~&shifting focus to condition") | |
| 266 | (format t "~%shifting focus to condition") | |
| 278 | 267 | (force-output) |
| 279 | 268 | (let ((cond-inst (@copy-term (substitution-image! sub cond))) |
| 280 | 269 | (rhs-inst |
| 285 | 274 | $$action-stack)) |
| 286 | 275 | (setq $$term cond-inst) |
| 287 | 276 | (when *-inside-apply-all-* |
| 288 | (format t "~&-- applying rule only at first position found: ") | |
| 277 | (format t "~%-- applying rule only at first position found: ") | |
| 289 | 278 | (term-print term) |
| 290 | 279 | (force-output) |
| 291 | 280 | (throw 'apply-all-quit nil)))))))))) |
| 304 | 293 | (block the-end |
| 305 | 294 | (let ((condition nil) |
| 306 | 295 | next-match-method |
| 307 | ;; (*do-unify* t) | |
| 296 | ;; (*do-unify* t) | |
| 308 | 297 | (*self* term)) |
| 309 | 298 | (multiple-value-bind (global-state subst nomatch Eequal) |
| 310 | 299 | (funcall (rule-first-match-method rule) (rule-lhs rule) term) |
| 311 | 300 | (when nomatch (return-from the-end nil)) |
| 312 | 301 | (when *apply-debug* |
| 313 | (format t "~&[apply-one-rule] : ") | |
| 302 | (format t "~%[apply-one-rule] : ") | |
| 314 | 303 | (format t "~% subst = ") |
| 315 | 304 | (print-substitution subst) |
| 316 | 305 | (format t "~% Eequal = ~a" eequal)) |
| 420 | 409 | ;;; |
| 421 | 410 | (defun apply-print-rule (x) |
| 422 | 411 | (unless x |
| 423 | (format t "~&That dosen't make sense as a rule specification.") | |
| 412 | (format t "~%That dosen't make sense as a rule specification.") | |
| 424 | 413 | (return-from apply-print-rule t)) |
| 425 | 414 | (let* ((act (get-apply-action x)) |
| 426 | 415 | (rule-spec (if (eq act :apply) |
| 427 | 416 | (parse-rule-spec x)))) |
| 428 | 417 | ;; |
| 429 | 418 | (if (eq :reduce act) |
| 430 | (format t "~&special rule for reduction of a selected subterm.") | |
| 419 | (format t "~%special rule for reduction of a selected subterm.") | |
| 431 | 420 | (if (eq :print act) |
| 432 | (format t "~&special rule to print-the selected subterm.") | |
| 421 | (format t "~%special rule to print-the selected subterm.") | |
| 433 | 422 | (progn |
| 434 | 423 | (when (or (eq :error rule-spec) (null rule-spec)) |
| 435 | (format t "~&That doesn't make sense as a rule specification.") | |
| 424 | (format t "~%That doesn't make sense as a rule specification.") | |
| 436 | 425 | (return-from apply-print-rule t)) |
| 437 | 426 | (let ((num (cadr rule-spec)) |
| 438 | 427 | (mod (car rule-spec)) |
| 449 | 438 | (print-chaos-object rule) |
| 450 | 439 | (when (and rev (or (rule-is-builtin rule) |
| 451 | 440 | (eq (axiom-type rule) :rule))) |
| 452 | (format t "~&This rule cannot be applied reversed.")) | |
| 453 | (when (and *last-module* | |
| 441 | (format t "~%This rule cannot be applied reversed.")) | |
| 442 | (when (and (get-context-module t) | |
| 454 | 443 | (not (rule-is-builtin rule))) |
| 455 | (format t "~&(This rule rewrites up.)")))))))) | |
| 444 | (format t "~%(This rule rewrites up.)")))))))) | |
| 456 | 445 | t)) |
| 457 | 446 | |
| 458 | 447 | ;;; EOF |
| 0 | 0 | ;;;-*- Mode:LISP; Package:CHAOS; Base:10; Syntax:Common-lisp -*- |
| 1 | 1 | ;;; |
| 2 | ;;; Copyright (c) 2000-2014, Toshimi Sawada. All rights reserved. | |
| 2 | ;;; Copyright (c) 2000-2015, Toshimi Sawada. All rights reserved. | |
| 3 | 3 | ;;; |
| 4 | 4 | ;;; Redistribution and use in source and binary forms, with or without |
| 5 | 5 | ;;; modification, are permitted provided that the following conditions |
| 27 | 27 | ;;; |
| 28 | 28 | (in-package :chaos) |
| 29 | 29 | #|============================================================================== |
| 30 | System: CHAOS | |
| 31 | Module: thstuff | |
| 32 | File: eval-match.lisp | |
| 30 | System: CHAOS | |
| 31 | Module: thstuff | |
| 32 | File: eval-match.lisp | |
| 33 | 33 | ==============================================================================|# |
| 34 | 34 | #-:chaos-debug |
| 35 | 35 | (declaim (optimize (speed 3) (safety 0) #-GCL (debug 0))) |
| 46 | 46 | ;;; ****** |
| 47 | 47 | |
| 48 | 48 | (defun eval-match-command (ast) |
| 49 | (unless *last-module* | |
| 50 | (with-output-chaos-error ('no-current-module) | |
| 51 | (princ "no current module."))) | |
| 52 | 49 | (let ((type (%match-type ast)) |
| 53 | 50 | (target (case (%match-target ast) |
| 54 | 51 | (:top $$term) |
| 57 | 54 | $$subterm |
| 58 | 55 | $$term)) |
| 59 | 56 | (t (let* ((*parse-variables* nil) |
| 60 | (parsed (with-in-module (*last-module*) | |
| 57 | (parsed (with-in-module ((get-context-module)) | |
| 61 | 58 | (simple-parse *current-module* |
| 62 | 59 | (%match-target ast) |
| 63 | 60 | *cosmos*)))) |
| 84 | 81 | |
| 85 | 82 | (defun find-rewrite-rules-top (target what &optional (type :match)) |
| 86 | 83 | (let* ((real-target (supply-psuedo-variables target)) |
| 87 | (patterns (find-matching-rules what real-target *last-module* type))) | |
| 84 | (patterns (find-matching-rules what real-target (get-context-module) type))) | |
| 88 | 85 | (unless patterns |
| 89 | (with-in-module (*last-module*) | |
| 90 | (format t "~&no rules found for term : ") | |
| 86 | (with-in-module ((get-context-module)) | |
| 87 | (format t "~%no rules found for term : ") | |
| 91 | 88 | (term-print target)) |
| 92 | 89 | (return-from find-rewrite-rules-top nil)) |
| 93 | 90 | ;; report the result |
| 94 | (format t "~&== matching rules to term : ") | |
| 95 | (with-in-module (*last-module*) | |
| 91 | (format t "~%== matching rules to term : ") | |
| 92 | (with-in-module ((get-context-module)) | |
| 96 | 93 | (let ((*fancy-print* nil)) |
| 97 | 94 | (term-print target)) |
| 98 | 95 | (dolist (pat patterns) |
| 117 | 114 | (princ " }")) |
| 118 | 115 | (princ " is ") |
| 119 | 116 | (print-axiom-brief rule *standard-output* nil t) |
| 120 | (format t "~& substitution : ") | |
| 117 | (format t "~% substitution : ") | |
| 121 | 118 | (let ((*print-indent* (+ *print-indent* 4))) |
| 122 | 119 | (print-substitution subst)) |
| 123 | 120 | (when extra |
| 124 | (format t "~& extra variables : ") | |
| 121 | (format t "~% extra variables : ") | |
| 125 | 122 | (format t "~{~a~^ ~}" (mapcar #'(lambda (x) (string (variable-name x))) |
| 126 | 123 | extra)))))))) |
| 127 | 124 | |
| 128 | 125 | (defun find-rewrite-rules-all (target what &optional (type :match)) |
| 129 | 126 | (let* ((real-target (supply-psuedo-variables target)) |
| 130 | (patterns (find-matching-rules-all what real-target *last-module* type))) | |
| 127 | (patterns (find-matching-rules-all what real-target (get-context-module) type))) | |
| 131 | 128 | (unless patterns |
| 132 | (with-in-module (*last-module*) | |
| 133 | (format t "~&no rules found for term : ") | |
| 129 | (with-in-module ((get-context-module)) | |
| 130 | (format t "~%no rules found for term : ") | |
| 134 | 131 | (term-print target)) |
| 135 | 132 | (return-from find-rewrite-rules-all nil)) |
| 136 | 133 | ;; report the result |
| 137 | (format t "~&== matching rules to term : ") | |
| 138 | (with-in-module (*last-module*) | |
| 134 | (format t "~%== matching rules to term : ") | |
| 135 | (with-in-module ((get-context-module)) | |
| 139 | 136 | (let ((*fancy-print* nil)) |
| 140 | 137 | (term-print target)) |
| 141 | 138 | (dolist (pat patterns) |
| 192 | 189 | nil |
| 193 | 190 | 'next-match) |
| 194 | 191 | 'next-unify))) |
| 195 | (with-in-module (*last-module*) | |
| 192 | (with-in-module ((get-context-module)) | |
| 196 | 193 | (let* ((*parse-variables* (mapcar #'(lambda (x) |
| 197 | 194 | (cons (variable-name x) x)) |
| 198 | 195 | (term-variables target))) |
| 213 | 210 | (funcall first-match-meth pattern real-target) |
| 214 | 211 | (when no-match |
| 215 | 212 | (if (eq type :match) |
| 216 | (format t "~&-- no match") | |
| 217 | (format t "~&-- no unify")) | |
| 213 | (format t "~%-- no match") | |
| 214 | (format t "~%-- no unify")) | |
| 218 | 215 | (return-from perform-match nil)) |
| 219 | 216 | (if (eq type :match) |
| 220 | (format t "~&-- match success.") | |
| 221 | (format t "~&-- unify success.")) | |
| 217 | (format t "~%-- match success.") | |
| 218 | (format t "~%-- unify success.")) | |
| 222 | 219 | (when e-equal |
| 223 | (format t "~&-- given terms are equational equal.") | |
| 220 | (format t "~%-- given terms are equational equal.") | |
| 224 | 221 | (return-from perform-match nil)) |
| 225 | (format t "~& substitution : ") | |
| 222 | (format t "~% substitution : ") | |
| 226 | 223 | (let ((*print-indent* (+ *print-indent* 4))) |
| 227 | 224 | (print-substitution subst)) |
| 228 | 225 | ;; ---- next matches |
| 232 | 229 | (while (not no-match) |
| 233 | 230 | (cond ((y-or-n-p-wait #\y 20 ">> More? [y/n] : ") |
| 234 | 231 | (if (eq type :match) |
| 235 | (format t "~&-- match success : ") | |
| 236 | (format t "~&-- unify success : ")) | |
| 232 | (format t "~%-- match success : ") | |
| 233 | (format t "~%-- unify success : ")) | |
| 237 | 234 | (let ((*print-indent* (+ 4 *print-indent*))) |
| 238 | (format t "~& * substitution : ") | |
| 235 | (format t "~% * substitution : ") | |
| 239 | 236 | (print-substitution subst)) |
| 240 | 237 | (print-next)) |
| 241 | 238 | (t (return-from end))) |
| 0 | 0 | ;;;-*- Mode:LISP; Package:CHAOS; Base:10; Syntax:Common-lisp -*- |
| 1 | 1 | ;;; |
| 2 | ;;; Copyright (c) 2000-2014, Toshimi Sawada. All rights reserved. | |
| 2 | ;;; Copyright (c) 2000-2015, Toshimi Sawada. All rights reserved. | |
| 3 | 3 | ;;; |
| 4 | 4 | ;;; Redistribution and use in source and binary forms, with or without |
| 5 | 5 | ;;; modification, are permitted provided that the following conditions |
| 27 | 27 | ;;; |
| 28 | 28 | (in-package :chaos) |
| 29 | 29 | #|============================================================================= |
| 30 | System:CHAOS | |
| 31 | Module:thstuff | |
| 32 | File:proof-struct.lisp | |
| 30 | System:CHAOS | |
| 31 | Module:thstuff | |
| 32 | File:proof-struct.lisp | |
| 33 | 33 | =============================================================================|# |
| 34 | 34 | #-:chaos-debug |
| 35 | 35 | (declaim (optimize (speed 3) (safety 0) #-GCL (debug 0))) |
| 44 | 44 | ;;; |
| 45 | 45 | (eval-when (:compile-toplevel :execute :load-toplevel) |
| 46 | 46 | (defstruct (tactic (:print-function pr-tactic)) |
| 47 | (name nil :type symbol) ; name | |
| 47 | (name nil :type symbol) ; name | |
| 48 | 48 | (executor nil :type (or null symbol)) ; tactic executor |
| 49 | 49 | ) |
| 50 | 50 | |
| 51 | 51 | (defparameter .tactic-si. (make-tactic :name :si |
| 52 | :executor 'apply-si)) ; Simultaneous Induction | |
| 52 | :executor 'apply-si)) ; Simultaneous Induction | |
| 53 | 53 | (defparameter .tactic-ca. (make-tactic :name :ca |
| 54 | :executor 'apply-ca)) ; Case Analysis | |
| 54 | :executor 'apply-ca)) ; Case Analysis | |
| 55 | 55 | (defparameter .tactic-tc. (make-tactic :name :tc |
| 56 | :executor 'apply-tc)) ; Theorem of Constants | |
| 56 | :executor 'apply-tc)) ; Theorem of Constants | |
| 57 | 57 | (defparameter .tactic-ip. (make-tactic :name :ip |
| 58 | :executor 'apply-ip)) ; Implication | |
| 58 | :executor 'apply-ip)) ; Implication | |
| 59 | #|| | |
| 59 | 60 | (defparameter .tactic-cs. (make-tactic :name :cs |
| 60 | :executor 'apply-cs)) ; Case Analysis on Sequences | |
| 61 | :executor 'apply-cs)) ; Case Analysis on Sequences | |
| 62 | ||# | |
| 61 | 63 | (defparameter .tactic-rd. (make-tactic :name :rd |
| 62 | :executor 'apply-rd)) ; Reduction | |
| 63 | ||
| 64 | :executor 'apply-rd)) ; Reduction | |
| 65 | ||
| 66 | (defparameter .tactic-nf. (make-tactic :name :nf | |
| 67 | :executor 'apply-nf)) ; nomalize goals, assumptions | |
| 68 | ||
| 69 | (defparameter .tactic-ct. (make-tactic :name :ct | |
| 70 | :executor 'apply-ct)) ; check contradiction | |
| 71 | ||
| 64 | 72 | (defparameter .tactic-nil. (make-tactic :name :nop |
| 65 | :executor 'apply-nil)) ; Do nothing, used internally. | |
| 66 | ||
| 67 | (defparameter .all-builtin-tactics. (list .tactic-si. .tactic-ca. .tactic-tc. .tactic-ip. .tactic-cs. .tactic-rd.)) | |
| 68 | ||
| 69 | ;; default tatics is a seriase of SI CA CS TC IP. | |
| 70 | (defparameter .default-tactics. (list .tactic-si. .tactic-ca. .tactic-cs. .tactic-tc. .tactic-ip. .tactic-rd.)) | |
| 73 | :executor 'apply-nil)) ; Do nothing, used internally. | |
| 74 | ||
| 75 | (defparameter .all-builtin-tactics. (list .tactic-si. .tactic-ca. .tactic-tc. .tactic-ip. .tactic-rd. .tactic-nf. .tactic-ct.)) | |
| 76 | ||
| 77 | ;; default tatics is a seriase of SI CA TC IP. | |
| 78 | (defparameter .default-tactics. (list .tactic-si. .tactic-ca. .tactic-tc. .tactic-ip. .tactic-rd.)) | |
| 71 | 79 | ;; this is not an ordinary tactic but a command, but it generates goals |
| 72 | 80 | (defparameter .tactic-ctf. (make-tactic :name :ctf |
| 73 | :executor 'apply-ctf)) | |
| 81 | :executor 'apply-ctf)) | |
| 74 | 82 | ;; this is not an ordinary tactic but a command, but it generates goals |
| 75 | 83 | (defparameter .tactic-csp. (make-tactic :name :csp |
| 76 | :executor 'apply-csp)) | |
| 84 | :executor 'apply-csp)) | |
| 77 | 85 | |
| 78 | 86 | ;; user defiled tactics: assoc list of (name . list-of-tactics) |
| 79 | 87 | ;; |
| 80 | 88 | (defvar .user-defined-tactics. nil) |
| 81 | 89 | |
| 82 | ||
| 83 | 90 | ) |
| 84 | 91 | |
| 85 | 92 | (defun canonicalize-tactic-name (name) |
| 99 | 106 | (setq name (canonicalize-tactic-name name)) |
| 100 | 107 | (find-if #'(lambda (x) (string-equal name (symbol-name (tactic-name x)))) .all-builtin-tactics.)) |
| 101 | 108 | |
| 102 | ;;; | |
| 103 | ;;; get-user-defined-tactic | |
| 104 | ;;; | |
| 105 | (defun get-user-defined-tactic (name) | |
| 109 | ;;; tactic-name-is-builtin? : name -> bool | |
| 110 | ;;; | |
| 111 | (defun tactic-name-is-builtin? (name) | |
| 112 | (get-builtin-tactic name)) | |
| 113 | ||
| 114 | ;;; sequence of tactic :defined | |
| 115 | ;;; :def <name> = (<tactic-name> ...) | |
| 116 | ;;; | |
| 117 | (defstruct (tactic-seq (:include tactic) | |
| 118 | (:print-function pr-tactic-seq)) | |
| 119 | (tactics nil :type list) ; list of tactics | |
| 120 | ) | |
| 121 | ||
| 122 | (defun pr-tactic-seq (obj stream &rest ignore) | |
| 123 | (declare (type tactic-seq obj) | |
| 124 | (ignore ignore)) | |
| 125 | (let ((tactics (tactic-seq-tactics obj))) | |
| 126 | (format stream "( ~{~a~^ ~a ~} )" (mapcar #'(lambda (x) (tactic-name x)) tactics)))) | |
| 127 | ||
| 128 | ;;; :ctf/:csp as tactic | |
| 129 | ;;; | |
| 130 | (defstruct (tactic-ctfp-common (:include tactic)) | |
| 131 | (minus nil :type (or null t)) ; t iff :ctf- or :csp- | |
| 132 | (context nil :type (or null module)) ; context module | |
| 133 | ) | |
| 134 | ||
| 135 | (defstruct (tactic-ctf (:include tactic-ctfp-common (executor 'apply-ctf-tactic)) | |
| 136 | (:print-function pr-tactic-ctf)) | |
| 137 | (form nil) ; term or equation | |
| 138 | ) | |
| 139 | ||
| 140 | (defun pr-tactic-ctf (obj stream &rest ignore) | |
| 141 | (declare (type tactic-ctf obj) | |
| 142 | (ignore ignore)) | |
| 143 | (let ((form (tactic-ctf-form obj))) | |
| 144 | (format stream ":ctf") | |
| 145 | (when (tactic-ctf-minus obj) | |
| 146 | (princ "-" stream)) | |
| 147 | (with-in-module ((tactic-ctf-context obj)) | |
| 148 | (cond ((axiom-p form) | |
| 149 | (princ "{" stream) | |
| 150 | (print-axiom-brief form stream) | |
| 151 | (princ " .}")) | |
| 152 | (t ; term | |
| 153 | (princ "[" stream) | |
| 154 | (term-print form stream) | |
| 155 | (princ " .]")))))) | |
| 156 | ||
| 157 | (defstruct (tactic-csp (:include tactic-ctfp-common (executor 'apply-csp-tactic)) | |
| 158 | (:print-function pr-tactic-csp)) | |
| 159 | (forms nil) ; list of equations | |
| 160 | ) | |
| 161 | ||
| 162 | (defun pr-tactic-csp (obj stream &rest ignore) | |
| 163 | (declare (type tactic-csp obj) | |
| 164 | (ignore ignore)) | |
| 165 | (let ((forms (tactic-csp-forms obj))) | |
| 166 | (format stream ":csp") | |
| 167 | (with-in-module ((tactic-csp-context obj)) | |
| 168 | (when (tactic-csp-minus obj) | |
| 169 | (princ "-" stream)) | |
| 170 | (princ "{" stream) | |
| 171 | (dolist (ax forms) | |
| 172 | (print-axiom-brief ax stream) | |
| 173 | (princ " . " stream)) | |
| 174 | (princ "}" stream)))) | |
| 175 | ||
| 176 | ;;; get-defined-tactic | |
| 177 | ;;; | |
| 178 | (defun get-defined-tactic (goal name) | |
| 106 | 179 | (setq name (canonicalize-tactic-name name)) |
| 107 | (cdr (assoc name .user-defined-tactics.))) | |
| 108 | ||
| 109 | ;;; | |
| 180 | (let ((defs (goal-defs goal))) | |
| 181 | (find-if #'(lambda (x) (string-equal name (canonicalize-tactic-name (tactic-name x)))) defs))) | |
| 182 | ||
| 110 | 183 | ;;; get-default-tactics |
| 111 | 184 | ;;; returns the default tactics, i.e. (:si :ca :cs :tc :ip) |
| 112 | 185 | ;;; |
| 113 | 186 | (defun get-default-tactics () .default-tactics.) |
| 114 | 187 | |
| 115 | ;;; | |
| 116 | ;;; get-tactic : name -> LIST(tactic) | |
| 117 | ;;; | |
| 118 | (defun get-tactic (name) | |
| 119 | (let ((tactic (or (get-user-defined-tactic name) | |
| 120 | (get-builtin-tactic name)))) | |
| 121 | (unless tactic | |
| 122 | (with-output-chaos-error ('no-such-tactic) | |
| 123 | (format t "No such tactic is defined with the name ~s" name))) | |
| 124 | (if (atom tactic) | |
| 125 | (list tactic) | |
| 126 | tactic))) | |
| 127 | ||
| 128 | ;;; | |
| 129 | 188 | ;;; make user defined tactic |
| 130 | 189 | ;;; |
| 131 | 190 | (defun declare-tactic (name &rest tactic-names) |
| 132 | 191 | (let ((tactics nil)) |
| 133 | 192 | (dolist (n tactic-names) |
| 134 | 193 | (let ((tactic (get-builtin-tactic n))) |
| 135 | (unless tactic | |
| 136 | (with-output-chaos-error ('no-such-tactic) | |
| 137 | (format t "No tactic with the name ~s" n))) | |
| 138 | (push tactic tactics))) | |
| 194 | (unless tactic | |
| 195 | (with-output-chaos-error ('no-such-tactic) | |
| 196 | (format t "No tactic with the name ~s" n))) | |
| 197 | (push tactic tactics))) | |
| 139 | 198 | (setq name (canonicalize-tactic-name name)) |
| 140 | 199 | (setq .user-defined-tactics. |
| 141 | 200 | (acons name (nreverse tactics) .user-defined-tactics.)))) |
| 142 | 201 | |
| 143 | ;;; | |
| 202 | ;;; ===== | |
| 203 | ;;; FLAGS | |
| 204 | ;;; ===== | |
| 205 | (defvar *citp-show-rwl* nil) | |
| 206 | ||
| 207 | ;;; ------------------------------------------------------------------------------- | |
| 208 | ;;; Various utils which controll 'switch' affected behaviour of the system . | |
| 209 | ;;; | |
| 210 | ||
| 211 | ;;; with-in-context : ptree-node | |
| 212 | ;;; construct a lexical environment for applying a tactic. | |
| 213 | ;;; | |
| 214 | (eval-when (:compile-toplevel :execute :load-toplevel) | |
| 215 | ||
| 216 | (defmacro with-in-context ((ptree-node) &rest body) | |
| 217 | (once-only (ptree-node) | |
| 218 | `(block :exit | |
| 219 | (let* ((.cur-goal. (ptree-node-goal ,ptree-node)) | |
| 220 | (.cur-targets. (goal-targets .cur-goal.)) | |
| 221 | (.next-goals. nil)) | |
| 222 | (unless .cur-targets. (return-from :exit nil)) | |
| 223 | ,@body)))) | |
| 224 | ||
| 225 | ) | |
| 226 | ||
| 227 | ;;; This variable controlls implicit applications of tactics. | |
| 228 | ;;; 'true' means CITP cares application of implicite applicatins of tactics | |
| 229 | ;;; such as 'normalization of the goal', 'contradiction check ('true = false')'. | |
| 230 | ;;; if this is 'false', CITP does only introduces proof schems defined. | |
| 231 | (declaim (special *citp-spoiler*)) | |
| 232 | (defvar *citp-spoiler* nil) | |
| 233 | ||
| 234 | (eval-when (:compile-toplevel :execute :load-toplevel) | |
| 235 | ||
| 236 | (defmacro if-spoiler-on (&key then else) | |
| 237 | `(if *citp-spoiler* | |
| 238 | (progn ,then) | |
| 239 | (progn ,else))) | |
| 240 | ||
| 241 | (defmacro when-spoiler-on (&rest body) | |
| 242 | `(when *citp-spoiler* | |
| 243 | ,@body)) | |
| 244 | ||
| 245 | (defmacro with-spoiler-on (&rest body) | |
| 246 | `(let ((*citp-spoiler* t)) | |
| 247 | (declare (special *citp-spoiler*)) | |
| 248 | ,@body)) | |
| 249 | ||
| 250 | ) | |
| 251 | ||
| 252 | (declaim (type fixnum *citp-max-flags*)) | |
| 253 | (defparameter *citp-max-flags* 10) | |
| 254 | ||
| 255 | (defstruct (citp-flag-struct) | |
| 256 | (name "" :type simple-string) | |
| 257 | (value nil) | |
| 258 | (hook #'(lambda(name value) | |
| 259 | (declare (ignore name value)) | |
| 260 | nil) | |
| 261 | :type (or function symbol))) | |
| 262 | ||
| 263 | (declaim (type (simple-array * (10)) *citp-flags*)) | |
| 264 | (defvar *citp-flags*) | |
| 265 | (eval-when (:execute :load-toplevel) | |
| 266 | (setq *citp-flags* (make-array *citp-max-flags*))) | |
| 267 | ||
| 268 | (defmacro citp-flag-struct (flag-index) | |
| 269 | `(aref *citp-flags* ,flag-index)) | |
| 270 | ||
| 271 | (defmacro citp-flag (flag-index) | |
| 272 | `(citp-flag-struct-value (aref *citp-flags* ,flag-index))) | |
| 273 | ||
| 274 | (defmacro citp-flag-name (flag-index) | |
| 275 | `(citp-flag-struct-name (aref *citp-flags* ,flag-index))) | |
| 276 | ||
| 277 | (defmacro citp-flag-hook (flag-index) | |
| 278 | `(citp-flag-struct-hook (aref *citp-flags* ,flag-index))) | |
| 279 | ||
| 280 | ;;; flag indexes | |
| 281 | (defconstant citp-all 0) | |
| 282 | (defconstant citp-verbose 1) | |
| 283 | (defconstant citp-show-rwl 2) | |
| 284 | (defconstant citp-spoiler 3) | |
| 285 | (defconstant citp-print-message 4) | |
| 286 | ||
| 287 | ;;; FIND-CITP-FLAG-INDEX : Name -> Index | |
| 288 | ;;; | |
| 289 | (defun find-citp-flag-index (given-name) | |
| 290 | (declare (type simple-string given-name) | |
| 291 | (values (or null fixnum))) | |
| 292 | (let ((i 0) | |
| 293 | (name (concatenate 'string "citp-" given-name))) | |
| 294 | (declare (type fixnum i)) | |
| 295 | (dotimes (x *citp-max-flags*) | |
| 296 | (when (string= name (citp-flag-name x)) | |
| 297 | (return-from find-citp-flag-index i)) | |
| 298 | (incf i)) | |
| 299 | nil)) | |
| 300 | ||
| 301 | ;;; print-citp-flag : index -> void | |
| 302 | ;;; | |
| 303 | (defun print-citp-flag (index) | |
| 304 | (if (= index citp-all) | |
| 305 | (do ((idx 1 (1+ idx))) | |
| 306 | ((<= *citp-max-flags* idx)) | |
| 307 | (pr-citp-flag-internal idx)) | |
| 308 | (pr-citp-flag-internal index))) | |
| 309 | ||
| 310 | (defun pr-citp-flag-internal (index) | |
| 311 | (unless (equal "" (citp-flag-name index)) | |
| 312 | (format t "~&Flag ~a is ~a" (subseq (citp-flag-name index) 5) (if (citp-flag index) "on" "off")))) | |
| 313 | ||
| 314 | ;;; help-citp-flag : index | |
| 315 | ;;; | |
| 316 | (defun help-citp-flag (index) | |
| 317 | (let ((flag (citp-flag-struct index))) | |
| 318 | flag)) | |
| 319 | ||
| 320 | ;;; flag initialization | |
| 321 | ;;; | |
| 322 | (defun initialize-citp-flag () | |
| 323 | (dotimes (idx *citp-max-flags*) | |
| 324 | (setf (citp-flag-struct idx) (make-citp-flag-struct :value nil))) | |
| 325 | (setf (citp-flag-name citp-all) "citp-all" | |
| 326 | (citp-flag-name citp-verbose) "citp-verbose" | |
| 327 | (citp-flag-name citp-show-rwl) "citp-show-rwl" | |
| 328 | (citp-flag-name citp-spoiler) "citp-spoiler" | |
| 329 | (citp-flag-name citp-print-message) "citp-print-message") | |
| 330 | ;; set default | |
| 331 | (setf (citp-flag citp-print-message) t) ; others are 'off' | |
| 332 | ;; verbose flag hook | |
| 333 | (setf (citp-flag-hook citp-verbose) | |
| 334 | #'(lambda (name value) | |
| 335 | (declare (ignore name)) | |
| 336 | (setf *citp-verbose* value))) | |
| 337 | ;; show-rwl hook | |
| 338 | (setf (citp-flag-hook citp-show-rwl) | |
| 339 | #'(lambda (name value) | |
| 340 | (declare (ignore name)) | |
| 341 | (setf *citp-show-rwl* value))) | |
| 342 | ;; citp-spoiler hook | |
| 343 | (setf (citp-flag-hook citp-spoiler) | |
| 344 | #'(lambda (name value) | |
| 345 | (declare (ignore name)) | |
| 346 | (setf *citp-spoiler* value))) | |
| 347 | ) | |
| 348 | ||
| 349 | (eval-when (:execute :load-toplevel) | |
| 350 | (initialize-citp-flag) | |
| 351 | ) | |
| 352 | ||
| 353 | ;;; messaing when :verbose on | |
| 354 | ;;; | |
| 355 | (eval-when (:compile-toplevel :execute :load-toplevel) | |
| 356 | ||
| 357 | (defmacro when-citp-verbose (&rest body) | |
| 358 | `(when *citp-verbose* | |
| 359 | (let ((*print-indent* (+ 2 *print-indent*)) | |
| 360 | (*print-line-limit* 90)) | |
| 361 | (declare (type fixnum *print-indent* *print-line-limit*)) | |
| 362 | ,@body))) | |
| 363 | ||
| 364 | ) | |
| 365 | ||
| 366 | ;;; citp standard running env. | |
| 367 | ;;; | |
| 368 | (defvar *citp-silent* t) | |
| 369 | (eval-when (:compile-toplevel :execute :load-toplevel) | |
| 370 | (defmacro with-citp-env (&rest body) | |
| 371 | `(if *citp-silent* | |
| 372 | (let ((*chaos-quiet* t) | |
| 373 | (*rwl-search-no-state-report* | |
| 374 | (if *citp-show-rwl* | |
| 375 | nil | |
| 376 | t))) | |
| 377 | ,@body) | |
| 378 | (progn | |
| 379 | ,@body))) | |
| 380 | ) | |
| 381 | ||
| 144 | 382 | ;;; for debugging |
| 145 | 383 | ;;; |
| 146 | 384 | (eval-when (:compile-toplevel :execute :load-toplevel) |
| 148 | 386 | (defmacro with-citp-debug (&rest body) |
| 149 | 387 | `(when *debug-citp* |
| 150 | 388 | (let ((*print-indent* (+ 2 *print-indent*)) |
| 151 | (*print-line-limit* 90)) | |
| 389 | (*print-line-limit* 90)) | |
| 152 | 390 | (declare (type fixnum *print-indent* *print-line-limit*)) |
| 153 | 391 | ,@body))) |
| 154 | 392 | |
| 161 | 399 | ;;; it holds all the information about a goal. |
| 162 | 400 | ;;; |
| 163 | 401 | (defstruct (goal (:print-function pr-goal)) |
| 164 | (name "" :type string) ; the name of the goal, we will refer | |
| 165 | ; this goal by this name | |
| 166 | (context nil :type (or null module)) ; context module | |
| 167 | (constants nil :type list) ; list of (var . constant) introduced for TC/CA/SI | |
| 168 | (ind-constants nil :type list) ; list of constants introduced for induction | |
| 169 | (indvars nil :type list) ; list of induction variables | |
| 170 | (assumptions nil :type list) ; list of hypothesis | |
| 171 | (tactic nil :type (or null tactic)) ; tactic which derived this goal | |
| 172 | (targets nil :type list) ; axioms to be proved | |
| 173 | (proved nil :type list) ; proved targets | |
| 174 | (critical-pairs nil :type list) ; list of critical pairs not yet axiomatized | |
| 402 | (name "" :type string) ; the name of the goal, we will refer | |
| 403 | ; this goal by this name | |
| 404 | (context nil :type (or null module)) ; context module | |
| 405 | (constants nil :type list) ; list of (var . constant) introduced for TC/CA/SI | |
| 406 | (ind-constants nil :type list) ; list of constants introduced for induction | |
| 407 | (indvars nil :type list) ; list of induction variables | |
| 408 | (skolems nil :type list) ; list of skolem functions | |
| 409 | (assumptions nil :type list) ; list of hypothesis | |
| 410 | (tactic nil :type (or null tactic)) ; tactic which derived this goal | |
| 411 | (targets nil :type list) ; axioms to be proved | |
| 412 | (proved nil :type list) ; proved targets | |
| 413 | (critical-pairs nil :type list) ; list of critical pairs not yet axiomatized | |
| 414 | (defs nil :type list) ; list of :defined tactics | |
| 175 | 415 | ) |
| 176 | 416 | |
| 177 | 417 | (defun goal-is-discharged (goal) |
| 183 | 423 | |
| 184 | 424 | (defun pr-goal (goal &optional (stream *standard-output*) &rest ignore) |
| 185 | 425 | (declare (type goal goal) |
| 186 | (type stream stream) | |
| 187 | (ignore ignore)) | |
| 426 | (type stream stream) | |
| 427 | (ignore ignore)) | |
| 188 | 428 | (let ((*print-line-limit* 80) |
| 189 | (*print-xmode* :fancy)) | |
| 429 | (*print-xmode* :fancy)) | |
| 190 | 430 | (with-in-module ((goal-context goal)) |
| 191 | 431 | (if (goal-tactic goal) |
| 192 | (format stream "~%~a=>~%:goal { ** ~a -----------------------------------------" | |
| 193 | (goal-tactic goal) (goal-name goal)) | |
| 194 | (format stream "~%:goal { ** ~a -----------------------------------------" | |
| 195 | (goal-name goal))) | |
| 432 | (format stream "~%~a=>~%:goal { ** ~a -----------------------------------------" | |
| 433 | (goal-tactic goal) (goal-name goal)) | |
| 434 | (format stream "~%:goal { ** ~a -----------------------------------------" | |
| 435 | (goal-name goal))) | |
| 196 | 436 | (let ((*print-indent* (+ 2 *print-indent*)) |
| 197 | (v-consts (goal-constants goal)) | |
| 198 | (i-consts (goal-ind-constants goal)) | |
| 199 | (ass (goal-assumptions goal)) | |
| 200 | (vs (goal-indvars goal)) | |
| 201 | (axs (goal-targets goal)) | |
| 202 | (proved (goal-proved goal)) | |
| 203 | (discharged (goal-is-discharged goal))) | |
| 204 | (print-next) | |
| 205 | (format stream "-- context module: ~a" | |
| 206 | (get-module-simple-name (ptree-context *proof-tree*))) | |
| 207 | (when proved | |
| 208 | (print-next) | |
| 209 | (format stream "-- discharged axiom~p" (length proved)) | |
| 210 | (dolist (pv proved) | |
| 211 | (let ((*print-indent* (+ 2 *print-indent*))) | |
| 212 | (print-next) | |
| 213 | (print-axiom-brief pv) (princ " .")))) | |
| 214 | (when vs | |
| 215 | (print-next) | |
| 216 | (format stream "-- induction variable~p" (length vs)) | |
| 217 | (dolist (v vs) | |
| 218 | (let ((*print-indent* (+ 2 *print-indent*))) | |
| 219 | (print-next) | |
| 220 | (term-print-with-sort v)))) | |
| 221 | (when v-consts | |
| 222 | (print-next) | |
| 223 | (format stream "-- introduced constant~p" (length v-consts)) | |
| 224 | (dolist (const (reverse v-consts)) | |
| 225 | (let ((*print-indent* (+ 2 *print-indent*))) | |
| 226 | (print-next) | |
| 227 | (print-method-brief (term-head (cdr const)))))) | |
| 228 | (when i-consts | |
| 229 | (print-next) | |
| 230 | (format stream "-- constant~p for induction" (length i-consts)) | |
| 231 | (dolist (ic (reverse i-consts)) | |
| 232 | (let ((*print-indent* (+ 2 *print-indent*))) | |
| 233 | (print-next) | |
| 234 | (print-method-brief (term-head (cdr ic)))))) | |
| 235 | (when ass | |
| 236 | (print-next) | |
| 237 | (format stream "-- introduced axiom~p" (length ass)) | |
| 238 | (dolist (as ass) | |
| 239 | (let ((*print-indent* (+ 2 *print-indent*))) | |
| 240 | (print-next) | |
| 241 | (print-axiom-brief as) (princ " .")))) | |
| 242 | (when axs | |
| 243 | (print-next) | |
| 244 | (format stream "-- sentence~p to be proved" (length axs)) | |
| 245 | (dolist (ax axs) | |
| 246 | (let ((*print-indent* (+ 2 *print-indent*))) | |
| 247 | (print-next) | |
| 248 | (print-axiom-brief ax) (princ " .")))) | |
| 249 | (format stream "~%}") | |
| 250 | (if discharged | |
| 251 | (format t " << proved >>")))))) | |
| 437 | (v-consts (goal-constants goal)) | |
| 438 | (i-consts (goal-ind-constants goal)) | |
| 439 | (skolems (goal-skolems goal)) | |
| 440 | (ass (goal-assumptions goal)) | |
| 441 | (vs (goal-indvars goal)) | |
| 442 | (axs (goal-targets goal)) | |
| 443 | (proved (goal-proved goal)) | |
| 444 | (discharged (goal-is-discharged goal))) | |
| 445 | (print-next) | |
| 446 | (format stream "-- context module: ~a" | |
| 447 | (get-module-simple-name (ptree-context *proof-tree*))) | |
| 448 | (when proved | |
| 449 | (print-next) | |
| 450 | (format stream "-- discharged sentence~p" (length proved)) | |
| 451 | (dolist (pv proved) | |
| 452 | (let ((*print-indent* (+ 2 *print-indent*))) | |
| 453 | (print-next) | |
| 454 | (print-axiom-brief pv) (princ " .")))) | |
| 455 | (when vs | |
| 456 | (print-next) | |
| 457 | (format stream "-- induction variable~p" (length vs)) | |
| 458 | (dolist (v vs) | |
| 459 | (let ((*print-indent* (+ 2 *print-indent*))) | |
| 460 | (print-next) | |
| 461 | (term-print-with-sort v)))) | |
| 462 | (when v-consts | |
| 463 | (print-next) | |
| 464 | (format stream "-- introduced constant~p" (length v-consts)) | |
| 465 | (dolist (const (reverse v-consts)) | |
| 466 | (let ((*print-indent* (+ 2 *print-indent*))) | |
| 467 | (print-next) | |
| 468 | (print-method-brief (term-head (cdr const)))))) | |
| 469 | (when i-consts | |
| 470 | (print-next) | |
| 471 | (format stream "-- constant~p for induction" (length i-consts)) | |
| 472 | (dolist (ic (reverse i-consts)) | |
| 473 | (let ((*print-indent* (+ 2 *print-indent*))) | |
| 474 | (print-next) | |
| 475 | (print-method-brief (term-head (cdr ic)))))) | |
| 476 | (when skolems | |
| 477 | (print-next) | |
| 478 | (format stream "-- introduced skolem function~p" (length skolems)) | |
| 479 | (dolist (sk skolems) | |
| 480 | (let ((*print-indent* (+ 2 *print-indent*))) | |
| 481 | (print-next) | |
| 482 | (print-method-brief sk)))) | |
| 483 | (when ass | |
| 484 | (print-next) | |
| 485 | (format stream "-- introduced axiom~p" (length ass)) | |
| 486 | (dolist (as ass) | |
| 487 | (let ((*print-indent* (+ 2 *print-indent*))) | |
| 488 | (print-next) | |
| 489 | (print-axiom-brief as) (princ " .")))) | |
| 490 | (when axs | |
| 491 | (print-next) | |
| 492 | (format stream "-- sentence~p to be proved" (length axs)) | |
| 493 | (dolist (ax axs) | |
| 494 | (let ((*print-indent* (+ 2 *print-indent*))) | |
| 495 | (print-next) | |
| 496 | (print-axiom-brief ax) (princ " .")))) | |
| 497 | (format stream "~%}") | |
| 498 | (if discharged | |
| 499 | (format t " << proved >>")))))) | |
| 500 | ||
| 501 | ;;; the-goal-needs-undo : goal -> bool | |
| 502 | ;;; returns t iff the goal is generated by :defined :ctf- or :csp- | |
| 503 | ;;; | |
| 504 | (defun the-goal-needs-undo (goal) | |
| 505 | (declare (type goal goal)) | |
| 506 | (let ((goal-tactic (goal-tactic goal))) | |
| 507 | (and (tactic-ctfp-common-p goal-tactic) | |
| 508 | (tactic-ctfp-common-minus goal-tactic)))) | |
| 252 | 509 | |
| 253 | 510 | ;;; ------------------------------------------------------------------------- |
| 254 | 511 | ;;; PTREE-NODE |
| 255 | 512 | ;;; A node of a proof tree. Contains a goal as its datum. |
| 256 | 513 | ;;; |
| 257 | 514 | (defstruct (ptree-node (:include bdag) |
| 258 | (:print-function pr-ptree-node)) | |
| 259 | (num-children 0 :type fixnum) ; number of children | |
| 260 | (next-child 0 :type fixnum) ; next child to be proved | |
| 261 | (my-num 0 :type fixnum) ; position in siblings, first = 1 | |
| 262 | (my-name "" :type string) ; name | |
| 263 | (done nil :type (or null t))) ; t iff the node is dischaged | |
| 515 | (:print-function pr-ptree-node)) | |
| 516 | (num-children 0 :type fixnum) ; number of children | |
| 517 | (next-child 0 :type fixnum) ; next child to be proved | |
| 518 | (my-num 0 :type fixnum) ; position in siblings, first = 1 | |
| 519 | (my-name "" :type string) ; name | |
| 520 | (done nil :type (or null t))) ; t iff the node is dischaged | |
| 264 | 521 | |
| 265 | 522 | (defun pr-ptree-node (ptree-node &optional (stream *standard-output*) &rest ignore) |
| 266 | 523 | (declare (type ptree-node ptree-node) |
| 267 | (type stream stream) | |
| 268 | (ignore ignore)) | |
| 524 | (type stream stream) | |
| 525 | (ignore ignore)) | |
| 269 | 526 | (format stream "[Node] sub nodes = ~d, discharged? = ~a ---------------" |
| 270 | (ptree-node-num-children ptree-node) | |
| 271 | (ptree-node-done ptree-node)) | |
| 527 | (ptree-node-num-children ptree-node) | |
| 528 | (ptree-node-done ptree-node)) | |
| 272 | 529 | (pr-goal (ptree-node-datum ptree-node) stream)) |
| 273 | 530 | |
| 274 | 531 | (defmacro ptree-node-goal (ptree-node) |
| 275 | 532 | `(ptree-node-datum ,ptree-node)) |
| 276 | 533 | |
| 277 | ;;; | |
| 278 | 534 | ;;; initialize-ptree-node : ptree-node -> ptree-node |
| 279 | 535 | ;;; discard existing child nodes. |
| 280 | 536 | ;;; |
| 282 | 538 | (unless no-warn |
| 283 | 539 | (when (ptree-node-subnodes node) |
| 284 | 540 | (with-output-chaos-warning () |
| 285 | (format t "Discarding exsisting ~d node~p" | |
| 286 | (ptree-node-num-children node) | |
| 287 | (length (ptree-node-subnodes node)))))) | |
| 541 | (format t "Discarding exsisting ~d node~p" | |
| 542 | (ptree-node-num-children node) | |
| 543 | (length (ptree-node-subnodes node)))))) | |
| 288 | 544 | (setf (ptree-node-num-children node) 0 |
| 289 | (ptree-node-subnodes node) nil) | |
| 545 | (ptree-node-subnodes node) nil) | |
| 290 | 546 | node) |
| 291 | 547 | |
| 292 | ;;; | |
| 293 | 548 | ;;; node-is-discharged? : ptree-node -> Bool |
| 294 | 549 | ;;; returns if the node's goal is discharged, |
| 295 | 550 | ;;; i.e., own goal has no target axioms to be proved, |
| 298 | 553 | (defun node-is-discharged? (node) |
| 299 | 554 | (let ((goal (ptree-node-goal node))) |
| 300 | 555 | (or (null (goal-targets goal)) |
| 301 | (and (ptree-node-subnodes node) | |
| 302 | (every #'(lambda (x) (node-is-discharged? x)) (ptree-node-subnodes node)))))) | |
| 556 | (and (ptree-node-subnodes node) | |
| 557 | (every #'(lambda (x) (node-is-discharged? x)) (ptree-node-subnodes node)))))) | |
| 303 | 558 | |
| 304 | 559 | ;;; make-it-unproved : ptree-node -> ptree-node' |
| 305 | 560 | ;;; |
| 312 | 567 | ;;; |
| 313 | 568 | (defun make-ptree-goal-name (parent-node my-num) |
| 314 | 569 | (declare (type (or null ptree-node) parent-node) |
| 315 | (type fixnum my-num)) | |
| 570 | (type fixnum my-num)) | |
| 316 | 571 | (if parent-node |
| 317 | 572 | (let ((p-name (goal-name (ptree-node-goal parent-node)))) |
| 318 | (if (equal p-name "root") | |
| 319 | (format nil "~d" my-num) | |
| 320 | (format nil "~a-~d" p-name my-num))) | |
| 573 | (if (equal p-name "root") | |
| 574 | (format nil "~d" my-num) | |
| 575 | (format nil "~a-~d" p-name my-num))) | |
| 321 | 576 | "root")) |
| 322 | 577 | |
| 323 | ;;; | |
| 324 | 578 | ;;; context module creator |
| 325 | 579 | ;;; |
| 326 | 580 | (defparameter .next-context-module. (%module-decl* "next-context-dummy" :object :user nil)) |
| 329 | 583 | (declare (type string goal-name)) |
| 330 | 584 | (format nil "#Goal-~a" goal-name)) |
| 331 | 585 | |
| 332 | ;;; | |
| 333 | 586 | ;;; prepare-next-goal : ptree-node -> goal |
| 334 | 587 | ;;; prepare next goal structure with associated context module |
| 335 | 588 | ;;; |
| 337 | 590 | |
| 338 | 591 | (defun prepare-next-goal (ptree-node &optional (tactic nil)) |
| 339 | 592 | (let ((goal-name (make-ptree-goal-name ptree-node (incf (ptree-node-num-children ptree-node)))) |
| 340 | (decl-form (copy-tree .next-context-module.))) | |
| 593 | (decl-form (copy-tree .next-context-module.))) | |
| 341 | 594 | (setf (%module-decl-name decl-form) (make-next-context-module-name goal-name)) |
| 342 | 595 | (let ((next-context (eval-ast decl-form)) |
| 343 | (cur-goal (ptree-node-goal ptree-node)) | |
| 344 | (next-goal (make-goal :name goal-name | |
| 345 | :tactic tactic))) | |
| 596 | (cur-goal (ptree-node-goal ptree-node)) | |
| 597 | (next-goal (make-goal :name goal-name | |
| 598 | :tactic tactic))) | |
| 346 | 599 | ;; goal module is hidden from user |
| 347 | 600 | (setf (module-hidden next-context) t) |
| 348 | 601 | (push (%module-decl-name decl-form) .goals-so-far.) |
| 350 | 603 | (import-module next-context :including (goal-context cur-goal)) |
| 351 | 604 | ;; inherit current goal |
| 352 | 605 | (setf (goal-context next-goal) next-context |
| 353 | (goal-constants next-goal) (goal-constants cur-goal) | |
| 354 | (goal-ind-constants next-goal) (goal-ind-constants cur-goal) | |
| 355 | (goal-indvars next-goal) (goal-indvars cur-goal) | |
| 356 | (goal-assumptions next-goal) (goal-assumptions cur-goal)) | |
| 606 | (goal-constants next-goal) (goal-constants cur-goal) | |
| 607 | (goal-ind-constants next-goal) (goal-ind-constants cur-goal) | |
| 608 | (goal-indvars next-goal) (goal-indvars cur-goal) | |
| 609 | (goal-skolems next-goal) (goal-skolems cur-goal) | |
| 610 | (goal-assumptions next-goal) (goal-assumptions cur-goal) | |
| 611 | (goal-defs next-goal) (goal-defs cur-goal)) | |
| 357 | 612 | (prepare-for-parsing next-context) |
| 358 | 613 | (setq *next-default-proof-node* nil) ; we reset the next default target |
| 359 | 614 | next-goal))) |
| 360 | 615 | |
| 361 | ;;; | |
| 362 | 616 | ;;; give-goal-name-each-in-order : ptree-node List(goal) -> void |
| 363 | 617 | ;;; this is used for renaming goals and their context modules |
| 364 | 618 | ;;; after applied a tactic. |
| 366 | 620 | (defun give-goal-name-each-in-order (parent-node list-goals) |
| 367 | 621 | (dolist (goal list-goals) |
| 368 | 622 | (let* ((gname (make-ptree-goal-name parent-node (incf (ptree-node-num-children parent-node)))) |
| 369 | (mod-name (make-next-context-module-name gname))) | |
| 623 | (mod-name (make-next-context-module-name gname))) | |
| 370 | 624 | (setf (goal-name goal) gname) |
| 371 | 625 | (setf (module-name (goal-context goal)) mod-name)))) |
| 372 | 626 | |
| 373 | ;;; | |
| 374 | 627 | ;;; make-ptree-root : module goal -> ptree-node |
| 375 | 628 | ;;; |
| 376 | 629 | (defun make-ptree-root (context-module initial-goals) |
| 377 | 630 | (declare (type module context-module) |
| 378 | (type list initial-goals)) | |
| 631 | (type list initial-goals)) | |
| 379 | 632 | (let ((root-node (make-ptree-node :subnodes nil :parent nil))) |
| 380 | (setf (ptree-node-goal root-node) (make-goal :name (make-ptree-goal-name nil (ptree-node-my-num root-node)) | |
| 381 | :context context-module | |
| 382 | :targets initial-goals)) | |
| 633 | (setf (ptree-node-goal root-node) | |
| 634 | (make-goal :name (make-ptree-goal-name nil (ptree-node-my-num root-node)) | |
| 635 | :context context-module | |
| 636 | :skolems (reverse (module-skolem-functions context-module)) | |
| 637 | :targets initial-goals)) | |
| 383 | 638 | root-node)) |
| 384 | 639 | |
| 385 | ;;; | |
| 386 | 640 | ;;; add-ptree-child : ptree-node module List(axiom) -> List(goal) |
| 387 | 641 | ;;; |
| 388 | 642 | (defun add-ptree-child (parent-node child-goal) |
| 389 | 643 | (declare (type ptree-node parent-node) |
| 390 | (type goal child-goal)) | |
| 644 | (type goal child-goal)) | |
| 391 | 645 | (setf (ptree-node-subnodes parent-node) |
| 392 | 646 | (nconc (ptree-node-subnodes parent-node) |
| 393 | (list (make-ptree-node :datum child-goal | |
| 394 | :my-num (ptree-node-num-children parent-node) | |
| 395 | :subnodes nil | |
| 396 | :parent parent-node))))) | |
| 647 | (list (make-ptree-node :datum child-goal | |
| 648 | :my-num (ptree-node-num-children parent-node) | |
| 649 | :subnodes nil | |
| 650 | :parent parent-node))))) | |
| 397 | 651 | |
| 398 | 652 | ;;; add-ptree-children : ptree-node List(goal) -> ptree-node' |
| 399 | 653 | ;;; add node of given goals as a child of the node. |
| 402 | 656 | ;;; |
| 403 | 657 | (defun add-ptree-children (parent-node list-goals) |
| 404 | 658 | (declare (type ptree-node parent-node) |
| 405 | (type list list-goals)) | |
| 659 | (type list list-goals)) | |
| 406 | 660 | (initialize-ptree-node parent-node t) |
| 407 | 661 | ;; give names to goals |
| 408 | 662 | (give-goal-name-each-in-order parent-node list-goals) |
| 417 | 671 | (unless parent (return-from get-ptree-root ptree-node)) |
| 418 | 672 | (get-ptree-root parent))) |
| 419 | 673 | |
| 674 | ;;; ptree utils | |
| 675 | ;;; | |
| 676 | ||
| 677 | ;;; the-node-needs-undo | |
| 678 | ;;; returns t iff the node is generated by :def(ined) | |
| 679 | ;;; :ctf- or :csp- | |
| 680 | (defun the-node-needs-undo (node) | |
| 681 | (declare (type ptree-node node)) | |
| 682 | (the-goal-needs-undo (ptree-node-goal node))) | |
| 683 | ||
| 684 | ;;; parent-nedds-undo | |
| 685 | ;;; returns t iff the parent node is generated by :def(ined) | |
| 686 | ;;; :ctf- or :csp- | |
| 687 | ;;; | |
| 688 | (defun parent-needs-undo (pnode) | |
| 689 | (declare (type (or null ptree-node) pnode)) | |
| 690 | (let ((node (ptree-node-parent pnode))) | |
| 691 | (unless node (return-from parent-needs-undo nil)) | |
| 692 | (the-node-needs-undo node))) | |
| 420 | 693 | |
| 421 | 694 | ;;;----------------------------------------------------------------------------- |
| 422 | 695 | ;;; PTREE : proof tree |
| 423 | 696 | ;;; whole proof tree structure. |
| 424 | 697 | ;;; |
| 425 | 698 | (defstruct (ptree (:print-function pr-ptree)) |
| 426 | (context nil :type (or null module)) ; context module | |
| 427 | (num-gen-const 0 :type fixnum) ; number of generated constants so far | |
| 699 | (context nil :type (or null module)) ; context module | |
| 700 | (num-gen-const 0 :type fixnum) ; number of generated constants so far | |
| 701 | (num-gen-const-ind 0 :type fixnum) ; number of generated constants for induction so far | |
| 428 | 702 | (root nil :type (or null ptree-node)) ; root goal |
| 429 | 703 | (indvar-subst nil :type list) |
| 430 | 704 | (var-subst nil :type list) |
| 705 | (defs-so-far nil :type list) ; :defined name so far | |
| 431 | 706 | ) |
| 432 | 707 | |
| 433 | 708 | (defun pr-ptree (ptree &optional (stream *standard-output*) &rest ignore) |
| 434 | 709 | (declare (type ptree ptree) |
| 435 | (type stream stream) | |
| 436 | (ignore ignore)) | |
| 710 | (type stream stream) | |
| 711 | (ignore ignore)) | |
| 437 | 712 | (let ((*standard-output* stream)) |
| 438 | 713 | (format t "~%Proof Tree ===================================") |
| 439 | 714 | (format t "~%-- number of generated constants: ~d" (ptree-num-gen-const ptree)) |
| 440 | 715 | (format t "~%-- induction variable bases:") |
| 441 | 716 | (with-in-module ((goal-context (ptree-node-goal (ptree-root ptree)))) |
| 442 | 717 | (let ((indvar-subst (ptree-indvar-subst ptree)) |
| 443 | (*print-indent* (+ 2 *print-indent*))) | |
| 444 | (if indvar-subst | |
| 445 | (dolist (is indvar-subst) | |
| 446 | (print-next) | |
| 447 | (term-print-with-sort (car is)) | |
| 448 | (princ " => ") | |
| 449 | (princ (cdr is))) | |
| 450 | (progn (print-next) (princ "none" stream)))) | |
| 718 | (*print-indent* (+ 2 *print-indent*))) | |
| 719 | (if indvar-subst | |
| 720 | (dolist (is indvar-subst) | |
| 721 | (print-next) | |
| 722 | (term-print-with-sort (car is)) | |
| 723 | (princ " => ") | |
| 724 | (princ (cdr is))) | |
| 725 | (progn (print-next) (princ "none" stream)))) | |
| 451 | 726 | (format stream "~%-- introduced constants:") |
| 452 | 727 | (let ((var-subst (ptree-var-subst ptree)) |
| 453 | (*print-indent* (+ 2 *print-indent*))) | |
| 454 | (if var-subst | |
| 455 | (dolist (is var-subst) | |
| 456 | (print-next) | |
| 457 | (term-print-with-sort (car is)) | |
| 458 | (princ " => ") | |
| 459 | (princ (cdr is))) | |
| 460 | (progn (print-next) (princ "none" stream)))) | |
| 728 | (*print-indent* (+ 2 *print-indent*))) | |
| 729 | (if var-subst | |
| 730 | (dolist (is var-subst) | |
| 731 | (print-next) | |
| 732 | (term-print-with-sort (car is)) | |
| 733 | (princ " => ") | |
| 734 | (princ (cdr is))) | |
| 735 | (progn (print-next) (princ "none" stream)))) | |
| 461 | 736 | (format stream "~%-- root node") |
| 462 | 737 | (pr-goal (ptree-node-goal (ptree-root ptree)))))) |
| 463 | 738 | |
| 464 | 739 | (defun reset-proof (ptree) |
| 465 | 740 | (setf (ptree-num-gen-const ptree) 0 |
| 466 | (ptree-indvar-subst ptree) nil | |
| 467 | (ptree-var-subst ptree) nil)) | |
| 741 | (ptree-indvar-subst ptree) nil | |
| 742 | (ptree-var-subst ptree) nil)) | |
| 743 | ||
| 744 | (defun existing-def-name? (ptree name) | |
| 745 | (setq name (canonicalize-tactic-name name)) | |
| 746 | (member name (ptree-defs-so-far ptree) :test #'equal)) | |
| 468 | 747 | |
| 469 | 748 | ;;; intro-const-returns-subst : module name variable -> (variable . constant-term) |
| 470 | 749 | ;;; introduces a new constant of sort(variable) into a module. |
| 473 | 752 | (defun intro-const-returns-subst (module name variable) |
| 474 | 753 | (multiple-value-bind (op meth) |
| 475 | 754 | (declare-operator-in-module (list name) |
| 476 | nil ; arity | |
| 477 | (variable-sort variable) ; coarity | |
| 478 | module ; | |
| 479 | nil ; constructor? | |
| 480 | nil ; behavioural? always nil. | |
| 481 | nil ; not coherent | |
| 482 | ) | |
| 755 | nil ; arity | |
| 756 | (variable-sort variable) ; coarity | |
| 757 | module ; | |
| 758 | nil ; constructor? | |
| 759 | nil ; behavioural? always nil. | |
| 760 | nil ; not coherent | |
| 761 | ) | |
| 483 | 762 | (declare (ignore op)) |
| 484 | (prepare-for-parsing module t t) ; force | |
| 763 | (prepare-for-parsing module t t) ; force | |
| 485 | 764 | (cons variable (make-applform-simple (variable-sort variable) meth nil)))) |
| 486 | 765 | |
| 487 | ;;; | |
| 488 | 766 | ;;; make-tc-const-name : proof-tree prefix -> string |
| 489 | 767 | ;;; |
| 490 | #|| | |
| 491 | (defun make-tc-const-name (variable) | |
| 492 | (format nil "~:@(~a~)@~a-~d" (variable-name variable) (sort-name (variable-sort variable)) | |
| 493 | (incf (ptree-num-gen-const *proof-tree*)))) | |
| 494 | ||# | |
| 495 | ||
| 496 | 768 | (defun make-tc-const-name (variable) |
| 497 | 769 | (format nil "~:@(~a~)@~a" (variable-name variable) |
| 498 | (string (sort-name (variable-sort variable))))) | |
| 499 | ||
| 500 | ;;; | |
| 770 | (string (sort-name (variable-sort variable))))) | |
| 771 | ||
| 501 | 772 | ;;; variable->constant : goal variable -> term |
| 502 | 773 | ;;; |
| 503 | 774 | (defun find-variable-subst-in (alist variable) |
| 509 | 780 | (defun variable->constant (goal variable) |
| 510 | 781 | (let ((vc-assoc (find-variable-subst-in (goal-constants goal) variable))) |
| 511 | 782 | (or (cdr vc-assoc) |
| 512 | (let ((name (cdr (find-variable-subst-in (ptree-var-subst *proof-tree*) variable))) | |
| 513 | (v-const nil)) | |
| 514 | (unless name | |
| 515 | (setq name (make-tc-const-name variable)) | |
| 516 | (push (cons variable name) (ptree-var-subst *proof-tree*))) | |
| 517 | (setq v-const (intro-const-returns-subst (goal-context goal) | |
| 518 | name | |
| 519 | variable)) | |
| 520 | (push v-const (goal-constants goal)) | |
| 521 | (cdr v-const))))) | |
| 522 | ||
| 523 | ;;; | |
| 783 | (let ((name (cdr (find-variable-subst-in (ptree-var-subst *proof-tree*) variable))) | |
| 784 | (v-const nil)) | |
| 785 | (unless name | |
| 786 | (setq name (make-tc-const-name variable)) | |
| 787 | (push (cons variable name) (ptree-var-subst *proof-tree*))) | |
| 788 | (setq v-const (intro-const-returns-subst (goal-context goal) | |
| 789 | name | |
| 790 | variable)) | |
| 791 | (push v-const (goal-constants goal)) | |
| 792 | (cdr v-const))))) | |
| 793 | ||
| 524 | 794 | ;;; variable->constructor : goal variable op -> term |
| 525 | 795 | ;;; |
| 526 | #|| | |
| 527 | (defun make-ind-const-name (name-prefix) | |
| 528 | (format nil "~a#~d" name-prefix (incf (ptree-num-gen-const *proof-tree*)))) | |
| 529 | ||# | |
| 530 | ||
| 531 | 796 | (defun make-ind-const-name (name-prefix sort) |
| 532 | 797 | (format nil "~a#~a" (string name-prefix) (string (sort-name sort)))) |
| 533 | 798 | |
| 534 | 799 | (defun variable->constructor (goal variable &key (sort nil) (op nil)) |
| 535 | (let ((svar (if sort | |
| 536 | (make-variable-term sort (intern (format nil "~a_~a" (variable-name variable) (sort-name sort)))) | |
| 537 | variable))) | |
| 538 | (flet ((make-iv-const (name) | |
| 539 | (if op | |
| 540 | (let ((constant (make-applform-simple (method-coarity op) op nil))) | |
| 541 | (push (cons variable constant) (goal-ind-constants goal)) | |
| 542 | constant) | |
| 543 | (let ((con (intro-const-returns-subst (goal-context goal) | |
| 544 | name | |
| 545 | svar))) | |
| 546 | (push con (goal-ind-constants goal)) | |
| 547 | (cdr con))))) | |
| 548 | (let ((v-assoc (find-variable-subst-in (goal-ind-constants goal) svar))) | |
| 549 | (or (cdr v-assoc) | |
| 550 | (let ((v-name (cdr (find-variable-subst-in (ptree-indvar-subst *proof-tree*) svar))) | |
| 551 | (vconst nil)) | |
| 552 | (unless v-name | |
| 553 | (setq v-name (make-ind-const-name (variable-name variable) | |
| 554 | (or sort (variable-sort svar))))) | |
| 555 | (setq vconst (make-iv-const v-name)) | |
| 556 | (pushnew (cons svar v-name) (ptree-indvar-subst *proof-tree*) :test #'equal) | |
| 557 | vconst)))))) | |
| 800 | (let ((svar (if sort | |
| 801 | (make-variable-term sort (intern (format nil "~a_~a" | |
| 802 | (variable-name variable) | |
| 803 | (sort-name sort)))) | |
| 804 | variable))) | |
| 805 | (flet ((make-iv-const (name) | |
| 806 | (if op | |
| 807 | (let ((constant (make-applform-simple (method-coarity op) op nil))) | |
| 808 | (push (cons variable constant) (goal-ind-constants goal)) | |
| 809 | constant) | |
| 810 | (let ((con (intro-const-returns-subst (goal-context goal) | |
| 811 | name | |
| 812 | svar))) | |
| 813 | (push con (goal-ind-constants goal)) | |
| 814 | (cdr con))))) | |
| 815 | (let ((v-assoc (find-variable-subst-in (goal-ind-constants goal) svar))) | |
| 816 | (or (cdr v-assoc) | |
| 817 | (let ((v-name (cdr (find-variable-subst-in (ptree-indvar-subst *proof-tree*) svar))) | |
| 818 | (vconst nil)) | |
| 819 | (unless v-name | |
| 820 | (setq v-name (make-ind-const-name (variable-name variable) | |
| 821 | (or sort (variable-sort svar))))) | |
| 822 | (setq vconst (make-iv-const v-name)) | |
| 823 | (pushnew (cons svar v-name) (ptree-indvar-subst *proof-tree*) :test #'equal) | |
| 824 | vconst)))))) | |
| 825 | ||
| 826 | ;;; SKOLEMITIZE | |
| 827 | ;;; allow citp to represent the goal sentence in FOPLE-SENTENCE | |
| 828 | (defun skolemize-if-need (fax) | |
| 829 | (unless (eq (axiom-type fax) :pignose-axiom) | |
| 830 | (return-from skolemize-if-need fax)) | |
| 831 | (with-citp-debug () | |
| 832 | (format t "~%[skolemize]: ") | |
| 833 | (print-axiom-brief fax)) | |
| 834 | (let* ((sentence (axiom-lhs fax)) | |
| 835 | (type (fopl-sentence-type sentence)) | |
| 836 | (*sk-function-num* nil)) | |
| 837 | (declare (type symbol type) | |
| 838 | (special *sk-function-num*)) | |
| 839 | (when (and (memq type '(:eq :beq)) | |
| 840 | (term-is-lisp-form? (term-arg-2 sentence))) | |
| 841 | (return-from skolemize-if-need fax)) | |
| 842 | ;; normalize quantified formula | |
| 843 | ;; \Q[v1...vn]S --> \Q[v1]\Q[v2]...\Q[vn]S | |
| 844 | (normalize-quantifiers sentence) | |
| 845 | ;; convert to NNF(negation normal form.) | |
| 846 | (setq sentence (neg-normal-form sentence)) | |
| 847 | ;; skolemization -- eliminate \Es | |
| 848 | (skolemize sentence) | |
| 849 | ;; skolemize may introduce new operators. | |
| 850 | (prepare-for-parsing *current-module*) | |
| 851 | ;; eliminate quantifiers -- eliminate \As | |
| 852 | (zap-quantifiers sentence) | |
| 853 | ;; convert to CNF(conjunctive normal form). | |
| 854 | (conj-normal-form sentence) | |
| 855 | ;; make it an equation | |
| 856 | (let ((ax (make-rule :lhs sentence | |
| 857 | :rhs *bool-true* | |
| 858 | :condition *bool-true* | |
| 859 | :labels (axiom-labels fax) | |
| 860 | :behavioural (axiom-is-behavioural fax) | |
| 861 | :type :equation))) | |
| 862 | (adjoin-axiom-to-module *current-module* ax) | |
| 863 | ax))) | |
| 558 | 864 | |
| 559 | 865 | ;;; |
| 560 | 866 | ;;; initialize-proof-tree : module goal -> ptree |
| 561 | 867 | ;;; |
| 562 | 868 | (defun initialize-proof-tree (context-module goal-module initial-goals) |
| 563 | (let ((root (make-ptree-root goal-module initial-goals))) | |
| 564 | (setq *next-default-proof-node* nil) | |
| 565 | (make-ptree :root root :context context-module))) | |
| 869 | (with-in-module (goal-module) | |
| 870 | (let ((*sk-function-num* nil)) | |
| 871 | (declare (special *sk-function-num*)) | |
| 872 | (let* ((targets (mapcar #'skolemize-if-need initial-goals)) | |
| 873 | (root (make-ptree-root goal-module targets))) | |
| 874 | (setq *next-default-proof-node* nil) | |
| 875 | (make-ptree :root root :context context-module))))) | |
| 566 | 876 | |
| 567 | 877 | ;;; |
| 568 | 878 | ;;; check-success : ptree -> Bool |
| 572 | 882 | (when unp |
| 573 | 883 | (format t "~%>> Next target goal is ~s." (goal-name (ptree-node-goal (car unp)))) |
| 574 | 884 | (setq *next-default-proof-node* (car unp)) |
| 575 | (format t "~%>> Remaining ~d goal~p." (length unp) (length unp)) | |
| 885 | (format t "~%>> Remaining ~d goal~p.~%" (length unp) (length unp)) | |
| 576 | 886 | (return-from check-success nil)) |
| 577 | 887 | (format t "~%** All goals are successfully discharged.~%") |
| 578 | 888 | (setq *next-default-proof-node* nil) |
| 585 | 895 | (defun roll-back (ptree) |
| 586 | 896 | (declare (type ptree ptree)) |
| 587 | 897 | (let* ((current-target (get-next-proof-context ptree)) |
| 588 | (parent (and current-target (ptree-node-parent current-target)))) | |
| 898 | (parent (and current-target (ptree-node-parent current-target)))) | |
| 589 | 899 | (unless parent |
| 590 | 900 | (format t "~%**> :roll back, already at root.") |
| 591 | 901 | (setq *next-default-proof-node* nil) |
| 592 | 902 | (return-from roll-back nil)) |
| 593 | 903 | (setf (ptree-node-subnodes parent) nil |
| 594 | (ptree-node-num-children parent) 0 | |
| 595 | (ptree-node-next-child parent) 0) | |
| 904 | (ptree-node-num-children parent) 0 | |
| 905 | (ptree-node-next-child parent) 0) | |
| 596 | 906 | (format t "~%**> :roll back") |
| 597 | 907 | (setq *next-default-proof-node* nil) |
| 598 | 908 | (setq current-target (get-next-proof-context ptree)) |
| 605 | 915 | ;;; |
| 606 | 916 | (defun find-goal-node (ptree name) |
| 607 | 917 | (declare (type ptree ptree) |
| 608 | (type string name)) | |
| 918 | (type string name)) | |
| 609 | 919 | (dag-wfs (ptree-root ptree) |
| 610 | #'(lambda (n) (let ((goal (ptree-node-goal n))) | |
| 611 | (when (string= (goal-name goal) name) | |
| 612 | (return-from find-goal-node n)))))) | |
| 920 | #'(lambda (n) (let ((goal (ptree-node-goal n))) | |
| 921 | (when (string= (goal-name goal) name) | |
| 922 | (return-from find-goal-node n)))))) | |
| 613 | 923 | |
| 614 | 924 | ;;; |
| 615 | 925 | ;;; print-named-goal : name -> void |
| 620 | 930 | (format t "There is no proof tree.") |
| 621 | 931 | (return-from print-named-goal nil))) |
| 622 | 932 | (let ((goal-node (if name |
| 623 | (find-goal-node ptree name) | |
| 624 | (if (next-proof-target-is-specified?) | |
| 625 | (get-next-proof-context ptree) | |
| 626 | (with-output-chaos-error ('no-goal) | |
| 627 | (format t "No default goal is specified.")))))) | |
| 933 | (find-goal-node ptree name) | |
| 934 | (if (next-proof-target-is-specified?) | |
| 935 | (get-next-proof-context ptree) | |
| 936 | (with-output-chaos-error ('no-goal) | |
| 937 | (format t "No default goal is specified.")))))) | |
| 628 | 938 | (unless goal-node |
| 629 | 939 | (with-output-chaos-error ('no-such-goal) |
| 630 | (format t "No such goal with the name ~s" name))) | |
| 940 | (format t "No such goal with the name ~s" name))) | |
| 631 | 941 | (pr-goal (ptree-node-goal goal-node)))) |
| 632 | 942 | |
| 633 | 943 | ;;; |
| 636 | 946 | (defun get-unproved-nodes (ptree) |
| 637 | 947 | (let ((nodes nil)) |
| 638 | 948 | (dag-dfs (ptree-root ptree) |
| 639 | #'(lambda (x) (unless (or (ptree-node-subnodes x) (goal-is-discharged (ptree-node-goal x))) | |
| 640 | (push x nodes)))) | |
| 949 | #'(lambda (x) (unless (or (ptree-node-subnodes x) (goal-is-discharged (ptree-node-goal x))) | |
| 950 | (push x nodes)))) | |
| 641 | 951 | (nreverse nodes))) |
| 642 | 952 | |
| 643 | ;;; | |
| 644 | 953 | ;;; get-unproved-goals : ptree -> List(goal) |
| 645 | 954 | ;;; |
| 646 | 955 | (defun get-unproved-goals (ptree) |
| 647 | 956 | (mapcar #'(lambda (y) (ptree-node-goal y)) (get-unproved-nodes ptree))) |
| 648 | 957 | |
| 649 | ;;; | |
| 650 | 958 | ;;; print-unproved-goals |
| 651 | 959 | ;;; |
| 652 | 960 | (defun print-unproved-goals (ptree &optional (stream *standard-output*)) |
| 657 | 965 | (dolist (goal (get-unproved-goals ptree)) |
| 658 | 966 | (pr-goal goal stream))) |
| 659 | 967 | |
| 660 | ;;; | |
| 661 | 968 | ;;; get-next-pfoof-context : ptree -> ptree-node |
| 662 | 969 | ;;; |
| 663 | 970 | (defun get-next-proof-context (ptree) |
| 666 | 973 | |
| 667 | 974 | (defun next-proof-target-is-specified? () |
| 668 | 975 | *next-default-proof-node*) |
| 976 | ||
| 977 | ;;; get-target-goal-node | |
| 978 | ;;; given goal-name or NULL, returns the next targetted goal node. | |
| 979 | ;;; | |
| 980 | (defun get-target-goal-node (&optional goal-name) | |
| 981 | (let ((next-goal-node (if goal-name | |
| 982 | (find-goal-node *proof-tree* goal-name) | |
| 983 | (get-next-proof-context *proof-tree*)))) | |
| 984 | (unless next-goal-node | |
| 985 | (with-output-chaos-error ('no-target) | |
| 986 | (if goal-name | |
| 987 | (format t "Could not find the goal ~s." goal-name) | |
| 988 | (format t "No default target goal.")))) | |
| 989 | next-goal-node)) | |
| 669 | 990 | |
| 670 | 991 | ;;; |
| 671 | 992 | ;;; select-next-goal : goal-name |
| 676 | 997 | (with-output-chaos-error ('no-proof-tree) |
| 677 | 998 | (format t "No proof is ongoing."))) |
| 678 | 999 | (cond ((string= goal-name ".") |
| 679 | (setq *next-default-proof-node* nil) | |
| 680 | (let ((next (get-next-proof-context *proof-tree*))) | |
| 681 | (format t "~%:select resetting next default target ...") | |
| 682 | (unless next | |
| 683 | (with-output-chaos-warning () | |
| 684 | (format t "There is no unproved goal.") | |
| 685 | (return-from select-next-goal nil))) | |
| 686 | (format t "~%>> next default-goal is ~s" (goal-name (ptree-node-goal next))))) | |
| 687 | (t (let ((node (find-goal-node *proof-tree* goal-name))) | |
| 688 | (unless node | |
| 689 | (with-output-chaos-error ('no-goal) | |
| 690 | (format t "No such goal ~s" goal-name))) | |
| 691 | (when (node-is-discharged? node) | |
| 692 | (with-output-chaos-warning () | |
| 693 | (format t "The goal ~s is alreaday discharged." (goal-name (ptree-node-goal node))) | |
| 694 | (print-next) | |
| 695 | (format t "This will discard the current status of the goal.")) | |
| 696 | (make-it-unproved node)) | |
| 697 | (setq *next-default-proof-node* node) | |
| 698 | (when (eq node (ptree-root *proof-tree*)) | |
| 699 | (reset-proof *proof-tree*)) | |
| 700 | (format t "~%>> setting next default goal to ~s" (goal-name (ptree-node-goal node))) | |
| 701 | node)))) | |
| 1000 | (setq *next-default-proof-node* nil) | |
| 1001 | (let ((next (get-next-proof-context *proof-tree*))) | |
| 1002 | (format t "~%:select resetting next default target ...") | |
| 1003 | (unless next | |
| 1004 | (with-output-chaos-warning () | |
| 1005 | (format t "There is no unproved goal.") | |
| 1006 | (return-from select-next-goal nil))) | |
| 1007 | (format t "~%>> next default-goal is ~s" (goal-name (ptree-node-goal next))))) | |
| 1008 | (t (let ((node (find-goal-node *proof-tree* goal-name))) | |
| 1009 | (unless node | |
| 1010 | (with-output-chaos-error ('no-goal) | |
| 1011 | (format t "No such goal ~s" goal-name))) | |
| 1012 | (when (node-is-discharged? node) | |
| 1013 | (with-output-chaos-warning () | |
| 1014 | (format t "The goal ~s is alreaday discharged." (goal-name (ptree-node-goal node))) | |
| 1015 | (print-next) | |
| 1016 | (format t "This will discard the current status of the goal.")) | |
| 1017 | (make-it-unproved node)) | |
| 1018 | (setq *next-default-proof-node* node) | |
| 1019 | (when (eq node (ptree-root *proof-tree*)) | |
| 1020 | (reset-proof *proof-tree*)) | |
| 1021 | (format t "~%>> setting next default goal to ~s" (goal-name (ptree-node-goal node))) | |
| 1022 | node)))) | |
| 1023 | ||
| 1024 | ;;; Getting TACTIC | |
| 1025 | ;;; get-tactic : name -> LIST(tactic) | |
| 1026 | ;;; | |
| 1027 | (defun get-tactic (name) | |
| 1028 | (let ((context (get-next-proof-context *proof-tree*))) | |
| 1029 | (let ((tactic (or (and context (get-defined-tactic (ptree-node-goal context) name)) | |
| 1030 | (get-builtin-tactic name)))) | |
| 1031 | (unless tactic | |
| 1032 | (with-output-chaos-error ('no-such-tactic) | |
| 1033 | (format t "No such tactic is defined with the name ~s" name))) | |
| 1034 | (if (atom tactic) | |
| 1035 | (list tactic) | |
| 1036 | tactic)))) | |
| 702 | 1037 | |
| 703 | 1038 | ;;; ==================== |
| 704 | 1039 | ;;; TOP LEVEL FUNCTIONS |
| 711 | 1046 | |
| 712 | 1047 | ;;; for LE check |
| 713 | 1048 | ;; (defvar .int-module. nil) |
| 714 | (defvar .ls-pat. nil) ; X < Y | |
| 715 | (defvar .le-pat. nil) ; X <= Y | |
| 1049 | (defvar .ls-pat. nil) ; X < Y | |
| 1050 | (defvar .le-pat. nil) ; X <= Y | |
| 716 | 1051 | |
| 717 | 1052 | (defun prepare-root-context (root-module context-module) |
| 718 | 1053 | (unless .int-module. |
| 719 | 1054 | (setq .int-module. (eval-modexp "INT")) |
| 720 | 1055 | (with-in-module (.int-module.) |
| 721 | 1056 | (let ((less (find-operator '("_" "<" "_") 2 .int-module.)) |
| 722 | (le (find-operator '("_" "<=" "_") 2 .int-module.)) | |
| 723 | (less-m nil) | |
| 724 | (le-m nil) | |
| 725 | (var-x nil) | |
| 726 | (var-y nil) | |
| 727 | (int-sort (find-sort-in .int-module. '|Int|))) | |
| 728 | (setq less-m (lowest-method* (car (opinfo-methods less)))) | |
| 729 | (setq le-m (lowest-method* (car (opinfo-methods le)))) | |
| 730 | (setq var-x (make-variable-term int-sort 'X)) | |
| 731 | (setq var-y (make-variable-term int-sort 'Y)) | |
| 732 | (setq .ls-pat. (make-applform-simple *bool-sort* less-m (list var-x var-y))) | |
| 733 | (setq .le-pat. (make-applform-simple *bool-sort* le-m (list var-x var-y)))))) | |
| 1057 | (le (find-operator '("_" "<=" "_") 2 .int-module.)) | |
| 1058 | (less-m nil) | |
| 1059 | (le-m nil) | |
| 1060 | (var-x nil) | |
| 1061 | (var-y nil) | |
| 1062 | (int-sort (find-sort-in .int-module. '|Int|))) | |
| 1063 | (setq less-m (lowest-method* (car (opinfo-methods less)))) | |
| 1064 | (setq le-m (lowest-method* (car (opinfo-methods le)))) | |
| 1065 | (setq var-x (make-variable-term int-sort 'X)) | |
| 1066 | (setq var-y (make-variable-term int-sort 'Y)) | |
| 1067 | (setq .ls-pat. (make-applform-simple *bool-sort* less-m (list var-x var-y))) | |
| 1068 | (setq .le-pat. (make-applform-simple *bool-sort* le-m (list var-x var-y)))))) | |
| 734 | 1069 | (import-module root-module :protecting context-module) |
| 735 | 1070 | (import-module root-module :protecting .int-module.) |
| 736 | 1071 | (compile-module root-module t)) |
| 737 | 1072 | |
| 738 | 1073 | (defun begin-proof (context-module goal-axioms) |
| 739 | 1074 | (declare (type module context-module) |
| 740 | (type list goal-axioms)) | |
| 1075 | (type list goal-axioms)) | |
| 741 | 1076 | (unless goal-axioms (return-from begin-proof nil)) |
| 742 | 1077 | (let* ((*chaos-quiet* t) |
| 743 | (root-module (eval-ast .root-context-module.))) | |
| 1078 | (root-module (eval-ast .root-context-module.))) | |
| 744 | 1079 | (setf (module-hidden root-module) t) |
| 745 | 1080 | (prepare-root-context root-module context-module) |
| 746 | 1081 | (when .goals-so-far. |
| 747 | 1082 | (setq *modules-so-far-table* (remove-if #'(lambda (x) |
| 748 | (member (car x) .goals-so-far. :test #'equal)) | |
| 749 | *modules-so-far-table*)) | |
| 1083 | (member (car x) .goals-so-far. :test #'equal)) | |
| 1084 | *modules-so-far-table*)) | |
| 750 | 1085 | (setq .goals-so-far. nil)) |
| 751 | 1086 | (setq *proof-tree* (initialize-proof-tree context-module root-module goal-axioms)) |
| 752 | 1087 | (pr-goal (ptree-node-goal (ptree-root *proof-tree*))) |
| 754 | 1089 | (setq *next-default-proof-node* (ptree-root *proof-tree*)) |
| 755 | 1090 | *proof-tree*)) |
| 756 | 1091 | |
| 757 | ;;; | |
| 1092 | ;;; -------- | |
| 1093 | ;;; PRiNTERS | |
| 1094 | ;;; -------- | |
| 1095 | ||
| 758 | 1096 | ;;; print-proof-tree |
| 759 | 1097 | ;;; |
| 1098 | (defvar *show-proof-mode* :horizontal) | |
| 1099 | ||
| 760 | 1100 | (defun print-proof-tree (goal-name &optional (describe nil)) |
| 761 | 1101 | (unless *proof-tree* |
| 762 | 1102 | (with-output-chaos-warning () |
| 763 | 1103 | (format t "There is no proof tree.") |
| 764 | 1104 | (return-from print-proof-tree nil))) |
| 765 | 1105 | (let ((target-node (if goal-name |
| 766 | (or (find-goal-node *proof-tree* goal-name) | |
| 767 | (with-output-chaos-error ('no-such-goal) | |
| 768 | (format t "No goal with the name ~s." goal-name))) | |
| 769 | (ptree-root *proof-tree*)))) | |
| 1106 | (or (find-goal-node *proof-tree* goal-name) | |
| 1107 | (with-output-chaos-error ('no-such-goal) | |
| 1108 | (format t "No goal with the name ~s." goal-name))) | |
| 1109 | (ptree-root *proof-tree*)))) | |
| 770 | 1110 | (if describe |
| 771 | (describe-proof-tree target-node) | |
| 772 | (!print-proof-tree target-node (get-next-proof-context *proof-tree*))))) | |
| 773 | ||
| 774 | (defun !print-proof-tree (root-node next-target &optional (stream *standard-output*)) | |
| 1111 | (describe-proof-tree target-node) | |
| 1112 | (!print-proof-tree target-node (get-next-proof-context *proof-tree*) *show-proof-mode*)))) | |
| 1113 | ||
| 1114 | (defun !print-proof-tree (root-node next-target mode &optional (stream *standard-output*)) | |
| 1115 | (if (eq mode :horizontal) | |
| 1116 | (!print-proof-horizontal root-node next-target stream) | |
| 1117 | (!print-proof-vertical root-node next-target stream))) | |
| 1118 | ||
| 1119 | (defun !print-proof-vertical (root-node next-target stream) | |
| 775 | 1120 | (let* ((leaf? #'(lambda (node) (null (dag-node-subnodes node)))) |
| 776 | (leaf-name #'(lambda (node) | |
| 777 | (with-output-to-string (s) | |
| 778 | (let ((goal (ptree-node-goal node))) | |
| 779 | (when (eq node next-target) | |
| 780 | (princ ">" s)) | |
| 781 | (if (goal-tactic goal) | |
| 782 | (format s "~a ~a" (goal-tactic goal) (goal-name goal)) | |
| 783 | (princ (goal-name goal) s)) | |
| 784 | (when (node-is-discharged? node) | |
| 785 | (princ "*" s))) | |
| 786 | s))) | |
| 787 | (leaf-info #'(lambda (node) (declare (ignore node)) t)) | |
| 788 | (int-node-name #'(lambda (node) (funcall leaf-name node))) | |
| 789 | (int-node-children #'(lambda (node) (ptree-node-subnodes node)))) | |
| 1121 | (leaf-name #'(lambda (node) | |
| 1122 | (with-output-to-string (s) | |
| 1123 | (let ((goal (ptree-node-goal node))) | |
| 1124 | (when (eq node next-target) | |
| 1125 | (princ ">" s)) | |
| 1126 | (if (goal-tactic goal) | |
| 1127 | (format s "[~a] ~a" (tactic-name (goal-tactic goal)) (goal-name goal)) | |
| 1128 | (princ (goal-name goal) s)) | |
| 1129 | (when (node-is-discharged? node) | |
| 1130 | (princ "*" s))) | |
| 1131 | s))) | |
| 1132 | (leaf-info #'(lambda (node) (declare (ignore node)) t)) | |
| 1133 | (int-node-name #'(lambda (node) (funcall leaf-name node))) | |
| 1134 | (int-node-children #'(lambda (node) (ptree-node-subnodes node)))) | |
| 790 | 1135 | (force-output stream) |
| 791 | 1136 | (print-next nil *print-indent* stream) |
| 792 | 1137 | (print-trees (list (augment-tree root-node)) stream))) |
| 793 | 1138 | |
| 1139 | (defun !print-proof-horizontal (node next-target stream) | |
| 1140 | (let ((*standard-output* stream)) | |
| 1141 | (let ((goal (ptree-node-goal node))) | |
| 1142 | (with-in-module ((goal-context goal)) | |
| 1143 | (when (eq node next-target) | |
| 1144 | (princ ">")) | |
| 1145 | (if (goal-tactic goal) | |
| 1146 | (format t "[~a]~6T~a" (tactic-name (goal-tactic goal)) (goal-name goal)) | |
| 1147 | (format t "~a" (goal-name goal))) | |
| 1148 | (when (node-is-discharged? node) | |
| 1149 | (princ "*")))) | |
| 1150 | (let ((subnodes (ptree-node-subnodes node))) | |
| 1151 | (when subnodes | |
| 1152 | (let (;; (*print-indent* (+ 4 *print-indent*)) | |
| 1153 | ) | |
| 1154 | (dolist (sub subnodes) | |
| 1155 | (print-next-prefix #\Space) | |
| 1156 | (!print-proof-horizontal sub next-target stream))))))) | |
| 1157 | ||
| 1158 | ||
| 1159 | #|| | |
| 794 | 1160 | (defun describe-proof-tree (node) |
| 795 | 1161 | (declare (type ptree-node node)) |
| 796 | 1162 | (flet ((proved? () |
| 797 | (format nil "~:[unproved~;proved~]" (node-is-discharged? node)))) | |
| 1163 | (format nil "~:[unproved~;proved~]" (node-is-discharged? node)))) | |
| 798 | 1164 | (let ((goal (ptree-node-goal node)) |
| 799 | (*print-line-limit* 80) | |
| 800 | (*print-xmode* :fancy)) | |
| 1165 | (*print-line-limit* 80) | |
| 1166 | (*print-xmode* :fancy)) | |
| 801 | 1167 | (with-in-module ((goal-context goal)) |
| 802 | (if (goal-tactic goal) | |
| 803 | (format t "~a=> GOAL(~a) ~a" (goal-tactic goal) (goal-name goal) (proved?)) | |
| 804 | (format t "=> GOAL(~a) ~a" (goal-name goal) (proved?))) | |
| 805 | (princ " ------------------------") | |
| 806 | (let ((*print-indent* (+ 4 *print-indent*))) | |
| 807 | (print-next) | |
| 808 | (format t "** context module: ~a" (get-module-simple-name *current-module*)) | |
| 809 | (let ((assumptions (goal-assumptions goal))) | |
| 810 | (when assumptions | |
| 811 | (print-next) | |
| 812 | (format t "** assumption~p" (length assumptions)) | |
| 813 | (let ((*print-indent* (+ 2 *print-indent*))) | |
| 814 | (dolist (as assumptions) | |
| 815 | (print-next) | |
| 816 | (print-axiom-brief as))))) | |
| 817 | (let ((proved (goal-proved goal))) | |
| 818 | (when proved | |
| 819 | (print-next) | |
| 820 | (format t "** discharged sentence~p:" (length proved)) | |
| 821 | (let ((*print-indent* (+ 2 *print-indent*))) | |
| 822 | (dolist (ax proved) | |
| 823 | (print-next) | |
| 824 | (print-axiom-brief ax))))) | |
| 825 | (let ((targets (goal-targets goal))) | |
| 826 | (when targets | |
| 827 | (print-next) | |
| 828 | (if (node-is-discharged? node) | |
| 829 | (format t "** targeted sentence~p:" (length targets)) | |
| 830 | (format t "** sentence~p to be proved:" (length targets))) | |
| 831 | (let ((*print-indent* (+ 2 *print-indent*))) | |
| 832 | (dolist (target targets) | |
| 833 | (print-next) | |
| 834 | (print-axiom-brief target))))))) | |
| 1168 | (if (goal-tactic goal) | |
| 1169 | (format t "[~a]=> GOAL(~a) ~a" (tactic-name (goal-tactic goal)) (goal-name goal) (proved?)) | |
| 1170 | (format t "=> GOAL(~a) ~a" (goal-name goal) (proved?))) | |
| 1171 | (princ " ------------------------") | |
| 1172 | (let ((*print-indent* (+ 4 *print-indent*))) | |
| 1173 | (print-next) | |
| 1174 | (format t "** context module: ~a" (get-module-simple-name *current-module*)) | |
| 1175 | (let ((assumptions (goal-assumptions goal))) | |
| 1176 | (when assumptions | |
| 1177 | (print-next) | |
| 1178 | (format t "** assumption~p" (length assumptions)) | |
| 1179 | (let ((*print-indent* (+ 2 *print-indent*)) | |
| 1180 | (*print-xmode* :fancy)) | |
| 1181 | (dolist (as assumptions) | |
| 1182 | (print-next) | |
| 1183 | (print-axiom-brief as) | |
| 1184 | (princ " ."))))) | |
| 1185 | (let ((proved (goal-proved goal))) | |
| 1186 | (when proved | |
| 1187 | (print-next) | |
| 1188 | (format t "** discharged sentence~p:" (length proved)) | |
| 1189 | (let ((*print-indent* (+ 2 *print-indent*))) | |
| 1190 | (dolist (ax proved) | |
| 1191 | (print-next) | |
| 1192 | (print-axiom-brief ax) | |
| 1193 | (princ " ."))))) | |
| 1194 | (let ((targets (goal-targets goal))) | |
| 1195 | (when targets | |
| 1196 | (print-next) | |
| 1197 | (if (node-is-discharged? node) | |
| 1198 | (format t "** targeted sentence~p:" (length targets)) | |
| 1199 | (format t "** sentence~p to be proved:" (length targets))) | |
| 1200 | (let ((*print-indent* (+ 2 *print-indent*))) | |
| 1201 | (dolist (target targets) | |
| 1202 | (print-next) | |
| 1203 | (print-axiom-brief target) | |
| 1204 | (princ " ."))))))) | |
| 835 | 1205 | (let ((subnodes (ptree-node-subnodes node))) |
| 836 | (when subnodes | |
| 837 | (let ((*print-indent* (+ 2 *print-indent*))) | |
| 838 | (dolist (sub subnodes) | |
| 839 | (print-next-prefix #\.) | |
| 840 | (describe-proof-tree sub)))))))) | |
| 841 | ||
| 842 | ;;; | |
| 1206 | (when subnodes | |
| 1207 | (let ((*print-indent* (+ 2 *print-indent*))) | |
| 1208 | (dolist (sub subnodes) | |
| 1209 | (print-next-prefix #\.) | |
| 1210 | (describe-proof-tree sub)))))))) | |
| 1211 | ||# | |
| 1212 | ||
| 1213 | (defparameter *proof-indent* 0) | |
| 1214 | ||
| 1215 | (defun describe-proof-tree (node) | |
| 1216 | (declare (type ptree-node node)) | |
| 1217 | (flet ((proved? () | |
| 1218 | ;; (format nil "~:[unproved~;proved~]" (node-is-discharged? node)) | |
| 1219 | (format nil "~:[ ~;*~]" (node-is-discharged? node)))) | |
| 1220 | (let ((goal (ptree-node-goal node)) | |
| 1221 | (*print-line-limit* 80) | |
| 1222 | (*print-xmode* :fancy)) | |
| 1223 | (with-in-module ((goal-context goal)) | |
| 1224 | (if (goal-tactic goal) | |
| 1225 | (format t "[~a]~8T~a~a" (tactic-name (goal-tactic goal)) (goal-name goal) (proved?)) | |
| 1226 | (format t "==> ~a~a" (goal-name goal) (proved?))) | |
| 1227 | ;; (princ " ------------------------") | |
| 1228 | (let ((*print-indent* (+ 4 *print-indent*))) | |
| 1229 | (print-next) | |
| 1230 | (format t "-- context module: ~a" (get-module-simple-name *current-module*)) | |
| 1231 | (let ((assumptions (goal-assumptions goal))) | |
| 1232 | (when assumptions | |
| 1233 | (print-next) | |
| 1234 | (format t "-- assumption~p" (length assumptions)) | |
| 1235 | (let ((*print-indent* (+ 2 *print-indent*)) | |
| 1236 | (*print-xmode* :fancy)) | |
| 1237 | (dolist (as assumptions) | |
| 1238 | (print-next) | |
| 1239 | (print-axiom-brief as) | |
| 1240 | (princ " ."))))) | |
| 1241 | (let ((proved (goal-proved goal))) | |
| 1242 | (when proved | |
| 1243 | (print-next) | |
| 1244 | (format t "-- discharged sentence~p:" (length proved)) | |
| 1245 | (let ((*print-indent* (+ 2 *print-indent*))) | |
| 1246 | (dolist (ax proved) | |
| 1247 | (print-next) | |
| 1248 | (print-axiom-brief ax) | |
| 1249 | (princ " ."))))) | |
| 1250 | (let ((targets (goal-targets goal))) | |
| 1251 | (when targets | |
| 1252 | (print-next) | |
| 1253 | (if (node-is-discharged? node) | |
| 1254 | (format t "-- targeted sentence~p:" (length targets)) | |
| 1255 | (format t "-- sentence~p to be proved:" (length targets))) | |
| 1256 | (let ((*print-indent* (+ 2 *print-indent*))) | |
| 1257 | (dolist (target targets) | |
| 1258 | (print-next) | |
| 1259 | (print-axiom-brief target) | |
| 1260 | (princ " ."))))))) | |
| 1261 | (let ((subnodes (ptree-node-subnodes node))) | |
| 1262 | (when subnodes | |
| 1263 | (let ((*print-indent* (+ *proof-indent* *print-indent*))) | |
| 1264 | (dolist (sub subnodes) | |
| 1265 | (print-next-prefix #\.) | |
| 1266 | (describe-proof-tree sub)))))))) | |
| 1267 | ||
| 843 | 1268 | ;;; print-current-goal : mode -> void |
| 844 | 1269 | ;;; |
| 845 | 1270 | (defun print-current-goal (describe) |
| 846 | 1271 | (let ((current (get-next-proof-context *proof-tree*))) |
| 847 | 1272 | (if current |
| 848 | (if describe ; :describe | |
| 849 | (pr-goal (ptree-node-goal current)) | |
| 850 | (format t "~%The current goal is ~a" (goal-name (ptree-node-goal current)))) | |
| 1273 | (if describe ; :describe | |
| 1274 | (pr-goal (ptree-node-goal current)) | |
| 1275 | (format t "~%The current goal is ~a" (goal-name (ptree-node-goal current)))) | |
| 851 | 1276 | (with-output-chaos-warning () |
| 852 | (format t "All goals have been discharged."))))) | |
| 1277 | (format t "All goals have been discharged."))))) | |
| 1278 | ||
| 1279 | ;;; print-defs | |
| 1280 | ;;; | |
| 1281 | (defun print-defs (describe &optional goal-name) | |
| 1282 | (declare (ignore describe)) | |
| 1283 | (let ((current (if goal-name | |
| 1284 | (find-goal-node *proof-tree* goal-name) | |
| 1285 | (get-next-proof-context *proof-tree*)))) | |
| 1286 | (if current | |
| 1287 | (let* ((goal (ptree-node-goal current)) | |
| 1288 | (defs (goal-defs goal))) | |
| 1289 | (unless defs | |
| 1290 | (format t "~%The goal ~a has no defs.~%" (goal-name goal)) | |
| 1291 | (return-from print-defs nil)) | |
| 1292 | (dolist (def defs) | |
| 1293 | (format t "~a = " (tactic-name def)) | |
| 1294 | (princ def) | |
| 1295 | (print-next))) | |
| 1296 | (with-output-chaos-warning () | |
| 1297 | (format t "No current goal."))))) | |
| 1298 | ||
| 853 | 1299 | |
| 854 | 1300 | ;;; EOF |
| 0 | 0 | ;;; |
| 1 | ;;; Copyright (c) 2000-2014, Toshimi Sawada. All rights reserved. | |
| 1 | ;;; Copyright (c) 2000-2015, Toshimi Sawada. All rights reserved. | |
| 2 | 2 | ;;; |
| 3 | 3 | ;;; Redistribution and use in source and binary forms, with or without |
| 4 | 4 | ;;; modification, are permitted provided that the following conditions |
| 38 | 38 | (if (not (equal "" cafeobj-version-memo)) |
| 39 | 39 | (if (not (equal "" patch-level)) |
| 40 | 40 | (setq cafeobj-version-minor |
| 41 | (format nil "@VMINOR@(~a,~A)" | |
| 42 | cafeobj-version-memo | |
| 43 | patch-level)) | |
| 44 | (setq cafeobj-version-minor | |
| 45 | (format nil "@VMINOR@(~a)" cafeobj-version-memo))) | |
| 41 | (format nil "@VMINOR@(~a,~A)" | |
| 42 | cafeobj-version-memo | |
| 43 | patch-level)) | |
| 44 | (setq cafeobj-version-minor | |
| 45 | (format nil "@VMINOR@(~a)" cafeobj-version-memo))) | |
| 46 | 46 | (setq cafeobj-version-minor "@VMINOR@")) |
| 47 | 47 | (setq cafeobj-version (concatenate 'string |
| 48 | cafeobj-version-major | |
| 49 | cafeobj-version-minor)) | |
| 48 | cafeobj-version-major | |
| 49 | cafeobj-version-minor)) | |
| 50 | 50 | ) |
| 51 | 51 | ;; EOF |
| 1 | 1 | # |
| 2 | 2 | # cafeobj wrapper script |
| 3 | 3 | # |
| 4 | # Copyright (c) 2000-2014, Toshimi Sawada. All rights reserved. | |
| 5 | # Copyright (c) 2014, Norbert Preining. All rights reserved. | |
| 4 | # Copyright (c) 2000-2014 Toshimi Sawada. All rights reserved. | |
| 5 | # Copyright (c) 2014-2015 Norbert Preining. All rights reserved. | |
| 6 | 6 | # |
| 7 | 7 | # Redistribution and use in source and binary forms, with or without |
| 8 | 8 | # modification, are permitted provided that the following conditions |
| 60 | 60 | libpath="$binpath/../@LIBPATH@" |
| 61 | 61 | sharepath="$binpath/../@SHAREPATH@" |
| 62 | 62 | |
| 63 | dohelp=0 | |
| 64 | ||
| 63 | 65 | engine=@FIRSTCHOICE@ |
| 64 | 66 | |
| 65 | 67 | while [ $# -gt 0 ] |
| 66 | 68 | do |
| 67 | 69 | key="$1" |
| 68 | 70 | case $key in |
| 71 | # don't shift away, will be handled by the cafeobj interpreter | |
| 72 | -h|-help|--help) dohelp=1 ; break ;; | |
| 69 | 73 | -engine|--engine) shift ; engine="$1" ; shift ;; |
| 70 | 74 | -wrapper-libpath|--wrapper-libpath) shift ; libpath="$1" ; shift ;; |
| 71 | 75 | -wrapper-sharepath|--wrapper-sharepath) shift ; sharepath="$1" ; shift ;; |
| 86 | 90 | *) break ;; |
| 87 | 91 | esac |
| 88 | 92 | done |
| 93 | ||
| 94 | if [ "$dohelp" = 1 ] ; then | |
| 95 | echo ' | |
| 96 | Usage: cafeobj [wrapper-options] [options] files ... | |
| 97 | ||
| 98 | Wrapper options: | |
| 99 | -engine NAME select the underlying Common Lisp engine. | |
| 100 | -list-engines lists all available common lisp engines | |
| 101 | -wrapper-libpath PATH sets the path to memory dumps | |
| 102 | -wrapper-sharepath PATH sets the path to CafeOBJ initialization files | |
| 103 | ' | |
| 104 | fi | |
| 89 | 105 | |
| 90 | 106 | case "x$engine" in |
| 91 | 107 | xacl) |