Commit d50924668624ff6d69771ea0ad34092c2d911ef5 - cafeobj

Redefine term structure. tswd 6 years ago

2 changed file(s) with 728 addition(s) and 1024 deletion(s). Raw diff Collapse all Expand all

+728

-0

chaos/primitives/bterm.lisp less more

	0	;;;--Mode:LISP; Package: Chaos; Base:10; Syntax:Common-lisp --
	1	;;;
	2	;;; Copyright (c) 2000-2018, 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: primitives.chaos
	32	File: term2.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	;;;**********
	40	;;; TERM CELL
	41	;;;*****************************************************************************
	42	;;; <TERM> ::= <Variable> \| <ApplForm > \| <LispForm> \| <PsuedoConstant>
	43	;;; \| <BuiltInConstant> \| <SystemObject> ...
	44	;;; * implementation
	45	;;; <TERM> == ( . )
	46	;;; \|
	47	;;; V
	48	;;; <BASE-TERM>
	49	;;;*****************************************************************************
	50
	51	;;; ============================================================================
	52	;;; BASE-TERM : common 'term' body structure
	53	;;; ============================================================================
	54
	55	(defstruct (base-term (:conc-name "TERM$") (:type list))
	56	(type 0 :type fixnum) ; variable, application form ...
	57	(status 0 :type fixnum) ; lowest parsed, reduced ...
	58	(sort nil :type sort*)) ; sort of the term
	59
	60	(declaim (inline is-base-term-variant))
	61	;;; should be enough for determining if an object is constructed from 'term-base'.
	62	;;; used for determing an object is a term. the term itself is a cons containing a
	63	;;; single 'term-base' object.
	64	(defun is-base-term-variant (x)
	65	(and (consp x) ; it's a cons
	66	(typep (car x) 'fixnum) ; first element has type of fixnum
	67	(typep (cadr x) 'fixnum) ; second element has status of fixnum
	68	(cdddr x))) ; and must have additional constructs
	69	(deftype term-body ()
	70	`(satisfies is-base-term-variant))
	71
	72	;;; TERM-TYPE represents kind of a term
	73	;;; #x001 : variable
	74	;;; #x002 : application form
	75	;;; #x004 : simple lisp code
	76	;;; #x008 : general lisp code
	77	;;; #x00c : simple OR general lisp code
	78	;;; #x010 : psuedo constant
	79	;;; #x011 : variable treated as constant (variable AND psuedo constant)
	80	;;; #x020 : pure builtin constant
	81	;;; #x040 : system object
	82	;;; $x070 : builtin constant (psuedo constant OR pure builtin OR system object)
	83
	84	(defconstant variable-type #x01)
	85	(defconstant application-form-type #x02)
	86	(defconstant simple-lisp-form-type #x04)
	87	(defconstant general-lisp-form-type #x08)
	88	;;; this type requires one of them is on
	89	(defconstant lisp-form-type (logior simple-lisp-form-type general-lisp-form-type))
	90	(defconstant psuedo-constant-type #x10)
	91	(defconstant pure-builtin-constant-type #x20)
	92	(defconstant system-object-type #x40)
	93	;;; this type requires one of them is on
	94	(defconstant builtin-constant-type (logior psuedo-constant-type
	95	pure-builtin-constant-type
	96	system-object-type))
	97	;;; this type requires both flags are on
	98	(defconstant constant-variable-type (logior variable-type
	99	psuedo-constant-type))
	100
	101	;;; TERM-STATUS
	102	;;; represents states
	103	;;; #x1000 : reduced flag : on iff the term is reduced.
	104	;;; #x2000 : lowest parsed flag : on iff the term is lowest parsed.
	105	;;; #x4000 : on demand flag : on iff the term is on deman.
	106	;;; #x8000 : red flag : on iff the term's context is not beh congruent.
	107
	108	(defconstant reduced-flag #x01)
	109	(defconstant lowest-parsed-flag #x02)
	110	(defconstant on-demand-flag #x04)
	111	(defconstant red-flag #x08)
	112
	113	;;; ============================================================================
	114	;;; TERM
	115	;;; 'term' is a cell containing a variation of BASE-TERM
	116	;;; ============================================================================
	117
	118	(defun is-term (obj)
	119	(and (consp obj)
	120	(typep (car obj) 'term-body)))
	121
	122	(deftype term () `(satisfies is-term))
	123
	124	;;; BASIC ACCESSORS
	125	;;; ---------------
	126
	127	;;; TERM-BODY term -> BASE-TERM
	128	(defmacro term-body (term) `(car ,term))
	129
	130	;;; TERM-CODE
	131	;;;
	132	(defmacro term-type (term) `(term$type (term-body ,term)))
	133
	134	;;; TERM-STATUS
	135	;;;
	136	(defmacro term-status (term) `(term$status (term-body ,term)))
	137
	138	;;; TERM-SORT
	139	;;; ---------
	140
	141	;;; from term
	142	(defmacro term-sort (term) `(term$sort (term-body ,term)))
	143
	144	;;; BASIC CONSTRUCTORS
	145	;;; ------------------
	146	(defmacro create-term (obj) `(list ,obj))
	147
	148	;;; make new term reusing existing term body
	149	(defmacro new-term (_term) `(create-term (term-body ,_term)))
	150
	151	;;; PREDICATES
	152	;;; ----------
	153
	154	;;; term-eq : term1 term2 -> bool
	155	;;; returns t iff "term1" and "term2" are exactly the same object.
	156	(defmacro term-eq (t1 t2) `(eq (term-body ,t1) (term-body ,t2)))
	157
	158	;;; term-equal : term1 term2 -> bool
	159	;;; t iff "term1" and "term2" has the same representation.
	160	(defmacro term-equal (t1 t2) `(equal ,t1 ,t2))
	161
	162	;;; type predicate
	163	;;; TERM? : object -> bool
	164	(defmacro term? (object)
	165	(once-only (object)
	166	`(and (consp ,object)
	167	(typep (car ,object) 'term-body))))
	168
	169	;;; TERM-REPLACE : from to -> from'
	170	;;; term1 is modified so that its body becomes a body of term to.
	171	;;;
	172	(defmacro term-replace (from to)
	173	`(setf (term-body ,from) (term-body ,to)))
	174
	175	;;; ============================================================================
	176	;;; VARIANTS OF BASE-TERM
	177	;;; ============================================================================
	178
	179	;;; --------
	180	;;; VARIABLE
	181	;;; --------
	182	(defstruct (variable (:type list) (:conc-name "VARIABLE$")
	183	(:include base-term
	184	(type variable-type)
	185	;; NOTE: variables are always 'reduced' and 'lowest parsed'
	186	(status (logior reduced-flag lowest-parsed-flag))))
	187	(name nil) ; name
	188	(print-name nil)) ; name used for printing
	189
	190	;;; ---------------
	191	;;; PSUEDO-CONSTNAT
	192	;;; used for a temporal(on-the-fly) constant value in a constrained context
	193	;;; ---------------
	194	(defstruct (pconst (:type list) (:conc-name "PCONST$")
	195	(:include variable
	196	(type psuedo-constant-type)
	197	;; NOTE: pconst is treated as 'lowest parsed' but not always 'reduced'
	198	(status lowest-parsed-flag :type fixnum))))
	199
	200	;;; --------------------
	201	;;; Operator APPLICATION
	202	;;; --------------------
	203	(defstruct (application (:type list) (:conc-name "APPL$")
	204	(:include base-term
	205	(type application-form-type)))
	206	(head nil) ; operator
	207	(subterms nil :type list)) ; list of subterms
	208
	209	;;; ---------------------
	210	;;; PURE Builtin CONSTANT
	211	;;; ---------------------
	212	(defstruct (pure-builtin (:type list) (:conc-name "BUILTIN$")
	213	(:include base-term
	214	(type pure-builtin-constant-type)
	215	;; builtin constants are treated as 'reduced' and 'lowest parsed'
	216	(status (logior reduced-flag lowest-parsed-flag))))
	217	(value nil) ; builtin value (a lisp object)
	218	)
	219
	220	;;; -------------
	221	;;; SYSTEM OBJECT
	222	;;; -------------
	223	(defstruct (system-object (:type list) (:conc-name "SYSTEM$")
	224	(:include pure-builtin
	225	(type system-object-type))))
	226
	227	;;; ----------------
	228	;;; SIMPLE-LISP FORM
	229	;;; ----------------
	230	(defstruct (simple-lisp-form (:type list) (:conc-name "LISP-FORM$")
	231	(:include base-term
	232	(type simple-lisp-form-type)
	233	;; simple-lisp-form is treated as 'reduced' and 'lowest parsed'
	234	(status (logior reduced-flag lowest-parsed-flag))))
	235	(function nil) ;
	236	(original-form nil) ; the original lisp code
	237	)
	238
	239	;;; -----------------
	240	;;; GENERAL-LISP FORM
	241	;;; -----------------
	242	(defstruct (general-lisp-form (:type list)
	243	(:include simple-lisp-form
	244	(type general-lisp-form-type))))
	245
	246	;;; --------------------
	247	;;; TERM TYPE PREDICATES -------------------------------------------------------
	248	;;; ============================================================================
	249	(defmacro term-type-eq (?t1 ?t2)
	250	`(eq (term$type (term-body ,?t1))
	251	(term$type (term-body ,?t2))))
	252
	253	;;; TEST by accessing trm-body
	254	(defmacro term$is-variable? (_term-body)
	255	`(eq variable-type (term$type ,_term-body)))
	256	(defmacro term$is-application-form? (_term-body)
	257	`(eq application-form-type (term$type ,_term-body)))
	258	(defmacro term$is-applform? (_term-body) ; synonym
	259	`(term$is-application-form? ,_term-body))
	260	(defmacro term$is-simple-lisp-form? (_term-body)
	261	`(eq simple-lisp-form-type (term$type ,_term-body)))
	262	(defmacro term$is-general-lisp-form? (_term-body)
	263	`(eq general-lisp-form-type (term$type ,_term-body)))
	264	(defmacro term$is-lisp-form? (_term-body)
	265	`(test-and lisp-form-type (term$type ,_term-body)))
	266	(defmacro term$is-pure-builtin-constant? (_term-body)
	267	`(eq pure-builtin-constant-type (term$type ,_term-body)))
	268	(defmacro term$is-builtin-constant? (_term-body)
	269	`(test-and builtin-constant-type (term$type ,_term-body)))
	270	(defmacro term$is-pconstant? (_term-body)
	271	`(eq psuedo-constant-type (term$type ,_term-body)))
	272	(defmacro term$is-system-object? (_term-body)
	273	`(eq system-object-type (term$type ,_term-body)))
	274	(defmacro term$is-constant-variable? (_term-body)
	275	`(eq constant-variable-type (term$type ,_term-body)))
	276
	277	;;; TEST via term cell
	278	(defmacro term-is-variable? (_term)
	279	`(term$is-variable? (term-body ,_term)))
	280	(defmacro term-is-application-form? (_term)
	281	`(term$is-application-form? (term-body ,_term)))
	282	(defmacro term-is-applform? (_term)
	283	`(term$is-application-form? (term-body ,_term)))
	284	(defmacro term-is-lisp-form? (_term)
	285	`(term$is-lisp-form? (term-body ,_term)))
	286	(defmacro term-is-simple-lisp-form? (_term)
	287	`(term$is-simple-lisp-form? (term-body ,_term)))
	288	(defmacro term-is-general-lisp-form? (_term)
	289	`(term$is-general-lisp-form? (term-body ,_term)))
	290	(defmacro term-is-pure-builtin-constant? (_term)
	291	`(term$is-pure-builtin-constant? (term-body ,_term)))
	292	(defmacro term-is-builtin-constant? (_term)
	293	`(term$is-builtin-constant? (term-body ,_term)))
	294	(defmacro term-is-pconstant? (_term)
	295	`(term$is-pconstant? (term-body ,_term)))
	296	(defmacro term-is-system-object? (_term)
	297	`(term$is-system-object? (term-body ,_term)))
	298	(defmacro term-is-chaos-expr? (_term)
	299	`(and (term-is-builtin-constant? ,_term)
	300	(eq chaos-value-sort (term-sort ,_term))
	301	(let ((value (term-builtin-value ,_term)))
	302	(and (consp value)
	303	(eq (car value) '\|%Chaos\|)))))
	304	(defmacro term-is-constant-variable? (_term)
	305	`(term$is-constant-variable? (term-body ,_term)))
	306
	307	;;; TERM-IS-CONSTANT? : term -> bool
	308	;;; note we include variable-type and psuedo-constant-type for safety.
	309	(defconstant priori-constant-type
	310	(logior variable-type lisp-form-type builtin-constant-type
	311	psuedo-constant-type
	312	system-object-type))
	313
	314	(defmacro term$is-constant? (_body)
	315	(once-only (_body)
	316	`(or (test-and priori-constant-type (term$type ,_body))
	317	(and (term$is-application-form? ,_body)
	318	(null (term$subterms ,_body))))))
	319
	320	(defmacro term-is-constant? (_term)
	321	`(term$is-constant? (term-body ,_term)))
	322
	323	;;; CHANGING treatment of vairables according to a situation.
	324	;;; when we reduce a term with variables, we want treate them as if
	325	;;; they are constants.
	326	;; mark variable as if its a constant
	327	(defmacro mark-variable-as-constant (term)
	328	(once-only (term)
	329	`(and (term-is-variable? ,term)
	330	(setf (term-type ,term) constant-variable-type))))
	331	(defmacro unmark-variable-as-constant (term)
	332	(once-only (term)
	333	`(and (term-is-constant-variable? ,term)
	334	(setf (term-type ,term) variable-type))))
	335
	336	;;; ----------------------
	337	;;; TERM STATUS PREDICATES -----------------------------------------------------
	338	;;; ============================================================================
	339
	340	(defmacro term$test-reduced-flag (term-body)
	341	`(test-and reduced-flag (term$status ,term-body)))
	342
	343	(defmacro term-is-reduced? (_term)
	344	`(term$test-reduced-flag (term-body ,_term)))
	345
	346	;;; red flag
	347	;;; --------
	348	(defmacro term$test-red-flag (term-body)
	349	`(test-and red-flag (term$status ,term-body)))
	350
	351	(defmacro term-is-red (term)
	352	`(term$test-red-flag (term-body ,term)))
	353
	354	;;; lowest parsed flag
	355	;;; ------------------
	356
	357	(defmacro term$test-lowest-parsed-flag (term-body)
	358	`(test-and lowest-parsed-flag (term$status ,term-body)))
	359
	360	(defmacro term-is-lowest-parsed? (_term)
	361	`(term$test-lowest-parsed-flag (term-body ,_term)))
	362
	363	;;; on demand flag
	364	;;; --------------
	365
	366	(defmacro term$test-on-demand-flag (term-body)
	367	`(test-and on-demand-flag (term$status ,term-body)))
	368
	369	(defmacro term-is-on-demand? (_term)
	370	`(term$test-on-demand-flag (term-body ,_term)))
	371
	372	;;; --------------------
	373	;;; TERM STATUS SETTERS --------------------------------------------------------
	374	;;; ============================================================================
	375
	376	;;; reduced flag
	377	;;; -------------
	378	(defmacro term$set-reduced-flag (term-body)
	379	(once-only (term-body)
	380	`(setf (term$status ,term-body)
	381	(make-or reduced-flag (term$status ,term-body)))))
	382
	383	(defmacro term-set-reduced-flag (term)
	384	`(term$set-reduced-flag (term-body ,term)))
	385
	386	(defmacro mark-term-as-reduced (_term) ; synonym
	387	`(term-set-reduced-flag ,_term))
	388
	389	(defmacro term$unset-reduced-flag (term-body)
	390	(once-only (term-body)
	391	`(setf (term$status ,term-body)
	392	(make-xor reduced-flag (term$status ,term-body)))))
	393
	394	(defmacro term-unset-reduced-flag (term)
	395	`(term$unset-reduced-flag (term-body ,term)))
	396
	397	(defmacro mark-term-as-not-reduced (_term) ; synonym
	398	`(term-unset-reduced-flag ,_term))
	399
	400	;;; red flag
	401	;;; --------
	402	(defmacro term$set-red-flag (term-body)
	403	(once-only (term-body)
	404	`(setf (term$status ,term-body)
	405	(make-or red-flag (term$status ,term-body)))))
	406
	407	(defmacro term-set-red (term)
	408	`(term$set-red-flag (term-body ,term)))
	409
	410	(defmacro term$set-green (term-body)
	411	(once-only (term-body)
	412	`(setf (term$status ,term-body)
	413	(make-xor red-flag (term$status ,term-body)))))
	414
	415	(defmacro term-set-green (term)
	416	`(term$set-green (term-body ,term)))
	417
	418	;;; lowest parsed flag
	419	;;; -------------------
	420
	421	(defmacro term$set-lowest-parsed-flag (term-body)
	422	(once-only (term-body)
	423	`(setf (term$status ,term-body)
	424	(make-or lowest-parsed-flag
	425	(term$status ,term-body)))))
	426
	427	(defmacro term-set-lowest-parsed-flag (term)
	428	`(term$set-lowest-parsed-flag (term-body ,term)))
	429
	430	(defmacro mark-term-as-lowest-parsed (_term) ; synonym
	431	`(term-set-lowest-parsed-flag ,_term))
	432
	433	(defmacro term$unset-lowest-parsed-flag (term-body)
	434	(once-only (term-body)
	435	`(setf (term$status ,term-body)
	436	(make-xor lowest-parsed-flag
	437	(term$status ,term-body)))))
	438
	439	(defmacro term-unset-lowest-parsed-flag (term)
	440	`(term$unset-lowest-parsed-flag (term-body ,term)))
	441
	442	(defmacro mark-term-as-not-lowest-parsed (_term) ; synonym
	443	`(term-unset-lowest-parsed-flag ,_term))
	444
	445	;;; on demand flag
	446	;;; --------------
	447
	448	(defmacro term$set-on-demand-flag (term-body)
	449	(once-only (term-body)
	450	`(setf (term$status ,term-body)
	451	(make-or on-demand-flag
	452	(term$status ,term-body)))))
	453
	454	(defmacro term-set-on-demand-flag (term)
	455	`(term$set-on-demand-flag (term-body ,term)))
	456
	457	(defmacro mark-term-as-on-demand (_term) ; synonym
	458	`(term-set-on-demand-flag ,_term))
	459
	460	(defmacro term$unset-on-demand-flag (term-body)
	461	(once-only (term-body)
	462	`(setf (term$status ,term-body)
	463	(make-xor on-demand-flag
	464	(term$status ,term-body)))))
	465
	466	(defmacro term-unset-on-demand-flag (term)
	467	`(term$unset-on-demand-flag ,term))
	468
	469	(defmacro mark-term-as-not-on-demand (_term) ; synonym
	470	`(term-unset-on-demand-flag ,_term))
	471
	472
	473	;;; ----------------------------------------
	474	;;; ACCESSORS of each term strucure variants --------------------------------
	475	;;; =========================================================================
	476
	477	;;; -----------------
	478	;;; APPLICATION FORM
	479	;;; -----------------
	480	(defmacro term-head (_term) `(appl$head (term-body ,_term)))
	481
	482	(defmacro change$head-operator (_body _op)
	483	`(setf (appl$head ,_body) ,_op))
	484
	485	(defmacro change-head-operator (_term _op)
	486	`(change$head-operator (term-body ,_term) ,_op))
	487
	488	;;; subterms
	489	;;; all of the followings are setf'able
	490	(defmacro term$subterms (_term-body) `(appl$subterms ,_term-body))
	491	(defmacro term$arg-1 (_term-body) `(car (appl$subterms ,_term-body)))
	492	(defmacro term$arg-2 (_term-body) `(cadr (appl$subterms ,_term-body)))
	493	(defmacro term$arg-3 (_term-body) `(caddr (appl$subterms ,_term-body)))
	494	(defmacro term$arg-4 (_term-body) `(cadddr (appl$subterms ,_term-body)))
	495	(defmacro term$arg-n (_term-body n)
	496	` (the term
	497	(nth (the fixnum ,n) (appl$subterms ,_term-body))))
	498	(defmacro term-subterms (_term) `(appl$subterms (term-body ,_term)))
	499	(defmacro term-arg-1 (_term) `(car (term-subterms ,_term)))
	500	(defmacro term-arg-2 (_term) `(cadr (term-subterms ,_term)))
	501	(defmacro term-arg-3 (_term) `(caddr (term-subterms ,_term)))
	502	(defmacro term-arg-4 (_term) `(cadddr (term-subterms ,_term)))
	503	(defmacro term-arg-n (_term n)
	504	` (nth (the fixnum ,n)
	505	(term-subterms ,_term)))
	506
	507	;;; -------------
	508	;;; VARIABLE TERM
	509	;;; -------------
	510	(defmacro variable-sort (_term) `(term$sort (term-body ,_term)))
	511	(defmacro variable-name (_term) `(variable$name (term-body ,_term)))
	512	(defmacro variable-print-name (_term) `(variable$print-name (term-body ,_term)))
	513
	514	;;; --------------
	515	;;; PCONSTANT TERM
	516	;;; --------------
	517	(defmacro pconst-sort (_term) `(term$sort (term-body ,_term)))
	518	(defmacro pconst-name (_term) `(pconst$name (term-body ,_term)))
	519	(defmacro pconst-print-name (_term) `(pconst$print-name (term-body ,_term)))
	520
	521	;;; ----------------
	522	;;; BUILTIN CONSTANT
	523	;;; ----------------
	524	(defmacro term$builtin-value (_term-body) `(builtin$value ,_term-body))
	525	(defmacro term-builtin-value (_term) `(term$builtin-value (term-body ,_term)))
	526
	527	;;; TERM-BUILTIN-EQUAL : term1 term2 -> bool
	528	;;; assume term1 is builtin constant term
	529	(defmacro term$builtin-equal (_builtin-body _term-body)
	530	(once-only (_term-body)
	531	`(and (term$is-builtin-constant? ,_term-body)
	532	(equal (term$builtin-value ,_builtin-body)
	533	(term$builtin-value ,_term-body)))))
	534
	535	(defmacro term-builtin-equal (_bi-term _term)
	536	`(term$builtin-equal (term-body ,_bi-term) (term-body ,_term)))
	537
	538	;;; -----------
	539	;;; CHAOS-VALUE
	540	;;; -----------
	541	(defmacro chaos-form-expr (_term)
	542	`(nth 1 (term-builtin-value ,_term)))
	543	(defmacro chaos-original-expr (_term)
	544	`(nth 2 (term-builtin-value ,_term)))
	545
	546	;;; ---------------
	547	;;; PSUEDO-CONSTANT
	548	;;; ---------------
	549	(defmacro term$psuedo-constant-name (_term-body) `(pconst$name ,_term-body))
	550	(defmacro psuedo-constant-name (_term) `(term$psuedo-constant-name (term-body ,_term)))
	551
	552	;;; ---------
	553	;;; LISP FORM
	554	;;; ---------
	555	(defmacro term$lisp-function (term-body) `(lisp-form$function ,term-body))
	556	(defmacro term-lisp-function (term) `(term$lisp-function (term-body ,term)))
	557	(defmacro lisp-form-function (term) `(term-lisp-function ,term)) ; synonym
	558
	559	(defmacro term$lisp-code-original-form (term-body)
	560	`(lisp-form$original-form ,term-body))
	561	(defmacro term$lisp-form-original-form (term-body)
	562	`(term$lisp-code-original-form ,term-body)) ; synonym
	563	(defmacro lisp-code-original-form (term)
	564	`(term$lisp-code-original-form (term-body ,term)))
	565	(defmacro lisp-form-original-form (term)
	566	`(lisp-code-original-form ,term)) ; synonym
	567
	568	;;; -------------
	569	;;; SYSTEM OBJECT
	570	;;; -------------
	571	(defmacro term$system-object (_term-body) `(system$value ,_term-body))
	572	(defmacro term-system-object (_term) `(term$system-object (term-body ,_term)))
	573
	574
	575	;;;*****************************************************************************
	576	;;; TERM CONSTRUCTORS
	577	;;;*****************************************************************************
	578
	579	;;; ********
	580	;;; VARIABLE ___________________________________________________________________
	581	;;; ********
	582
	583	;;; NOTE variables are always considered as reduced.
	584	;;; lowest parsed flag is also set to on.
	585
	586	(defconstant var-const-code
	587	(logior variable-type reduced-flag lowest-parsed-flag))
	588
	589	(declaim (inline make-variable-term))
	590
	591	(defun make-variable-term (sort variable-name &optional (print-name variable-name))
	592	(create-term (make-variable :sort sort :name variable-name :print-name print-name)))
	593
	594	(defmacro variable-copy (var)
	595	(once-only (var)
	596	`(make-variable-term (variable-sort ,var)
	597	(variable-name ,var)
	598	(variable-print-name ,var))))
	599
	600	;;; ****************
	601	;;; APPLICATION-FORM ___________________________________________________________
	602	;;; ****************
	603	(declaim (inline make-application-term))
	604
	605	(defun make-application-term (op sort subterms)
	606	(create-term (make-application :head op :sort sort :subterms subterms)))
	607
	608	;;; ****************
	609	;;; SIMPLE-LISP-CODE ___________________________________________________________
	610	;;; ****************
	611	(declaim (inline make-simple-lisp-form-term))
	612
	613	(defun make-simple-lisp-form-term (original-form)
	614	(create-term (make-simple-lisp-form :original-form original-form
	615	:sort cosmos)))
	616
	617	;;; *****************
	618	;;; GENERAL-LISP-CODE __________________________________________________________
	619	;;; *****************
	620	(declaim (inline make-general-lisp-form-term))
	621
	622	(defun make-general-lisp-form-term (original-form)
	623	(create-term (make-general-lisp-form :original-form original-form
	624	:sort cosmos)))
	625
	626	;;; ****************
	627	;;; BUILTIN CONSTANT ___________________________________________________________
	628	;;; ****************
	629	(declaim (inline make-bconst-term))
	630
	631	(defun make-bconst-term (sort value)
	632	(create-term (make-pure-builtin :value value :sort sort)))
	633
	634	;;; ***************
	635	;;; PSUEDO CONSTANT____________________________________________________________
	636	;;; ***************
	637	(declaim (inline make-pconst-term))
	638
	639	(defun make-pconst-term (sort name &optional (print-name name))
	640	(create-term (make-pconst :sort sort :name name :print-name print-name)))
	641
	642	(defmacro pconst-copy (var)
	643	(once-only (var)
	644	`(make-pconst-term (pconst-sort ,var)
	645	(pconst-name ,var)
	646	(pconst-print-name ,var))))
	647
	648	;;; *************
	649	;;; SYSTEM OBJECT ____________________________________________________________
	650	;;; *************
	651	(declaim (inline make-system-object-term))
	652
	653	(defun make-system-object-term (value sort)
	654	(create-term (make-system-object :value value :sort sort)))
	655
	656	;;;*****************************************************************************
	657	;;; BASIC UTILITIES
	658	;;;*****************************************************************************
	659
	660	;;; TERM-VARIABLES : term -> LIST[variable]
	661	;;;
	662	(defun term-variables (term)
	663	(let ((body (term-body term)))
	664	(cond ((term$is-variable? body) (list term))
	665	((term$is-constant? body) nil)
	666	(t (let ((res nil))
	667	(declare (type list res))
	668	(dolist (st (appl$subterms body) res)
	669	(setq res (delete-duplicates (append res (term-variables st))
	670	:test #'(lambda (x y)
	671	(term-eq x y))))))))))
	672
	673	(defun term-pvariables (term)
	674	(let ((body (term-body term)))
	675	(cond ((term$is-pconstant? body) (list term))
	676	((or (term$is-constant? body) (term$is-variable? body)) nil)
	677	(t (let ((res nil))
	678	(declare (type list res))
	679	(dolist (st (appl$subterms body) res)
	680	(setq res (delete-duplicates (append res (term-pvariables st))
	681	:test #'(lambda (x y)
	682	(eq (variable-name x)
	683	(variable-name y)))))))))))
	684
	685	(defun term-constant-variables (term)
	686	(let ((body (term-body term)))
	687	(cond ((term$is-constant-variable? body) (list term))
	688	((term$is-constant? body) nil)
	689	(t (let ((res nil))
	690	(declare (type list res))
	691	(dolist (st (appl$subterms body) res)
	692	(setq res (delete-duplicates (append res (term-constant-variables st))
	693	:test #'(lambda (x y)
	694	(eq (variable-name x)
	695	(variable-name y)))))))))))
	696
	697	(declaim (inline variables-occur-at-top?))
	698
	699	(defun variables-occur-at-top? (term)
	700	(block variables-occur-at-top-exit
	701	(dolist (st (term-subterms term))
	702	(when (term-is-variable? st)
	703	(return-from variables-occur-at-top-exit t)))))
	704
	705	;;; TERM-IS-GROUND? : term -> bool
	706	;;;
	707	(defmacro term$is-ground? (_body)
	708	(once-only (_body)
	709	`(block success
	710	(cond ((term$is-variable? ,_body) (return-from success nil))
	711	((term$is-application-form? ,_body)
	712	(dolist (st (appl$subterms ,_body) t)
	713	(unless (term-is-ground? st)
	714	(return-from success nil))))
	715	(t t)))))
	716
	717	(defun term-is-ground? (xx_term)
	718	(term$is-ground? (term-body xx_term)))
	719
	720	;;; SIMPLE-COPY-TERM : term -> new-term
	721	;;; copies term.
	722	;;;
	723	(declaim (inline simple-copy-term))
	724	(defun simple-copy-term (term)
	725	(copy-tree (the list term)))
	726
	727	;;; EOF

-1024

~~chaos/primitives/term2.lisp~~ less more

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: primitives.chaos
32		File: term2.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		;;;**********
40		;;; TERM CELL
41		;;;*****************************************************************************
42		;;; <TERM> ::= <Variable> \| <ApplForm > \| <SimpleLispForm> \| <PsuedoVariable>
43		;;; <GeneralLispForm> \| <BuiltInConstant> \| <SystemObject>
44		;;;
45		;;; Implementation:
46		;;; ( . )
47		;;; \|
48		;;; V
49		;;; <TermBody>
50		;;;*****************************************************************************
51
52		;;; TYPE -----------------------------------------------------------------------
53		(deftype term () 'cons)
54		;;; (deftype term-body () 'simple-vector)
55		(deftype term-body () 'cons)
56		;;;
57		(defmacro termp (obj)
58		(once-only (obj)
59		`(and (consp ,obj) (consp (car ,obj)) (integerp (caar ,obj)))))
60
61		(defun is-term? (obj) (termp obj))
62
63		;;; accessor ___________________________________________________________________
64		(defmacro term-body (_term) `(car ,_term))
65
66		;;; constructor
67		(defmacro create-term (obj) `(list ,obj))
68		(defmacro new-term (_term) `(create-term (term-body ,_term)))
69
70		;;; term-eq : term1 term2 -> bool ______________________________________________
71		;;; returns t iff "term1" and "term2" are exactly the same object.
72		;;;
73		(defmacro term-eq (t1 t2) `(eq (term-body ,t1) (term-body ,t2)))
74		(defmacro term-equal (t1 t2) `(equal ,t1 ,t2))
75		;;- function varsion
76		(defun !term-eq (t1 t2) (eq (term-body t1) (term-body t2)))
77
78		;;; term-replace : from to -> from' ____________________________________________
79		;;; term1 is modified so that its body becomes a body of term to.
80		;;;
81		(defmacro term-replace (from to) `(setf (term-body ,from) (term-body ,to)))
82
83		;;;****************************
84		;;; GENERAL TERM BODY STRUCTURE
85		;;;****************************
86		;;; - encoded terms ************************************************************
87		;;; ( term-code encoded-term-contents )
88		;;; 1. variable
89		;;; encoded-term-contents ::= variable-code sort-m-code
90		;;; 2. application-form
91		;;; encoded-term-contents ::= operator-code sort-id-bit subterms
92		;;; 3. lisp-code
93		;;; encoded-term-contents ::= lisp-function sort-id-bit
94		;;; 4. builtin-constant
95		;;; encoded-term-contents ::= builtin-value sort-id-bit
96		;;; 5. system-object
97		;;; encoded-term-contents ::= object-value sort-id-bit
98		;;; 6. psuedo-variable
99		;;; encoded-term-contents ::= variable-code sort-id-bit
100		;;;
101		;;; - decoded (pre encoded) terms *********************************************
102		;;; ( term-code pre-encoded-term-content )
103		;;; 1. variable
104		;;; pre-encoded-term-contents ::= variable-name sort
105		;;; 2. application-form
106		;;; pre-encoded-term-contents ::= method sort subterms
107		;;; 3. lisp-code
108		;;; pre-encoded-term-contents ::= lisp-function sort orignal-form
109		;;; 4. builtin-constant
110		;;; pre-encoded-term-contents ::= builtin-value sort
111		;;; 5. system-object
112		;;; pre-encoded-term-contents ::= object-value sort
113		;;; 6. psuedo-variable
114		;;; pre-encoded-term-contents ::= variable-name sort
115		;;;
116
117		;;;-----------------------------------------------------------------------------
118		;;; TERM-CODE Values : fixnum (16bits)
119		;;;-----------------------------------------------------------------------------
120
121		;;; TERM-CODE PART is a 16bits fixnum coded flags:
122		;;; lower 12 bits : kind (variable, application form, etc.)
123		;;; higher 4 bits : status (reduced, lowest parsed, on demamd)
124
125		;;; LOWER 12 bits **************************************************************
126		;;; represents kinds:
127		;;; #x001 : variable
128		;;; #x002 : application form
129		;;; #x004 : simple lisp code
130		;;; #x008 : general lisp code
131		;;; #x010 : psuedo constant bit
132		;;; #x030 : builtin constant
133		;;; #x040 : system object
134
135		;;;
136		;;; #x101 : decoded variable
137		;;; #x102 : decoded application term
138		;;; #x104 : decoded simple lisp code
139		;;; #x108 : decoded general lisp code
140		;;; #x110 : decoded psuedo constant
141		;;; #x130 : decoded builtin constant
142		;;; #x140 : decoded system object
143
144		(defconstant variable-type #x001)
145		(defconstant application-form-type #x002)
146		(defconstant simple-lisp-code-type #x004)
147		(defconstant general-lisp-code-type #x008)
148		(defconstant lisp-code-type (logior simple-lisp-code-type general-lisp-code-type))
149		(defconstant psuedo-constant-type #x010)
150		(defconstant pure-builtin-constant-type #x020)
151		(defconstant system-object-type #x040)
152		(defconstant builtin-constant-type (logior psuedo-constant-type
153		pure-builtin-constant-type
154		system-object-type))
155		(defconstant pre-encode-bit #x100)
156		(defconstant pre-variable-type (logior pre-encode-bit variable-type))
157		(defconstant pre-application-form-type (logior pre-encode-bit
158		application-form-type))
159		(defconstant pre-simple-lisp-code-type (logior pre-encode-bit
160		simple-lisp-code-type))
161		(defconstant pre-general-lisp-code-type (logior pre-encode-bit
162		general-lisp-code-type))
163		(defconstant pre-lisp-code-type (logior pre-encode-bit lisp-code-type))
164		(defconstant pre-psuedo-constant-type
165		(logior pre-encode-bit psuedo-constant-type))
166		(defconstant pre-builtin-constant-type (logior pre-encode-bit
167		builtin-constant-type))
168		(defconstant pre-pure-builtin-constant-type
169		(logior pre-encode-bit pure-builtin-constant-type))
170		(defconstant pre-system-object-type (logior pre-encode-bit system-object-type))
171
172		;;; HIGHER 4 bits *************************************************************
173		;;; represents state:
174		;;; #x1000 : reduced flag : on iff the term is reduced.
175		;;; #x2000 : lowest parsed flag : on iff the term is lowest parsed.
176		;;; #x4000 : on demand flag : on iff the term is on deman.
177		;;; #x8000 : red flag : on iff the term's context is not beh congruent.
178
179		(defconstant reduced-flag #x1000)
180		(defconstant lowest-parsed-flag #x2000)
181		(defconstant on-demand-flag #x4000)
182		(defconstant red-flag #x8000)
183
184		;;; ******************
185		;;; ACCESS BY POSITION ---------------------------------------------------------
186		;;; ******************
187		;;; Access BODY DIRECTLY
188		;;; (defmacro body-1st (o) `(%svref ,o 0))
189		;;; (defmacro body-2nd (o) `(%svref ,o 1))
190		;;; (defmacro body-3rd (o) `(%svref ,o 2))
191		;;; (defmacro body-4th (o) `(%svref ,o 3))
192
193		(defmacro body-1st (o) `(car ,o ))
194		(defmacro body-2nd (o) `(cadr ,o ))
195		(defmacro body-3rd (o) `(caddr ,o ))
196		(defmacro body-4th (o) `(cadddr ,o ))
197
198		;;; VIA TERM CELL
199		(defmacro term-1st (o) `(body-1st (car ,o)))
200		(defmacro term-2nd (o) `(body-2nd (car ,o)))
201		(defmacro term-3rd (o) `(body-3rd (car ,o)))
202		(defmacro term-4th (o) `(body-4th (car ,o)))
203
204		;;; *************
205		;;; ACCES BY NAME ______________________________________________________________
206		;;; *************
207
208		;;;-----------------------------------------------------------------------------
209		;;; CODE : the 1st part
210		;;;-----------------------------------------------------------------------------
211		;;; from body
212		(defmacro term$code (term-body) `(the fixnum (body-1st ,term-body)))
213		;;; from term
214		(defmacro term-code (term) `(the fixnum (term-1st ,term)))
215
216		;;;
217		;;; TYPE-EQ for terms
218		;;;
219		(defconstant term-type-mask #x0ff)
220
221		(defmacro term-type-eq (?t1 ?t2)
222		` (= (the fixnum (make-and (term-code ,?t1) ,term-type-mask))
223		(the fixnum (make-and (term-code ,?t2) ,term-type-mask))))
224
225		(defun term-type (t1)
226		(let ((code (term-code t1)))
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))))
235
236		;;;-----------------------------------------------------------------------------
237		;;; SORT/SORT-CODE : the 3rd part
238		;;;-----------------------------------------------------------------------------
239		;;; from body
240		(defmacro term$sort (term-body) `(the sort (body-3rd ,*term-body)))
241		(defmacro term$sort-code (term-body) `(the fixnum (body-3rd ,term-body)))
242		;;; from term
243		(defmacro term-sort (term) `(the sort (term-3rd ,*term)))
244		(defmacro term-sort-code (term) `(the fixnum (term-3rd ,term)))
245
246		(defmacro variable$sort (term-body) `(the sort (body-3rd ,*term-body)))
247		(defmacro variable-sort (term-body) `(the sort (term-3rd ,*term-body)))
248
249		;;;-----------------------------------------------------------------------------
250		;;; THE 2nd part
251		;;; varies for each types:
252		;;; (1) application form : op-code or method
253		;;; (2) builtin constant : builtin value
254		;;; (3) lisp form : lisp function
255		;;; (4) variable : variable-code or variable name
256		;;; (5) psuedo constant : constant-code or variable name
257		;;; (6) system object : object
258		;;;-----------------------------------------------------------------------------
259
260		;;; APPLICATION FORM :
261
262		(defmacro term$op-code (_term-body) `(body-2nd ,_term-body))
263		(defmacro term$method (_term-body) `(the method (body-2nd ,_term-body)))
264		(defmacro term$head (_term-body) `(body-2nd ,_term-body))
265		(defmacro term-op-code (_term) `(term-2nd ,_term))
266		(defmacro term-method (_term) `(the method (term-2nd ,_term)))
267		(defmacro term-head (_term) `(term-2nd ,_term))
268
269		(defmacro change$head-operator (_body _op)
270		`(setf (body-2nd ,_body) ,_op))
271		(defmacro change-head-operator (_term _op)
272		`(setf (term-2nd ,_term) ,_op))
273
274		;;; VARIABLE TERM :
275
276		(defmacro term$variable-code (_term-body) `(body-2nd ,_term-body))
277		(defmacro variable$name (_term-body) `(body-2nd ,_term-body))
278		(defmacro variable$print-name (_term-body) `(body-4th ,_term-body))
279		(defmacro term-variable-code (_term) `(term-2nd ,_term))
280		(defmacro variable-name (_term) `(term-2nd ,_term))
281		(defmacro variable-print-name (_term) `(term-4th ,_term))
282
283		;;; BUILTIN CONSTANT :
284
285		(defmacro term$builtin-value (_term-body) `(body-2nd ,_term-body))
286		(defmacro term-builtin-value (_term) `(term-2nd ,_term))
287
288		;;; CHAOS-VALUE
289		(defmacro chaos-form-expr (_term)
290		`(nth 1 (term-builtin-value ,_term)))
291		(defmacro chaos-original-expr (_term)
292		`(nth 2 (term-builtin-value ,_term)))
293
294		;;; PSUEDO-CONSTANT
295		;;; just the same as BUILTIN CONSTANT
296		(defmacro term$psuedo-constant-code (_term-body) `(body-2nd ,_term-body))
297		(defmacro term$psuedo-constant-name (_term-body) `(body-2nd ,_term-body))
298		(defmacro psuedo-constant-code (_term) `(term-2nd ,_term))
299		(defmacro psuedo-constant-name (_term) `(term-2nd ,_term))
300
301		;;; LISP FORM :
302
303		(defmacro term$lisp-function (_term-body) `(body-2nd ,_term-body))
304		(defmacro term-lisp-function (_term) `(term-2nd ,_term))
305		(defmacro lisp-form-function (_term) `(term-2nd ,_term)) ; synonym
306
307
308		;;; SYSTEM OBJECT :
309
310		(defmacro term$system-object (_term-body) `(body-2nd ,_term-body))
311		(defmacro term-system-object (_term) `(term-2nd ,_term))
312
313		;;;-----------------------------------------------------------------------------
314		;;; THE REST PART
315		;;;
316		;;; (term-type {opcode \| builtin-value \| lisp-function} sort-code rest)
317		;;; 1 2 3 4
318		;;; the rest part of a term (term-type sort-code rest)
319		;;; term type : contents
320		;;; ==========================================================================
321		;;; lisp-code : rest = orignal-form
322		;;; 4
323		;;; application-form : rest = subterms
324		;;; 4
325		;;;-----------------------------------------------------------------------------
326		;;; LISP FORM :
327		;;; setf'able
328		(defmacro term$lisp-code-original-form (_term-body)
329		`(body-4th ,_term-body))
330		(defmacro term$lisp-form-original-form (_term-body)
331		`(body-4th ,_term-body)) ; synonym
332		(defmacro lisp-code-original-form (_term)
333		`(term-4th ,_term))
334		(defmacro lisp-form-original-form (_term)
335		`(term-4th ,_term)) ; synonym
336
337		;;; APPLICATION FORM :
338		;;; all are setf'able
339		(defmacro term$subterms (_term-body) `(the list (body-4th ,_term-body)))
340		(defmacro term-subterms (_term) (the list `(term-4th ,_term)))
341
342		;;; subterm accessors
343		(defmacro term$arg-1 (_term-body) `(car (term$subterms ,_term-body)))
344		(defmacro term$arg-2 (_term-body) `(cadr (term$subterms ,_term-body)))
345		(defmacro term$arg-3 (_term-body) `(caddr (term$subterms ,_term-body)))
346		(defmacro term$arg-4 (_term-body) `(cadddr (term$subterms ,_term-body)))
347		(defmacro term$arg-n (_term-body n)
348		` (the term
349		(nth (the fixnum ,n) (term$subterms ,_term-body))))
350
351		(defmacro term-arg-1 (_term) `(car (term-subterms ,_term)))
352		(defmacro term-arg-2 (_term) `(cadr (term-subterms ,_term)))
353		(defmacro term-arg-3 (_term) `(caddr (term-subterms ,_term)))
354		(defmacro term-arg-4 (_term) `(cadddr (term-subterms ,_term)))
355		(defmacro term-arg-n (_term n)
356		` (nth (the fixnum ,n)
357		(term-subterms ,_term)))
358
359		;;; *****************
360		;;; term type testers___________________________________________________________
361		;;; *****************
362
363		;;; check from term type.
364
365		(defmacro term-code$is-decoded? (_term-code)
366		`(test-and pre-encode-bit ,_term-code))
367
368		;;; note : the following predicate does not get be affected by
369		;;; pre-endcode bit.
370
371		(defmacro term-code$is-variable? (_term-code)
372		`(test-and ,_term-code variable-type))
373		(defmacro term-code$is-application-form? (_term-code)
374		`(test-and ,_term-code application-form-type))
375		(defmacro term-code$is-lisp-code? (_term-code)
376		`(test-and ,_term-code lisp-code-type))
377		(defmacro term-code$is-simple-lisp-code? (_term-code)
378		`(test-and ,_term-code simple-lisp-code-type))
379		(defmacro term-code$is-general-lisp-code? (_term-code)
380		`(test-and ,_term-code general-lisp-code-type))
381		(defmacro term-code$is-builtin-constant? (_term-code)
382		`(test-and ,_term-code builtin-constant-type))
383		(defmacro term-code$is-pure-builtin-constant? (_term-code)
384		`(test-and ,_term-code pure-builtin-constant-type))
385		(defmacro term-code$is-psuedo-constant? (_term-code)
386		`(test-and ,_term-code psuedo-constant-type))
387		(defmacro term-code$is-system-object? (_term-code)
388		`(test-and ,_term-code system-object-type))
389
390		;;; test via body directly
391
392		(defmacro term$is-variable? (_term-body)
393		`(term-code$is-variable? (term$code ,_term-body)))
394		(defmacro term$is-application-form? (_term-body)
395		`(term-code$is-application-form? (term$code ,_term-body)))
396		(defmacro term$is-applform? (_term-body)
397		`(term-code$is-application-form? (term$code ,_term-body)))
398		(defmacro term$is-lisp-code? (_term-body)
399		`(term-code$is-lisp-code? (term$code ,_term-body)))
400		(defmacro term$is-lisp-form? (_term-body)
401		`(term-code$is-lisp-code? (term$code ,_term-body)))
402		(defmacro term$is-simple-lisp-code? (_term-body)
403		`(term-code$is-simple-lisp-code? (term$code ,_term-body)))
404		(defmacro term$is-simple-lisp-form? (_term-body)
405		`(term-code$is-simple-lisp-code? (term$code ,_term-body)))
406		(defmacro term$is-general-lisp-code? (_term-body)
407		`(term-code$is-general-lisp-code? (term$code ,_term-body)))
408		(defmacro term$is-general-lisp-form? (_term-body)
409		`(term-code$is-general-lisp-code? (term$code ,_term-body)))
410		(defmacro term$is-pure-builtin-constant? (_term-body)
411		`(term-code$is-pure-builtin-constant? (term$code ,_term-body)))
412		(defmacro term$is-builtin-constant? (_term-body)
413		`(term-code$is-builtin-constant? (term$code ,_term-body)))
414		(defmacro term$is-psuedo-constant? (_term-body)
415		`(term-code$is-psuedo-constant? (term$code ,_term-body)))
416		(defmacro term$is-system-object? (_term-body)
417		`(term-code$is-system-object? (term$code ,_term-body)))
418
419		;;; test via term cell
420
421		(defmacro term-is-variable? (_term)
422		`(term-code$is-variable? (term-code ,_term)))
423		(defmacro term-is-application-form? (_term)
424		`(term-code$is-application-form? (term-code ,_term)))
425		(defmacro term-is-applform? (_term)
426		`(term-code$is-application-form? (term-code ,_term)))
427		(defmacro term-is-lisp-form? (_term)
428		`(term-code$is-lisp-code? (term-code ,_term)))
429		(defmacro term-is-simple-lisp-form? (_term)
430		`(term-code$is-simple-lisp-code? (term-code ,_term)))
431		(defmacro term-is-general-lisp-form? (_term)
432		`(term-code$is-general-lisp-code? (term-code ,_term)))
433		(defmacro term-is-pure-builtin-constant? (_term)
434		`(term-code$is-pure-builtin-constant? (term-code ,_term)))
435		(defmacro term-is-builtin-constant? (_term)
436		`(term-code$is-builtin-constant? (term-code ,_term)))
437		(defmacro term-is-psuedo-constant? (_term)
438		`(term-code$is-psuedo-constant? (term-code ,_term)))
439		(defmacro term-is-system-object? (_term)
440		`(term-code$is-system-object? (term-code ,_term)))
441		(defmacro term-is-chaos-expr? (_term)
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\|)))))
447
448		;;; ******************
449		;;; TERM STATE TESTERS _________________________________________________________
450		;;; and SETTERS
451		;;; ******************
452
453		;;; just a synonym of term$code, term-code
454		(defmacro term$state-flag (__term-body) `(body-1st ,__term-body))
455		(defmacro term-state-flag (__term) `(term-1st ,__term))
456
457		;;;; STATE TESTERS
458
459		;;; reduced flag
460
461		(defmacro term$test-reduced-flag (*term-body)
462		`(test-and reduced-flag (term$state-flag ,*term-body)))
463		(defmacro term-test-reduced-flag (*term)
464		`(test-and reduced-flag (term-state-flag ,*term)))
465		(defmacro term-is-reduced? (_term) ; synonym
466		`(term-test-reduced-flag ,_term))
467
468		;;; red flag
469
470		(defmacro term$test-red-flag (*term-body)
471		`(test-and red-flag (term$state-flag ,*term-body)))
472		(defmacro term-test-red-flag (*term)
473		`(test-and red-flag (term-state-flag ,*term)))
474		(defmacro term-is-red (_term)
475		`(test-and red-flag (term-state-flag ,_term)))
476
477		;;; lowest parsed flag
478
479		(defmacro term$test-lowest-parsed-flag (*term-body)
480		`(test-and lowest-parsed-flag (term$state-flag ,*term-body)))
481		(defmacro term-test-lowest-parsed-flag (*term)
482		`(test-and lowest-parsed-flag (term-state-flag ,*term)))
483		(defmacro term-is-lowest-parsed? (_term) ; synonym
484		`(term-test-lowest-parsed-flag ,_term))
485
486		;;; on demand flag
487
488		(defmacro term$test-on-demand-flag (*term-body)
489		`(test-and on-demand-flag (term$state-flag ,*term-body)))
490		(defmacro term-test-on-demand-flag (*term)
491		`(test-and on-demand-flag (term-state-flag ,*term)))
492		(defmacro term-is-on-demand? (_term) ; synonym
493		`(term-test-on-demand-flag ,_term))
494
495		;;; STATE SETTERS
496
497		;;; reduced flag :
498		(defmacro term$set-reduced-flag (*term-body)
499		(once-only (*term-body)
500		`(setf (term$state-flag ,*term-body)
501		(make-or reduced-flag (term$state-flag ,*term-body)))))
502		(defmacro term-set-reduced-flag (*term)
503		(once-only (*term)
504		`(setf (term-state-flag ,*term)
505		(make-or reduced-flag (term-state-flag ,*term)))))
506		(defmacro mark-term-as-reduced (_term) ; synonym
507		`(term-set-reduced-flag ,_term))
508
509		(defconstant .not-reduced-bit. (logand #xffff (lognot reduced-flag)))
510
511		(defmacro term$unset-reduced-flag (*term-body)
512		(once-only (*term-body)
513		`(setf (term$state-flag ,*term-body)
514		(make-and .not-reduced-bit. (term$state-flag ,*term-body)))))
515
516		(defmacro term-unset-reduced-flag (*term)
517		(once-only (*term)
518		`(setf (term-state-flag ,*term)
519		(make-and .not-reduced-bit. (term-state-flag ,*term)))))
520		(defmacro mark-term-as-not-reduced (_term) ; synonym
521		`(term-unset-reduced-flag ,_term))
522
523
524		;;; red flag
525		(defmacro term$set-red-flag (*term-body)
526		(once-only (*term-body)
527		`(setf (term$state-flag ,*term-body)
528		(make-or red-flag (term$state-flag ,*term-body)))))
529
530		(defmacro term-set-red (*term)
531		(once-only (*term)
532		`(setf (term-state-flag ,*term)
533		(make-or red-flag (term-state-flag ,*term)))))
534
535		(defconstant .green-bit. (logand #xffff (lognot red-flag)))
536		(defmacro term$set-green (*term-body)
537		(once-only (*term-body)
538		`(setf (term$state-falag ,*term-body)
539		(make-and .green-bit. (term$state-flag ,*term-body)))))
540
541		(defmacro term-set-green (*term)
542		(once-only (*term)
543		`(setf (term-state-flag ,*term)
544		(make-and .green-bit. (term-state-flag ,*term)))))
545
546		;;; lowest parsed flag :
547
548		(defmacro term$set-lowest-parsed-flag (*term-body)
549		(once-only (*term-body)
550		`(setf (term$state-flag ,*term-body)
551		(make-or lowest-parsed-flag
552		(term$state-flag ,*term-body)))))
553
554		(defmacro term-set-lowest-parsed-flag (*term)
555		(once-only (*term)
556		`(setf (term-state-flag ,*term)
557		(make-or lowest-parsed-flag
558		(term-state-flag ,*term)))))
559
560		(defmacro mark-term-as-lowest-parsed (_term) ; synonym
561		`(term-set-lowest-parsed-flag ,_term))
562
563		(defconstant .not-lowest-parsed-bit. (logand #xffff (lognot lowest-parsed-flag)))
564
565		(defmacro term$unset-lowest-parsed-flag (*term-body)
566		(once-only (*term-body)
567		`(setf (term$state-flag ,*term-body)
568		(make-and .not-lowest-parsed-bit.
569		(term$state-flag ,*term-body)))))
570
571		(defmacro term-unset-lowest-parsed-flag (*term)
572		(once-only (*term)
573		`(setf (term-state-flag ,*term)
574		(make-and .not-lowest-parsed-bit.
575		(term-state-flag ,*term)))))
576
577		(defmacro mark-term-as-not-lowest-parsed (_term) ; synonym
578		`(term-unset-lowest-parsed-flag ,_term))
579
580		;;; on demand flag :
581
582		(defmacro term$set-on-demand-flag (*term-body)
583		(once-only (*term-body)
584		`(setf (term$state-flag ,*term-body)
585		(make-or on-demand-flag
586		(term$state-flag ,*term-body)))))
587
588		(defmacro term-set-on-demand-flag (*term)
589		(once-only (*term)
590		`(setf (term-state-flag ,*term)
591		(make-or on-demand-flag
592		(term-state-flag ,*term)))))
593
594		(defmacro mark-term-as-on-demand (_term) ; synonym
595		`(term-set-on-demand-flag ,_term))
596
597		(defconstant .not-on-demand-bit. (logand #xffff (lognot on-demand-flag)))
598
599		(defmacro term$unset-on-demand-flag (*term-body)
600		(once-only (*term-body)
601		`(setf (term$state-flag ,*term-body)
602		(make-and .not-on-demand-bit.
603		(term$state-flag ,*term-body)))))
604
605		(defmacro term-unset-on-demand-flag (*term)
606		(once-only (*term)
607		`(setf (term-state-flag ,*term)
608		(make-and .not-on-demand-bit.
609		(term-state-flag ,*term)))))
610
611		(defmacro mark-term-as-not-on-demand (_term) ; synonym
612		`(term-unset-on-demand-flag ,_term))
613
614		;;;*****************************************************************************
615		;;; TERM CONSTUCTORS
616		;;;*****************************************************************************
617
618		;;; constructors for pre-encoded version precedes `@'.
619
620		;;; ********
621		;;; VARIABLE ___________________________________________________________________
622		;;; ********
623
624		;;; NOTE variables are always considered as reduced.
625		;;; lowest parsed flag is also set to on.
626
627		(defconstant var-const-code
628		(logior variable-type reduced-flag lowest-parsed-flag))
629		(defconstant pre-var-const-code
630		(logior var-const-code pre-encode-bit))
631
632		;;; (defmacro make-variable-term (__sort __variable-name) ; synonym
633		;;; `(create-term (vector pre-var-const-code ,__variable-name ,__sort nil)))
634
635		(defmacro @create-variable-term (__variable-name __sort
636		&optional (p_name __variable-name))
637		` (create-term (list pre-var-const-code ,__variable-name ,__sort
638		,p_name)))
639
640		(defmacro make-variable-term (__sort __variable-name
641		&optional (_print_name __variable-name))
642		`(create-term (list pre-var-const-code
643		,__variable-name
644		,__sort
645		,_print_name)))
646
647
648		(defmacro variable-copy (var)
649		(once-only (var)
650		`(make-variable-term (variable-sort ,var)
651		(variable-name ,var)
652		(variable-print-name ,var))))
653
654		(defmacro variable-copy-x (var)
655		(once-only (var)
656		`(make-variable-term (variable-sort ,var)
657		(intern (concatenate 'string (string (variable-name ,var)) "'"))
658		(variable-print-name ,var))))
659
660		;;; ****************
661		;;; APPLICATION-FORM ___________________________________________________________
662		;;; ****************
663
664		#\|\|
665		(defmacro create-application-form-term (_operator-code _sort-id-code _subterms)
666		` (create-term (vector applicatin-form-type
667		,_operator-code
668		,_sort-id-code
669		,_subterms)))
670
671		(defmacro @create-application-form-term (_method _sort _subterms)
672		` (create-term (vector pre-application-form-type
673		,_method
674		,_sort
675		,_subterms)))
676
677		\|\|#
678
679		(defmacro create-application-form-term (_operator-code _sort-id-code _subterms)
680		` (create-term (list applicatin-form-type
681		,_operator-code
682		,_sort-id-code
683		,_subterms)))
684
685		(defmacro @create-application-form-term (_method _sort _subterms)
686		` (create-term (list pre-application-form-type
687		,_method
688		,_sort
689		,_subterms)))
690
691		;;; ****************
692		;;; SIMPLE-LISP-CODE ___________________________________________________________
693		;;; ****************
694
695		;;; NOTE simple-lisp-code is always treated as reduced and lowest parsed.
696		;;;
697		(defconstant simple-lisp-const-code
698		(logior reduced-flag lowest-parsed-flag simple-lisp-code-type))
699		(defconstant pre-simple-lisp-const-code
700		(logior pre-encode-bit simple-lisp-const-code))
701
702		#\|\|
703		(defmacro create-simple-lisp-code-term (_function &optional _sort-id-code)
704		` (create-term (vector simple-lisp-const-code
705		,_function
706		,_sort-id-code
707		nil)))
708
709		(defmacro make-simple-lisp-form-term (__original-form)
710		` (create-term (vector pre-simple-lisp-const-code
711		nil
712		cosmos
713		,__original-form)))
714
715		\|\|#
716
717		(defmacro create-simple-lisp-code-term (_function &optional _sort-id-code)
718		` (create-term (list simple-lisp-const-code
719		,_function
720		,_sort-id-code
721		nil)))
722
723		(defmacro make-simple-lisp-form-term (__original-form)
724		` (create-term (list pre-simple-lisp-const-code
725		nil
726		cosmos
727		,__original-form)))
728
729		;;; *****************
730		;;; GENERAL-LISP-CODE __________________________________________________________
731		;;; *****************
732
733		;;; NOTE general-lisp-code is always treated as reduced and lowest parsed.
734		;;;
735		(defconstant general-lisp-const-code
736		(logior reduced-flag lowest-parsed-flag general-lisp-code-type))
737		(defconstant pre-general-lisp-const-code
738		(logior pre-encode-bit general-lisp-const-code))
739
740		#\|\|
741		(defmacro create-general-lisp-code-term (_function _sort-id-code)
742		` (create-term (vector general-lisp-const-code
743		,_function
744		,_sort-id-code
745		nil)))
746
747		(defmacro @create-general-lisp-code-term (_function _original-form _sort)
748		` (create-term (vector pre-general-lisp-const-code
749		,_function
750		,_sort
751		,_original-form)))
752
753		(defmacro make-general-lisp-form-term (_original-form)
754		` (create-term (vector pre-general-lisp-const-code
755		nil
756		cosmos
757		,_original-form)))
758
759		\|\|#
760
761		(defmacro create-general-lisp-code-term (_function _sort-id-code)
762		` (create-term (list general-lisp-const-code
763		,_function
764		,_sort-id-code
765		nil)))
766
767		(defmacro @create-general-lisp-code-term (_function _original-form _sort)
768		` (create-term (list pre-general-lisp-const-code
769		,_function
770		,_sort
771		,_original-form)))
772
773		(defmacro make-general-lisp-form-term (_original-form)
774		` (create-term (list pre-general-lisp-const-code
775		nil
776		cosmos
777		,_original-form)))
778
779		;;; ****************
780		;;; BUILTIN CONSTANT ___________________________________________________________
781		;;; ****************
782
783		;;; For a while, builtin constant terms cannot be rewritten,i.e.,
784		;;; they are treated as irreducible. so we set flag reduced, always.
785		(defconstant builtin-constr-code
786		(logior pure-builtin-constant-type reduced-flag))
787		(defconstant pre-builtin-constr-code
788		(logior pre-encode-bit builtin-constr-code))
789
790		;;; downward compatibility
791		#\|\|
792		(defmacro make-bconst-term (_sort_ _value_)
793		` (create-term (vector pre-builtin-constr-code
794		,_value_
795		,_sort_
796		nil)))
797		\|\|#
798
799		(defmacro make-bconst-term (_sort_ _value_)
800		` (create-term (list pre-builtin-constr-code
801		,_value_
802		,_sort_
803		nil)))
804
805		;;; ***************
806		;;; PSUEDO CONSTANT____________________________________________________________
807		;;; ***************
808
809		;;; NOTE psuedo constant is treated as reduced and lowest parsed.
810		(defconstant psuedo-constant-const-code
811		(logior reduced-flag lowest-parsed-flag psuedo-constant-type))
812		(defconstant pre-psuedo-constant-const-code
813		(logior pre-encode-bit psuedo-constant-const-code))
814
815		;;; downward compat.
816
817		(defmacro make-psuedo-constant-term (_sort _name)
818		` (create-term (list pre-psuedo-constant-const-code
819		,_name
820		,_sort
821		nil)))
822
823		(defmacro make-pvariable-term (_sort _name &optional (_p-name _name))
824		` (create-term (list pre-psuedo-constant-const-code
825		,_name
826		,_sort
827		,_p-name)))
828
829		(defmacro pvariable-copy (var)
830		(once-only (var)
831		`(make-pvariable-term (variable-sort ,var) (variable-name ,var)
832		(variable-print-name ,var))))
833
834
835		;;; *************
836		;;; SYSTEM OBJECT ____________________________________________________________
837		;;; *************
838
839		;;; NOTE system object is treated as reduced and lowest parsed.
840		(defconstant system-object-const-code
841		(logior reduced-flag lowest-parsed-flag system-object-type))
842		(defconstant pre-system-object-const-code
843		(logior pre-encode-bit system-object-const-code))
844
845		#\|\|
846		(defmacro make-system-object-term (__value __sort)
847		` (create-term (vector pre-system-object-const-code
848		,__value
849		,__sort
850		nil)))
851
852		\|\|#
853
854		(defmacro make-system-object-term (__value __sort)
855		` (create-term (list pre-system-object-const-code
856		,__value
857		,__sort
858		nil)))
859
860		;;;*****************************************************************************
861		;;; BASIC UTILITIES
862		;;;*****************************************************************************
863
864		(defconstant all-term-code
865		(logior variable-type application-form-type lisp-code-type
866		builtin-constant-type psuedo-constant-type system-object-type))
867
868		;;; TERM? : object -> bool
869		;;; we don't need fast predicate, this is not used as rewriting nor parsing.
870		;;;
871		#\|\|
872		(defmacro term? (!object)
873		(once-only (!object)
874		` (and (consp ,!object)
875		(simple-vector-p (car ,!object))
876		(= 4 (the fixnum (length (car ,!object)))))))
877		\|\|#
878
879		(defmacro term? (!object)
880		(once-only (!object)
881		` (and (consp ,!object)
882		(consp (car ,!object))
883		(typep (caar ,!object) 'fixnum))))
884
885		;;; TERM-BUILTIN-EQUAL : term1 term2 -> bool
886		;;; assume term1 is builtin constant term
887		;;;
888		(defmacro term$builtin-equal (_builtin-body _term-body)
889		(once-only (*_term-body)
890		` (and (term$is-builtin-constant? ,*_term-body)
891		(equal (term$builtin-value ,*_builtin-body)
892		(term$builtin-value ,*_term-body)))))
893
894		(defmacro term-builtin-equal (_bi-term _term)
895		`(term$builtin-equal (term-body ,_bi-term) (term-body ,_term)))
896
897		;;; TERM-IS-CONSTANT? : term -> bool
898		;;; note we include variable-type and psuedo-constant-type for safety.
899		;;;
900		(defconstant priori-constant-type
901		(logior variable-type lisp-code-type builtin-constant-type
902		psuedo-constant-type
903		system-object-type))
904
905		(defmacro term$is-constant? (*_body)
906		(once-only (*_body)
907		`(or (test-and priori-constant-type (term$code ,*_body))
908		(null (term$subterms ,*_body)))))
909
910		(defmacro term-is-constant? (*_term)
911		`(term$is-constant? (term-body ,*_term)))
912
913		;;; TERM-VARIABLES : term -> LIST[variable]
914		;;;
915		(defun term-variables (term)
916		(let ((body (term-body term)))
917		(cond ((term$is-variable? body) (list term))
918		((term$is-constant? body) nil)
919		(t (let ((res nil))
920		(declare (list res))
921		(dolist (st (term$subterms body) res)
922		(setq res (delete-duplicates (append res (term-variables st))
923		:test #'!term-eq))))))))
924
925		(defun term-pvariables (term)
926		(let ((body (term-body term)))
927		(cond ((term$is-psuedo-constant? body) (list term))
928		((or (term$is-constant? body) (term$is-variable? 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-pvariables st))
933		:test #'(lambda (x y)
934		(eq (variable-name x)
935		(variable-name y)))))))))))
936
937		(declaim (inline variables-occur-at-top?))
938
939		#+GCL
940		(si:define-inline-function variables-occur-at-top? (term)
941		(block variables-occur-at-top-exit
942		(dolist (st (term-subterms term))
943		(when (term-is-variable? st)
944		(return-from variables-occur-at-top-exit t)))))
945
946		#-GCL
947		(defun variables-occur-at-top? (term)
948		(block variables-occur-at-top-exit
949		(dolist (st (term-subterms term))
950		(when (term-is-variable? st)
951		(return-from variables-occur-at-top-exit t)))))
952
953		;;; TERM-IS-GROUND? : term -> bool
954		;;;
955		(defconstant apriori-ground-type ; not used now.
956		(logior lisp-code-type builtin-constant-type system-object-type))
957
958		(defmacro term$is-ground? (*_body)
959		(once-only (*_body)
960		` (block success
961		(cond ((term$is-variable? ,*_body) (return-from success nil))
962		((term$is-application-form? ,*_body)
963		(dolist (st (term$subterms ,*_body) t)
964		(unless (term-is-ground? st)
965		(return-from success nil))))
966		(t t)))))
967
968		(defun term-is-ground? (xx_term)
969		(term$is-ground? (term-body xx_term)))
970
971		;;; *** ---
972		;;; SIMPLE-COPY-TERM : term -> new-term
973		;;; copies term.
974		;;;
975		#\|\|
976		(defun simple-copy-term (term)
977		(create-term (let ((x (make-array 4))
978		(body (term-body term)))
979		(declare (type simple-vector x))
980		(dotimes (i 4)
981		(declare (type fixnum i))
982		(setf (%svref x i) (%svref body i)))
983		x)))
984		\|\|#
985
986		(declaim (inline simple-copy-term))
987		(defun simple-copy-term (term)
988		(copy-tree (the list term)))
989
990		;;; The followings are only meaningful for encoded terms ***********************
991		;;;*****************************************************************************
992
993		;;; TERM-VARIABLE-MATCH : variable-body term-body -> bool
994		;;; true iff term-body matches varible-body
995		;;;
996		(defmacro !term-variable-match (_variable-body _term-body)
997		(once-only (_variable-body _term-body)
998		` (test-and (term$sort-code ,*_variable-body)
999		(term$sort-code ,*_term-body))))
1000
1001		(defmacro term-variable-match (_variable_ _term_)
1002		` (!term-variable-match (term-body ,*_variable_)
1003		(term-body ,*_term_)))
1004
1005		;;; TERM-OPERATOR-EQ : term -> bool
1006		;;;
1007		(defmacro !term-operator-eq (_term-body1 _term-body2)
1008		`(= (term$op-code ,_term-body1) (term$op-code ,_term-body2)))
1009
1010		(defmacro term-operator-eq (_term1 _term2)
1011		`(!term-operator-eq (term-body ,_term1) (term-body ,_term2)))
1012
1013		;;; TERM-OPERATOR-EQUAL : term -> bool
1014		;;;
1015		(defmacro !term-operator-equal (__term-body1 __term-body2)
1016		(once-only (__term-body1 __term-body2)
1017		` (and (term$operator-eq ,__term-body1 ,__term-body2)
1018		(= (term$sort-code ,__term-body1) (term$sort-code ,__term-body2)))))
1019
1020		(defmacro term-operator-equal (__term1_ __term2_)
1021		`(!term-operator-equal (term-body ,__term1_) (term-body ,__term2_)))
1022
1023		;;; EOF