mirror of
https://git.code.sf.net/p/newrpl/sources
synced 2024-11-16 19:51:25 +01:00
1439 lines
42 KiB
C
1439 lines
42 KiB
C
#include "newrpl.h"
|
|
#include "libraries.h"
|
|
|
|
// GLOBAL SUPPORT FUNCTIONS FOR SYMBOLICS
|
|
|
|
|
|
/*
|
|
* Copyright (c) 2014, Claudio Lapilli and the newRPL Team
|
|
* All rights reserved.
|
|
* This file is released under the 3-clause BSD license.
|
|
* See the file LICENSE.txt that shipped with this distribution.
|
|
*/
|
|
|
|
|
|
|
|
/* COMPILING A SYMBOLIC:
|
|
*
|
|
* Compiler will switch to infix mode with the return value: OK_STARTCONSTRUCT_INFIX
|
|
* And will return to RPN on ENDCONSTRUCT.
|
|
*
|
|
* In infix mode, the compiler sends OPCODE_MAXTOKEN to all libraries.
|
|
* Libraries must determine if the token string starts with a token provided by the library.
|
|
* Libraries reply with OK_TOKENINFO + MKTOKENINFO(precedence,nargs,length), with length=maximum
|
|
* number of characters that the compiled token will absorb (length<=TokenLen)
|
|
* At the same time, libraries must return the precedence of the compiled token they detected and
|
|
* the number of arguments that this operator/function needs from the stack, and whether it is left
|
|
* or right associative.
|
|
* The compiler will choose the library that absorbs the most characters, will split the token
|
|
* and pass the new token to the library to compile using OPCODE_COMPILE.
|
|
*
|
|
*
|
|
*/
|
|
|
|
/* Operators precedence should be:
|
|
|
|
|
|
31= BRACKETS/PARENTHESIS/COMMA
|
|
|
|
16 = OVR_EVAL, OVR_XEQ
|
|
14 = RULESEPARATOR, EQUATIONEQUAL
|
|
13= OVR_OR
|
|
12= OVR_XOR
|
|
11= OVR_AND
|
|
10= OVR_EQ, OVR_NOTEQ
|
|
9= OVR_LT OVR_GT OVR_LTE OVR_GTE
|
|
|
|
8= OVR_ADD
|
|
7= OVR_SUB
|
|
|
|
6= OVR_MUL
|
|
5= OVR_DIV,OVR_INV
|
|
|
|
4= OVR_NEG, OVR_UMINUS, OVR_UPLUS
|
|
|
|
3= OVR_POW
|
|
|
|
|
|
2 = ALL OTHER FUNCTIONS AND COMMANDS
|
|
|
|
|
|
1 = COMPLEX IDENT
|
|
1 = REAL IDENTS
|
|
1 = CONSTANT IDENT
|
|
1 = COMPOSITE OBJECT
|
|
1 = NUMERIC TYPES
|
|
|
|
*/
|
|
|
|
// RETURN THE OPCODE OF THE MAIN OPERATOR OF THE SYMBOLIC,
|
|
// OR ZERO IF AN ATOMIC OBJECT
|
|
// ABLE TO DIG THROUGH MULTIPLE LAYERS OF DOSYMB WRAPPING
|
|
|
|
WORD rplSymbMainOperator(WORDPTR symbolic)
|
|
{
|
|
WORDPTR endptr=rplSkipOb(symbolic);
|
|
while( (ISSYMBOLIC(*(symbolic+1))) && ((symbolic+1)<endptr)) ++symbolic;
|
|
if(symbolic+1>=endptr) return 0;
|
|
if(!ISPROLOG(*(symbolic+1))) return *(symbolic+1);
|
|
return 0;
|
|
}
|
|
|
|
// PEEL OFF USELESS LAYERS OF DOSYMB WRAPPING
|
|
// DO NOT CALL FOR ANY OBJECTS OTHER THAN A SYMBOLIC
|
|
// NO ARGUMENT CHECKS
|
|
WORDPTR rplSymbUnwrap(WORDPTR symbolic)
|
|
{
|
|
WORDPTR endptr=rplSkipOb(symbolic);
|
|
while( (ISSYMBOLIC(*(symbolic+1))) && ((symbolic+1)<endptr)) ++symbolic;
|
|
if(symbolic+1>=endptr) return 0;
|
|
return symbolic;
|
|
}
|
|
|
|
|
|
// RETURN 1 IF THE OBJECT IS ALLOWED WITHIN A SYMBOLIC, OTHERWISE 0
|
|
|
|
BINT rplIsAllowedInSymb(WORDPTR object)
|
|
{
|
|
// CALL THE GETINFO OPCODE TO SEE IF IT'S ALLOWED
|
|
LIBHANDLER handler=rplGetLibHandler(LIBNUM(*object));
|
|
WORD savedopcode=CurOpcode;
|
|
// ARGUMENTS TO PASS TO THE HANDLER
|
|
DecompileObject=object;
|
|
RetNum=-1;
|
|
CurOpcode=MKOPCODE(LIBNUM(*object),OPCODE_GETINFO);
|
|
if(handler) (*handler)();
|
|
|
|
// RESTORE ORIGINAL OPCODE
|
|
CurOpcode=savedopcode;
|
|
|
|
if(RetNum>OK_TOKENINFO) {
|
|
if(TI_TYPE(RetNum)==TITYPE_NOTALLOWED) return 0;
|
|
return 1;
|
|
}
|
|
return 0;
|
|
}
|
|
|
|
|
|
// TAKE 'nargs' ITEMS FROM THE STACK AND APPLY THE OPERATOR OPCODE
|
|
// LEAVE THE NEW SYMBOLIC OBJECT IN THE STACK
|
|
// NO ARGUMENT CHECKS!
|
|
void rplSymbApplyOperator(WORD Opcode,BINT nargs)
|
|
{
|
|
BINT f;
|
|
WORDPTR obj,ptr;
|
|
BINT size=0;
|
|
for(f=1;f<=nargs;++f) {
|
|
obj=rplPeekData(f);
|
|
if(ISSYMBOLIC(*obj)) obj=rplSymbUnwrap(obj);
|
|
size+=rplObjSize(obj);
|
|
}
|
|
size+=1;
|
|
|
|
WORDPTR newobject=rplAllocTempOb(size);
|
|
if(!newobject) return;
|
|
|
|
newobject[0]=MKPROLOG(DOSYMB,size);
|
|
newobject[1]=Opcode;
|
|
ptr=newobject+2;
|
|
for(f=nargs;f>0;--f) {
|
|
obj=rplPeekData(f);
|
|
if(ISSYMBOLIC(*obj)) obj=rplSymbUnwrap(obj);
|
|
else {
|
|
// CHECK IF IT'S ALLOWED IN SYMBOLICS
|
|
LIBHANDLER han=rplGetLibHandler(LIBNUM(*obj));
|
|
WORD savedopc=CurOpcode;
|
|
CurOpcode=MKOPCODE(LIBNUM(*obj),OPCODE_GETINFO);
|
|
RetNum=-1;
|
|
if(han) (*han)();
|
|
CurOpcode=savedopc;
|
|
if(RetNum>OK_TOKENINFO) {
|
|
if(TI_TYPE(RetNum)==TITYPE_NOTALLOWED) {
|
|
Exceptions|=EX_BADARGTYPE;
|
|
ExceptionPointer=IPtr;
|
|
return;
|
|
}
|
|
}
|
|
else {
|
|
Exceptions|=EX_BADARGTYPE;
|
|
ExceptionPointer=IPtr;
|
|
return;
|
|
}
|
|
|
|
}
|
|
rplCopyObject(ptr,obj);
|
|
// REPLACE QUOTED IDENT WITH UNQUOTED ONES FOR SYMBOLIC OBJECTS
|
|
if(LIBNUM(*ptr)==DOIDENT) *ptr=MKPROLOG(DOIDENTEVAL,OBJSIZE(*ptr));
|
|
|
|
ptr=rplSkipOb(ptr);
|
|
}
|
|
rplDropData(nargs-1);
|
|
rplOverwriteData(1,newobject);
|
|
}
|
|
|
|
|
|
// CHANGE THE SYMBOLIC TO CANONICAL FORM.
|
|
// CANONICAL FORM APPLIES THE FOLLOWING RULES:
|
|
// SUBTRACTION AND DIVISION ARE FOLDED INTO ADDITION AND MULTIPLICATION WITH NEG() AND INV()
|
|
// SUCCESSIVE ADDITION AND MULTIPLICATION LISTS ARE FLATTENED
|
|
// NEGATIVE NUMBERS ARE REPLACED WITH UNARY MINUS AND POSITIVE ONES.
|
|
// NEG() OPERATOR IS REPLACED WITH UMINUS
|
|
// ALL NUMERICAL TERMS ARE ADDED TOGETHER
|
|
// ALL NUMERICAL FACTORS IN THE NUMERATOR ARE MULTIPLIED TOGETHER
|
|
// ALL NUMERICAL FACTORS IN THE DENOMINATOR ARE MULTIPLIED TOGETHER
|
|
// SYMBOLIC FRACTIONS ARE REDUCED
|
|
|
|
// APPLY AN OPERATOR WITH ARGUMENTS RECENTLY EVAL'ED, AND EVAL THE RESULT AS WELL
|
|
// SIMILAR TO APPLYING THE OPERATOR BUT IT ALSO DOES MINOR SIMPLIFICATION
|
|
|
|
#define SYMBITEMCOMPARE(item1,item2) ((BINT)LIBNUM(*(item2))-(BINT)LIBNUM(*(item1)))
|
|
|
|
|
|
|
|
// CHANGE THE SYMBOLIC TO CANONICAL FORM.
|
|
// CANONICAL FORM APPLIES THE FOLLOWING RULES:
|
|
// SUBTRACTION AND DIVISION ARE FOLDED INTO ADDITION AND MULTIPLICATION WITH NEG() AND INV()
|
|
// SUCCESSIVE ADDITION AND MULTIPLICATION LISTS ARE FLATTENED
|
|
// NEGATIVE NUMBERS ARE REPLACED WITH UNARY MINUS AND POSITIVE ONES.
|
|
// NEG() OPERATOR IS REPLACED WITH UMINUS
|
|
// ALL NUMERICAL TERMS ARE ADDED TOGETHER
|
|
// ALL NUMERICAL FACTORS IN THE NUMERATOR ARE MULTIPLIED TOGETHER
|
|
// ALL NUMERICAL FACTORS IN THE DENOMINATOR ARE MULTIPLIED TOGETHER
|
|
// SYMBOLIC FRACTIONS ARE REDUCED
|
|
|
|
|
|
void rplSymbAutoSimplify()
|
|
{
|
|
|
|
|
|
|
|
}
|
|
|
|
void rplSymbEVALApplyOperator(WORD Opcode,BINT nargs)
|
|
{
|
|
if(LIBNUM(Opcode)==LIB_OVERLOADABLE) {
|
|
// TREAT SOME OPERATORS IN A SPECIAL WAY
|
|
// TO APPLY SIMPLIFICATIONS
|
|
|
|
switch(OPCODE(Opcode))
|
|
{
|
|
case OVR_ADD:
|
|
{
|
|
// SORT ARGUMENTS BY LIBRARY NUMBER
|
|
WORDPTR *ptr,*ptr2,*endlimit,*startlimit,save;
|
|
WORDPTR *left,*right;
|
|
|
|
startlimit=DSTop-nargs+1; // POINT TO SECOND ELEMENT IN THE LIST
|
|
endlimit=DSTop; // POINT AFTER THE LAST ELEMENT
|
|
|
|
for(ptr=startlimit;ptr<endlimit;++ptr)
|
|
{
|
|
save=*ptr;
|
|
|
|
left=startlimit-1;
|
|
right=ptr-1;
|
|
if(SYMBITEMCOMPARE(*right,save)>0) {
|
|
if(SYMBITEMCOMPARE(save,*left)>0) {
|
|
while(right-left>1) {
|
|
if(SYMBITEMCOMPARE(*(left+(right-left)/2),save)>0) {
|
|
right=left+(right-left)/2;
|
|
}
|
|
else {
|
|
left=left+(right-left)/2;
|
|
}
|
|
}
|
|
} else right=left;
|
|
// INSERT THE POINTER RIGHT BEFORE right
|
|
for(ptr2=ptr;ptr2>right; ptr2-=1 ) *ptr2=*(ptr2-1);
|
|
//memmove(right+1,right,(ptr-right)*sizeof(WORDPTR));
|
|
*right=save;
|
|
}
|
|
}
|
|
|
|
// TODO: PREPROCESS EACH ARGUMENT
|
|
// NEGATIVE NUMBERS BECOME (UMINUS POSITIVE NUMBER)
|
|
|
|
|
|
// APPLY
|
|
BINT k;
|
|
for(k=1;k<nargs;++k) {
|
|
rplCallOvrOperator(Opcode);
|
|
}
|
|
|
|
}
|
|
return;
|
|
}
|
|
}
|
|
else rplSymbApplyOperator(Opcode,nargs);
|
|
}
|
|
|
|
|
|
|
|
|
|
// DETERMINES WHETHER TWO SYMBOLIC OBJECTS ARE IDENTICAL OR NOT
|
|
// NO ARGUMENT CHECKS, NEVER THROWS EXCEPTIONS, DOES NOT ALTER THE STACK, DOES NOT ALLOCATE MEMORY
|
|
|
|
BINT rplSymbObjectMatch(WORDPTR baseobject,WORDPTR objptr)
|
|
{
|
|
|
|
// START THE MATCHING PROCESS
|
|
|
|
|
|
WORDPTR endofbase=rplSkipOb(baseobject);
|
|
WORDPTR endofobj=rplSkipOb(objptr);
|
|
|
|
while( (baseobject<endofbase) && (objptr<endofobj)) {
|
|
|
|
if(ISSYMBOLIC(*baseobject)) baseobject=rplSymbUnwrap(baseobject);
|
|
if(ISSYMBOLIC(*objptr)) objptr=rplSymbUnwrap(objptr);
|
|
|
|
if(ISNUMBER(*baseobject)) {
|
|
if(!ISNUMBER(*objptr)) return 0; // MATCH FAILED
|
|
|
|
mpd_t num1,num2;
|
|
|
|
rplReadNumberAsReal(baseobject,&num1);
|
|
rplReadNumberAsReal(objptr,&num2);
|
|
|
|
if(mpd_cmp(&num1,&num2,&Context)) return 0; // MATCH FAILED
|
|
}
|
|
else
|
|
if(!ISPROLOG(*baseobject)) {
|
|
// IT'S AN OPCODE OF AN OPERATOR, OR AN INTEGER NUMBER. MUST MATCH EXACTLY
|
|
if(*baseobject!=*objptr) return 0; // MATCH FAILED
|
|
++baseobject;
|
|
++objptr;
|
|
continue;
|
|
}
|
|
|
|
else
|
|
if(ISSYMBOLIC(*baseobject)) {
|
|
if(!ISSYMBOLIC(*objptr)) return 0; // MATCH FAILED
|
|
// INCREASE THE POINTERS TO SCAN INSIDE THE SYMBOLIC
|
|
++baseobject;
|
|
++objptr;
|
|
continue;
|
|
}
|
|
|
|
// ADD MORE SPECIAL CASES HERE
|
|
|
|
// ALL OTHER OBJECTS **MUST** BE IDENTICAL, REGARDLESS OF TYPE
|
|
else
|
|
if(!rplCompareObjects(baseobject,objptr)) return 0; // MATCH FAILED
|
|
|
|
|
|
// AFTER A MATCH, PROCESS THE NEXT OBJECT
|
|
baseobject=rplSkipOb(baseobject);
|
|
objptr=rplSkipOb(objptr);
|
|
|
|
}
|
|
|
|
if((baseobject!=endofbase)||(objptr!=endofobj)) return 0; // RETURN WITH "NO MATCH" RESULT
|
|
|
|
return 1;
|
|
}
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
// SYMBOLIC EXPRESSION IN LEVEL 2
|
|
// RULE IN LEVEL 1
|
|
// CREATES A NEW LOCAL ENVIRONMENT, WITH THE FOLLOWING VARIABLES:
|
|
// GETLAM1 IS AN UNNAMED VARIABLE THAT WILL CONTAIN 1 IF THERE WAS A MATCH, 0 OTHERWISE
|
|
// GETLAM2 IS UNNAMED, AND WILL CONTAIN A POINTER INSIDE THE ORIGINAL SYMBOLIC WHERE THE LAST MATCH WAS FOUND, TO BE USED BY MATCHNEXT
|
|
// * ANY IDENTS THAT DON'T START WITH A . ARE CREATED AND SET EQUAL TO THE RIGHT SIDE OF THE RULE OPERATOR
|
|
// * ANY IDENTS THAT START WITH A PERIOD MATCH ANY EXPRESSION AS FOLLOWS:
|
|
// .X MATCHES ANY EXPRESSION (LARGEST MATCH POSSIBLE) AND DEFINES .X = 'FOUND EXPRESSION'
|
|
// .X.s MATCHES ANY EXPRESSION (SMALLEST MATCH POSSIBLE)
|
|
// .X.S SAME AS DEFAULT (LARGEST MATCH) (AN ALIAS FOR CONSISTENCY)
|
|
// .X.n MATCHES ANY NUMERIC EXPRESSION (SMALLEST MATCH) AND DEFINES .X.n = 'FOUND EXPRESSION'
|
|
// .X.N MATCHES ANY NUMERIC EXPRESSION (LARGEST MATCH) AND DEFINES .X.N = 'FOUND EXPRESSION'
|
|
// .X.I MATCHES ANY INTEGER .X.I = NUMBER
|
|
// .X.R MATCHES ANY NUMBER (REAL OR INTEGER, BUT WON'T MATCH FRACTIONS) .X.R = NUMBER.
|
|
|
|
|
|
|
|
void rplSymbRuleMatch()
|
|
{
|
|
// MATCH A RULE IN THE CURRENT SYMBOLIC, DOES NOT MATCH RECURSIVELY INSIDE THE SYMBOLIC
|
|
|
|
WORDPTR ruleleft,ruleright,ruleptr,objptr;
|
|
|
|
ruleleft=rplSymbUnwrap(rplPeekData(1));
|
|
if(!ruleleft) {
|
|
Exceptions|=EX_BADARGTYPE;
|
|
ExceptionPointer=IPtr;
|
|
return;
|
|
}
|
|
if(!ISSYMBOLIC(*ruleleft)) {
|
|
Exceptions|=EX_BADARGTYPE;
|
|
ExceptionPointer=IPtr;
|
|
return;
|
|
}
|
|
++ruleleft;
|
|
if(*ruleleft!=CMD_RULESEPARATOR) {
|
|
Exceptions|=EX_BADARGTYPE;
|
|
ExceptionPointer=IPtr;
|
|
return;
|
|
}
|
|
++ruleleft;
|
|
ruleright=rplSkipOb(ruleleft);
|
|
|
|
objptr=rplSymbUnwrap(rplPeekData(2));
|
|
|
|
if(!objptr) {
|
|
Exceptions|=EX_BADARGTYPE;
|
|
ExceptionPointer=IPtr;
|
|
return;
|
|
}
|
|
|
|
|
|
// START THE MATCHING PROCESS
|
|
// CREATE A NEW ENVIRONMENT FOR LOCAL VARS
|
|
|
|
// CREATE A NEW LAM ENVIRONMENT FOR TEMPORARY STORAGE OF INDEX
|
|
rplCreateLAMEnvironment(IPtr);
|
|
|
|
rplCreateLAM(nulllam_ident,zero_bint); // GETLAM1 = MATCH OR NOT?
|
|
rplCreateLAM(nulllam_ident,zero_bint); // GETLAM2 = LAST OBJECT SCANNED
|
|
|
|
// ... FROM HERE ON, THERE ARE NAMED LAM'S WITH THE PATTERNS
|
|
|
|
if( (!ISSYMBOLIC(*objptr)) && (!ISIDENT(*objptr))) {
|
|
// NOT A SYMBOLIC OBJECT, NOTHING TO MATCH
|
|
// RETURN WITH A "DID NOT MATCH" IN GETLAM1
|
|
return;
|
|
}
|
|
|
|
WORDPTR endofrule=rplSkipOb(ruleleft);
|
|
WORDPTR endofobj=rplSkipOb(objptr);
|
|
|
|
while( (ruleleft<endofrule) && (objptr<endofobj)) {
|
|
|
|
if(ISSYMBOLIC(*ruleleft)) ruleleft=rplSymbUnwrap(ruleleft);
|
|
if(ISSYMBOLIC(*objptr)) objptr=rplSymbUnwrap(objptr);
|
|
|
|
if(ISSYMBOLIC(*ruleleft)) {
|
|
if(!ISSYMBOLIC(*objptr)) break; // MATCH FAILED
|
|
// INCREASE THE POINTERS TO SCAN INSIDE THE SYMBOLIC
|
|
++ruleleft;
|
|
++objptr;
|
|
if(*ruleleft==MKOPCODE(LIB_OVERLOADABLE,OVR_ADD)) {
|
|
// DO COMMUTATIVE/ASSOCIATIVE MATCHING
|
|
//if(!rplSymbAdditionMatch(ruleleft-1,objptr-1)) break;
|
|
|
|
|
|
}
|
|
|
|
continue;
|
|
}
|
|
else
|
|
if(ISIDENT(*ruleleft)) {
|
|
// CHECK IF IT'S A PLACEHOLDER
|
|
BINT len=OBJSIZE(*ruleleft)<<2;
|
|
BINT shortlen;
|
|
BYTE type=0;
|
|
BYTEPTR varname=(BYTEPTR)(ruleleft+1);
|
|
if(*((char *)varname)=='.') {
|
|
// THIS IS A SPECIAL PLACEHOLDER
|
|
BYTEPTR name2=varname+len-1;
|
|
while(*name2==0) --name2;
|
|
while(*name2!='.') --name2;
|
|
if(name2==varname) {
|
|
// THERE WAS NO SUFFIX
|
|
type=0;
|
|
} else {
|
|
if(name2+1<varname+len) type=*(name2+1);
|
|
else type=0;
|
|
}
|
|
|
|
// HERE WE HAVE: type HOLDS THE TYPE CHARACTER
|
|
|
|
// IF THIS NAME ALREADY EXISTS, WE NEED TO MATCH ITS CONTENTS
|
|
// IF IT DOESN'T, WE NEED TO FIND A PROPER MATCH
|
|
|
|
WORDPTR lamptr=rplFindLAM(ruleleft,0);
|
|
if(lamptr) {
|
|
// NAME ALREADY EXISTS, THE OBJECT MUST MATCH
|
|
|
|
if(!rplSymbObjectMatch(*(lamptr+1),objptr)) break; // MATCH FAILED
|
|
// MATCH SUCCEEDED!
|
|
|
|
} else {
|
|
ScratchPointer1=endofrule;
|
|
ScratchPointer2=endofobj;
|
|
ScratchPointer3=ruleleft;
|
|
ScratchPointer4=objptr;
|
|
BINT newlam=rplCreateLAM(ruleleft,zero_bint); // CREATE A PLACEHOLDER FOR THE LAM
|
|
endofrule=ScratchPointer1;
|
|
endofobj=ScratchPointer2;
|
|
ruleleft=ScratchPointer3;
|
|
objptr=ScratchPointer4;
|
|
if(Exceptions) {
|
|
rplCleanupLAMs(0);
|
|
return;
|
|
}
|
|
// TODO: DO THE MATCH AND ASSIGN IT!
|
|
BINT matchresult=0;
|
|
switch(type)
|
|
{
|
|
case 'N':
|
|
case 'n':
|
|
// ONLY MATCH A NUMERIC EXPRESSION
|
|
// AN EXPRESSION WHERE ALL ARGUMENTS ARE NOT IDENTS
|
|
// TODO:
|
|
// if(rplSymbIsNumeric(objptr)) matchresult=1;
|
|
break;
|
|
case 'I':
|
|
// ONLY MATCH AN INTEGER NUMBER
|
|
if(ISBINT(*objptr)) matchresult=1;
|
|
break;
|
|
case 'R':
|
|
if(ISNUMBER(*objptr)) matchresult=1;
|
|
break;
|
|
case 0:
|
|
default:
|
|
// MATCH ANY EXPRESSION
|
|
matchresult=1;
|
|
break;
|
|
}
|
|
|
|
if(matchresult) {
|
|
rplPutLAMn(newlam,objptr);
|
|
}
|
|
else break;
|
|
|
|
}
|
|
|
|
|
|
} // END OF SPECIAL IDENTS
|
|
else {
|
|
// NORMAL IDENTS
|
|
if(!rplCompareIDENT(ruleleft,objptr)) break; // MATCH FAILED
|
|
}
|
|
|
|
}
|
|
|
|
|
|
// ADD MORE SPECIAL CASES HERE
|
|
|
|
// ALL OTHER OBJECTS **MUST** BE IDENTICAL, REGARDLESS OF TYPE
|
|
else
|
|
if(!rplSymbObjectMatch(ruleleft,objptr)) break; // MATCH FAILED
|
|
|
|
|
|
// AFTER A MATCH, PROCESS THE NEXT OBJECT
|
|
ruleleft=rplSkipOb(ruleleft);
|
|
objptr=rplSkipOb(objptr);
|
|
|
|
|
|
}
|
|
|
|
if((ruleleft!=endofrule)||(objptr!=endofobj)) return; // RETURN WITH "NO MATCH" RESULT
|
|
|
|
rplPutLAMn(1,one_bint); // RETURN NULLLAM1 = 1
|
|
rplPutLAMn(2,endofobj); // NEXT OBJECT TO BE SCANNED
|
|
|
|
return;
|
|
}
|
|
|
|
// COUNT HOW MANY ARGUMENTS THERE ARE FOR THE MAIN SYMBOLIC OPERATOR
|
|
// RETURNS ZERO FOR ATOMIC OBJECTS, OR THE NUMBER OF ARGUMENTS FOR AN OPERATOR OR FUNCTION
|
|
// IT FLATTENS ADDITION AND MULTIPLICATION
|
|
|
|
BINT rplSymbCountArguments(WORDPTR object)
|
|
{
|
|
object=rplSymbUnwrap(object);
|
|
if(!object) return 0;
|
|
|
|
if(!ISSYMBOLIC(*object)) return 0;
|
|
|
|
WORDPTR endofobj=rplSkipOb(object);
|
|
WORD Opcode=*(object+1);
|
|
if(ISPROLOG(Opcode)) return 0;
|
|
if(ISBINT(Opcode)) return 0;
|
|
|
|
// HERE WE ARE SURE THAT OPCODE IS AN OPERATOR
|
|
object+=2;
|
|
BINT count=0;
|
|
|
|
while(object!=endofobj) {
|
|
if(ISSYMBOLIC(*object)) object=rplSymbUnwrap(object);
|
|
if(ISSYMBOLIC(*object)) {
|
|
if(*(object+1)==Opcode) {
|
|
// SAME OPERATION
|
|
if( (Opcode==MKOPCODE(LIB_OVERLOADABLE,OVR_ADD)) || (Opcode==MKOPCODE(LIB_OVERLOADABLE,OVR_MUL))) { object+=2; continue; }
|
|
}
|
|
|
|
}
|
|
++count;
|
|
object=rplSkipOb(object);
|
|
}
|
|
|
|
return count;
|
|
|
|
}
|
|
|
|
|
|
// SCAN AN OBJECT, RETURN 1 IF IT'S NUMERIC, 0 OTHERWISE
|
|
|
|
BINT rplSymbIsNumeric(WORDPTR object)
|
|
{
|
|
|
|
WORDPTR endofobj=rplSkipOb(object);
|
|
|
|
while(object!=endofobj) {
|
|
if(ISSYMBOLIC(*object)) object=rplSymbUnwrap(object);
|
|
if(ISSYMBOLIC(*object)) { ++object; continue; }
|
|
if(ISIDENT(*object)) return 0;
|
|
object=rplSkipOb(object);
|
|
}
|
|
|
|
return 1;
|
|
}
|
|
|
|
|
|
// SCAN AN OBJECT, RETURN 1 IF IT CONTAINS A SPECIAL RULE IDENT, 0 OTHERWISE
|
|
BINT rplSymbHasSpecialIdent(WORDPTR object)
|
|
{
|
|
WORDPTR endofobj=rplSkipOb(object);
|
|
|
|
while(object!=endofobj) {
|
|
if(ISSYMBOLIC(*object)) object=rplSymbUnwrap(object);
|
|
if(ISSYMBOLIC(*object)) { ++object; continue; }
|
|
if(ISIDENT(*object)) {
|
|
// CHECK IF IT'S A SPECIAL IDENT (ALL SPECIAL IDENTS BEGIN WITH A DOT)
|
|
if(*((char *)(object+1))=='.') return 1;
|
|
}
|
|
object=rplSkipOb(object);
|
|
}
|
|
|
|
return 0;
|
|
|
|
}
|
|
|
|
// REPLACE AN OBJECT WITHIN A SYMBOLIC
|
|
// IT CREATES A NEW OBJECT, SO IT MIGHT TRIGGER GC
|
|
// USES ScratchPointers 1 THRU 3 DURING GC
|
|
// RETURNS A POINTER TO THE NEW OBJECT
|
|
// LOW LEVEL FUNCTION - NO ARGUMENT CHECKS!!!
|
|
|
|
WORDPTR rplSymbReplace(WORDPTR mainobj,WORDPTR arg,WORDPTR newarg)
|
|
{
|
|
|
|
ScratchPointer1=mainobj;
|
|
ScratchPointer2=arg;
|
|
ScratchPointer3=newarg;
|
|
WORDPTR newobj=rplAllocTempOb(rplObjSize(mainobj)-rplObjSize(arg)+rplObjSize(newarg)-1),ptr,end;
|
|
if(Exceptions) return NULL;
|
|
ptr=newobj;
|
|
mainobj=ScratchPointer1;
|
|
arg=ScratchPointer2;
|
|
newarg=ScratchPointer3;
|
|
while(mainobj!=arg) *ptr++=*mainobj++;
|
|
end=rplSkipOb(newarg);
|
|
while(newarg!=end) *ptr++=*newarg++;
|
|
mainobj=rplSkipOb(arg);
|
|
end=rplSkipOb(ScratchPointer1);
|
|
while(mainobj!=end) *ptr++=*mainobj++;
|
|
return newobj;
|
|
}
|
|
|
|
|
|
// EXPLODE A SYMBOLIC IN THE STACK IN REVERSE (LEVEL 1 CONTAINS THE FIRST OBJECT, LEVEL 2 THE SECOND, ETC.)
|
|
// INCLUDING OPERATORS
|
|
// USES ScratchPointer1 FOR GC PROTECTION
|
|
// RETURN THE NUMBER OF OBJECTS THAT ARE ON THE STACK
|
|
|
|
BINT rplSymbExplode(WORDPTR object)
|
|
{
|
|
BINT count=0,countops=0,nargs;
|
|
|
|
WORDPTR ptr,end,localend,numbers;
|
|
|
|
ptr=object;
|
|
end=rplSkipOb(object);
|
|
|
|
while(ptr!=end) {
|
|
if(ISSYMBOLIC(*ptr)) { ++ptr; continue; }
|
|
if(! (ISPROLOG(*ptr) || ISBINT(*ptr))) ++countops;
|
|
++count;
|
|
ptr=rplSkipOb(ptr);
|
|
}
|
|
|
|
// HERE count+countops IS THE NUMBER OF POINTERS WE NEED TO PUSH ON THE STACK
|
|
ScratchPointer1=object;
|
|
rplExpandStack(count+countops); // EXPAND THE DATA STACK NOW, SO WE CAN MANUALLY PUSH IN BULK
|
|
if(Exceptions) return 0;
|
|
numbers=rplAllocTempOb(countops);
|
|
if(!numbers) return 0;
|
|
object=ScratchPointer1;
|
|
ptr=DSTop+count+countops-1;
|
|
end=rplSkipOb(object);
|
|
countops=0;
|
|
|
|
while(object!=end) {
|
|
if(ISSYMBOLIC(*object)) {
|
|
nargs=0;
|
|
WORDPTR tmp=object+1,tmpend=rplSkipOb(object);
|
|
while(tmp!=tmpend) {
|
|
++nargs;
|
|
tmp=rplSkipOb(tmp);
|
|
}
|
|
// HERE nargs HAS THE NUMBER OF ARGUMENTS + 1 FOR THE OPCODE
|
|
++object;
|
|
continue;
|
|
}
|
|
*ptr=object;
|
|
if(! (ISPROLOG(*object) || ISBINT(*object))) { numbers[countops]=MAKESINT(nargs); --ptr; *ptr=&numbers[countops]; ++countops; }
|
|
--ptr;
|
|
object=rplSkipOb(object);
|
|
}
|
|
|
|
DSTop+=count+countops;
|
|
|
|
return count+countops;
|
|
|
|
}
|
|
|
|
// REASSEMBLE A SYMBOLIC THAT WAS EXPLODED IN THE STACK
|
|
// DOES NOT CHECK FOR VALIDITY OF THE SYMBOLIC!
|
|
|
|
WORDPTR rplSymbImplode(BINT numobjects)
|
|
{
|
|
|
|
WORDPTR *stkptr=DSTop-1;
|
|
|
|
BINT size=0,narg;
|
|
|
|
BINT f;
|
|
|
|
for(f=0;f<numobjects;++f)
|
|
{
|
|
size+=rplObjSize(*stkptr);
|
|
--stkptr;
|
|
}
|
|
|
|
// HERE size HAS THE TOTAL SIZE WE NEED TO ALLOCATE
|
|
|
|
WORDPTR newobject=rplAllocTempOb(size),newptr,object;
|
|
|
|
if(!newobject) return NULL;
|
|
|
|
stkptr=DSTop-1;
|
|
newptr=newobject;
|
|
for(f=0;f<numobjects;++f)
|
|
{
|
|
object=*stkptr;
|
|
if(!(ISPROLOG(*object)||ISBINT(*object))) {
|
|
// WE HAVE AN OPCODE, START A SYMBOLIC RIGHT HERE
|
|
*newptr++=MKPROLOG(DOSYMB,0);
|
|
*newptr++=*object; // STORE THE OPCODE
|
|
--stkptr;
|
|
++f;
|
|
}
|
|
else {
|
|
// COPY THE OBJECT
|
|
WORDPTR endobj=rplSkipOb(object);
|
|
while(object!=endobj) *newptr++=*object++;
|
|
}
|
|
|
|
--stkptr;
|
|
|
|
}
|
|
|
|
// HERE WE HAVE THE NEW OBJECT, BUT ALL SYMBOLIC SIZES ARE SET TO ZERO
|
|
// NEED TO FIX THE SIZES ACCORDING TO THE NUMBER OF ARGUMENTS
|
|
// newptr IS POINTING AT THE END OF THE NEW OBJECT
|
|
|
|
for(;f>0;--f) {
|
|
++stkptr;
|
|
object=*stkptr;
|
|
if(!(ISPROLOG(*object)||ISBINT(*object))) {
|
|
// FOUND AN OPERATOR, GET THE NUMBER OF ITEMS
|
|
narg=OPCODE(**(stkptr-1));
|
|
|
|
// PATCH THE LAST SYMBOLIC WITH ZERO FOR SIZE IN THE OBJECT
|
|
WORDPTR scan=newobject,lastone=0;
|
|
while(scan<newptr) {
|
|
if(*scan==MKPROLOG(DOSYMB,0)) {
|
|
lastone=scan;
|
|
++scan;
|
|
continue;
|
|
}
|
|
scan=rplSkipOb(scan);
|
|
}
|
|
// HERE lastone HAS THE LAST SYMBOLIC FOUND
|
|
scan=lastone+1;
|
|
while(narg) { scan=rplSkipOb(scan); --narg; }
|
|
|
|
// AND PATCH THE SIZE
|
|
*lastone=MKPROLOG(DOSYMB,scan-lastone-1);
|
|
|
|
}
|
|
|
|
}
|
|
|
|
return newobject;
|
|
|
|
}
|
|
|
|
// SKIP ONE SYMBOLIC OBJECT IN ITS EXPLODED FORM IN THE STACK
|
|
// THE ARGUMENT IS A POINTER TO THE STACK, NOT THE OBJECT
|
|
// RETURS THE POINTER TO THE STACK ELEMENT THAT HAS THE NEXT OBEJCT
|
|
|
|
WORDPTR *rplSymbSkipInStack(WORDPTR *stkptr)
|
|
{
|
|
if(ISPROLOG(**stkptr)) return --stkptr;
|
|
if(ISBINT(**stkptr)) return --stkptr;
|
|
|
|
// IT'S AN OPERATOR
|
|
--stkptr;
|
|
|
|
BINT nargs=OPCODE(**stkptr)-1; // EXTRACT THE SINT
|
|
--stkptr;
|
|
while(nargs) {
|
|
if(ISPROLOG(**stkptr)) { --stkptr; --nargs; continue; }
|
|
if(ISBINT(**stkptr)) { --stkptr; --nargs; continue; }
|
|
--stkptr;
|
|
nargs+=OPCODE(**stkptr)-1;
|
|
--stkptr;
|
|
--nargs;
|
|
}
|
|
|
|
return stkptr;
|
|
}
|
|
|
|
|
|
|
|
|
|
// CONVERT A SYMBOLIC INTO CANONICAL FORM:
|
|
// A) NEGATIVE NUMBERS REPLACED WITH NEG(n)
|
|
// B) ALL SUBTRACTIONS REPLACED WITH ADDITION OF NEGATED ITEMS
|
|
// c) ALL NEG(A+B+...) = NEG(A)+NEG(B)+NEG(...)
|
|
// D) FLATTEN ALL ADDITION TREES
|
|
|
|
// E) ALL NEGATIVE POWERS REPLACED WITH a^-n = INV(a^n)
|
|
// F) ALL DIVISIONS REPLACED WITH MULTIPLICATION BY INV()
|
|
// G) ALL INV(A*B*...) = INV(A)*INV(B)*INV(...)
|
|
// H) FLATTEN ALL MULTIPLICATION TREES
|
|
|
|
const WORD const uminus_opcode[]={
|
|
MKOPCODE(LIB_OVERLOADABLE,OVR_UMINUS)
|
|
};
|
|
const WORD const add_opcode[]={
|
|
MKOPCODE(LIB_OVERLOADABLE,OVR_ADD)
|
|
};
|
|
const WORD const inverse_opcode[]={
|
|
MKOPCODE(LIB_OVERLOADABLE,OVR_INV)
|
|
};
|
|
const WORD const mul_opcode[]={
|
|
MKOPCODE(LIB_OVERLOADABLE,OVR_MUL)
|
|
};
|
|
|
|
|
|
WORDPTR rplSymbCanonicalForm(WORDPTR object)
|
|
{
|
|
BINT numitems=rplSymbExplode(object);
|
|
BINT f;
|
|
WORDPTR *stkptr,sobj,*endofstk;
|
|
|
|
stkptr=DSTop-1;
|
|
endofstk=stkptr-numitems;
|
|
|
|
//*******************************************
|
|
// SCAN THE SYMBOLIC FOR ITEM A)
|
|
// A) NEGATIVE NUMBERS REPLACED WITH NEG(n)
|
|
|
|
|
|
while(stkptr!=endofstk) {
|
|
sobj=*stkptr;
|
|
|
|
if(ISBINT(*sobj)) {
|
|
// THE OBJECT IS AN INTEGER NUMBER
|
|
BINT64 num=rplReadBINT(sobj);
|
|
if(num<0) {
|
|
num=-num;
|
|
rplNewBINTPush(num,DECBINT);
|
|
if(Exceptions) { DSTop=endofstk+1; return NULL; }
|
|
WORDPTR newobj=rplPeekData(1);
|
|
|
|
WORDPTR *ptr=DSTop-2;
|
|
|
|
// MAKE A HOLE IN THE STACK TO ADD NEGATION
|
|
while(ptr!=stkptr) {
|
|
*(ptr+2)=*ptr;
|
|
--ptr;
|
|
}
|
|
DSTop++; // MOVE ONLY ONE SPOT, DROPPING THE NEW OBJECT IN THE SAME OPERATION
|
|
stkptr[0]=newobj;
|
|
stkptr[1]=two_bint;
|
|
stkptr[2]=uminus_opcode;
|
|
}
|
|
}
|
|
|
|
if(ISREAL(*sobj)) {
|
|
// THE OBJECT IS A REAL NUMBER
|
|
mpd_t dec;
|
|
rplCopyRealToRReg(0,sobj);
|
|
if(mpd_isnegative(&RReg[0])) {
|
|
RReg[0].flags^=MPD_NEG; // MAKE IT POSITIVE
|
|
rplRRegToRealPush(0);
|
|
if(Exceptions) { DSTop=endofstk+1; return NULL; }
|
|
WORDPTR newobj=rplPeekData(1);
|
|
|
|
WORDPTR *ptr=DSTop-2;
|
|
|
|
// MAKE A HOLE IN THE STACK TO ADD NEGATION
|
|
while(ptr!=stkptr) {
|
|
*(ptr+2)=*ptr;
|
|
--ptr;
|
|
}
|
|
DSTop++; // MOVE ONLY ONE SPOT, DROPPING THE NEW OBJECT IN THE SAME OPERATION
|
|
stkptr[0]=newobj;
|
|
stkptr[1]=two_bint;
|
|
stkptr[2]=uminus_opcode;
|
|
}
|
|
}
|
|
|
|
--stkptr;
|
|
}
|
|
|
|
|
|
//*******************************************
|
|
// SCAN THE SYMBOLIC FOR ITEM B)
|
|
// B) ALL SUBTRACTIONS REPLACED WITH ADDITION OF NEGATED ITEMS
|
|
|
|
stkptr=DSTop-1;
|
|
|
|
while(stkptr!=endofstk) {
|
|
sobj=*stkptr;
|
|
|
|
if(*sobj==MKOPCODE(LIB_OVERLOADABLE,OVR_SUB)) {
|
|
|
|
WORDPTR *secondarg=rplSymbSkipInStack(stkptr-2);
|
|
|
|
WORDPTR *ptr=DSTop-1;
|
|
|
|
// MAKE A HOLE IN THE STACK TO ADD NEGATION
|
|
while(ptr!=secondarg) {
|
|
*(ptr+2)=*ptr;
|
|
--ptr;
|
|
}
|
|
DSTop+=2; // 2 PLACES IN THE STACK ARE GUARANTEED BY STACK SLACK
|
|
stkptr+=2;
|
|
secondarg[1]=two_bint;
|
|
secondarg[2]=uminus_opcode;
|
|
*stkptr=add_opcode;
|
|
stkptr--;
|
|
rplExpandStack(2); // NOW GROW THE STACK
|
|
if(Exceptions) { DSTop=endofstk+1; return NULL; }
|
|
}
|
|
|
|
|
|
|
|
--stkptr;
|
|
}
|
|
|
|
|
|
|
|
|
|
//*******************************************
|
|
// SCAN THE SYMBOLIC FOR ITEM C)
|
|
// C) ALL NEG(A+B+...) = NEG(A)+NEG(B)+NEG(...)
|
|
|
|
stkptr=DSTop-1;
|
|
while(stkptr!=endofstk) {
|
|
sobj=*stkptr;
|
|
|
|
if(*sobj==MKOPCODE(LIB_OVERLOADABLE,OVR_UMINUS)) {
|
|
WORDPTR *nextarg=stkptr-2;
|
|
|
|
if(**nextarg==MKOPCODE(LIB_OVERLOADABLE,OVR_ADD)) {
|
|
// A SUM NEGATED? DISTRIBUTE THE OPERATOR OVER THE ARGUMENTS
|
|
|
|
BINT nargs=OPCODE(**(nextarg-1))-1;
|
|
|
|
BINT c;
|
|
nextarg-=2;
|
|
for(c=0;c<nargs;++c) {
|
|
|
|
if(**nextarg==MKOPCODE(LIB_OVERLOADABLE,OVR_UMINUS)) {
|
|
// NEG/NEG = REMOVE THE NEGATION
|
|
WORDPTR *ptr=nextarg-1;
|
|
// AND REMOVE THE GAP
|
|
while(ptr!=DSTop-2) {
|
|
*ptr=*(ptr+2);
|
|
++ptr;
|
|
}
|
|
DSTop-=2;
|
|
stkptr-=2;
|
|
nextarg-=2;
|
|
}
|
|
else {
|
|
// NEGATE THIS TERM
|
|
WORDPTR *ptr=DSTop-1;
|
|
// AND REMOVE THE GAP
|
|
while(ptr!=nextarg) {
|
|
*(ptr+2)=*ptr;
|
|
--ptr;
|
|
}
|
|
|
|
DSTop+=2;
|
|
stkptr+=2;
|
|
nextarg[1]=two_bint;
|
|
nextarg[2]=uminus_opcode;
|
|
nextarg+=2;
|
|
}
|
|
|
|
nextarg=rplSymbSkipInStack(nextarg);
|
|
|
|
}
|
|
// REMOVE THE ORIGINAL NEGATION
|
|
WORDPTR *ptr=stkptr-1;
|
|
// AND REMOVE THE GAP
|
|
while(ptr!=DSTop-2) {
|
|
*ptr=*(ptr+2);
|
|
++ptr;
|
|
}
|
|
DSTop-=2;
|
|
stkptr-=2;
|
|
|
|
}
|
|
else stkptr--;
|
|
}
|
|
|
|
|
|
|
|
--stkptr;
|
|
}
|
|
|
|
|
|
|
|
|
|
|
|
|
|
//*******************************************
|
|
// SCAN THE SYMBOLIC FOR ITEM D)
|
|
// D) FLATTEN ALL ADDITION TREES
|
|
|
|
stkptr=DSTop-1;
|
|
while(stkptr!=endofstk) {
|
|
sobj=*stkptr;
|
|
|
|
if(*sobj==MKOPCODE(LIB_OVERLOADABLE,OVR_ADD)) {
|
|
BINT nargs=OPCODE(**(stkptr-1))-1;
|
|
|
|
BINT c,orignargs=nargs;
|
|
WORDPTR *nextarg=stkptr-2;
|
|
|
|
for(c=0;c<nargs;++c) {
|
|
|
|
if(**nextarg==MKOPCODE(LIB_OVERLOADABLE,OVR_ADD)) {
|
|
// FLATTEN BY REMOVING THE ADDITION
|
|
WORDPTR *ptr=nextarg-1;
|
|
nargs+=OPCODE(**(nextarg-1))-2; // ADD THE ARGUMENTS TO THE BASE LOOP
|
|
// AND REMOVE THE GAP
|
|
while(ptr!=DSTop-2) {
|
|
*ptr=*(ptr+2);
|
|
++ptr;
|
|
}
|
|
DSTop-=2;
|
|
stkptr-=2;
|
|
--c;
|
|
nextarg-=2;
|
|
}
|
|
else nextarg=rplSymbSkipInStack(nextarg);
|
|
|
|
}
|
|
|
|
// HERE stkptr IS POINTING TO THE ORIGINAL SUM COMMAND
|
|
// STORE THE NEW TOTAL NUMBER OF ARGUMENTS
|
|
if(orignargs!=nargs) {
|
|
WORDPTR newnumber=rplNewSINT(nargs+1,DECBINT);
|
|
if(!newnumber) { DSTop=endofstk+1; return NULL; }
|
|
*(stkptr-1)=newnumber;
|
|
}
|
|
|
|
stkptr--;
|
|
}
|
|
|
|
|
|
|
|
--stkptr;
|
|
}
|
|
|
|
|
|
//*******************************************
|
|
// SCAN THE SYMBOLIC FOR ITEM E)
|
|
// E) ALL NEGATIVE POWERS REPLACED WITH a^-n = INV(a^n)
|
|
|
|
stkptr=DSTop-1;
|
|
|
|
while(stkptr!=endofstk) {
|
|
sobj=*stkptr;
|
|
|
|
if(*sobj==MKOPCODE(LIB_OVERLOADABLE,OVR_POW)) {
|
|
|
|
WORDPTR *arg1=stkptr-2;
|
|
WORDPTR *arg2=rplSymbSkipInStack(arg1);
|
|
|
|
if(**arg2==MKOPCODE(LIB_OVERLOADABLE,OVR_UMINUS)) {
|
|
// NEGATIVE POWER DETECTED WE JUST NEED TO REPLACE THE UMINUS
|
|
// WITH AN INV()
|
|
|
|
// MOVE EVERYTHING TWO LEVELS UP
|
|
WORDPTR *ptr=arg2-1;
|
|
while(ptr!=stkptr+1) {
|
|
*ptr=*(ptr+2);
|
|
++ptr;
|
|
}
|
|
|
|
*stkptr=inverse_opcode;
|
|
--stkptr;
|
|
*stkptr=two_bint;
|
|
}
|
|
}
|
|
|
|
--stkptr;
|
|
}
|
|
|
|
//*******************************************
|
|
// SCAN THE SYMBOLIC FOR ITEM F)
|
|
// F) ALL DIVISIONS REPLACED WITH MULTIPLICATION BY INV()
|
|
|
|
stkptr=DSTop-1;
|
|
|
|
while(stkptr!=endofstk) {
|
|
sobj=*stkptr;
|
|
|
|
if(*sobj==MKOPCODE(LIB_OVERLOADABLE,OVR_DIV)) {
|
|
|
|
WORDPTR *secondarg=rplSymbSkipInStack(stkptr-2);
|
|
|
|
WORDPTR *ptr=DSTop-1;
|
|
|
|
// MAKE A HOLE IN THE STACK TO ADD INVERSE
|
|
while(ptr!=secondarg) {
|
|
*(ptr+2)=*ptr;
|
|
--ptr;
|
|
}
|
|
DSTop+=2; // 2 PLACES IN THE STACK ARE GUARANTEED BY STACK SLACK
|
|
stkptr+=2;
|
|
secondarg[1]=two_bint;
|
|
secondarg[2]=inverse_opcode;
|
|
*stkptr=mul_opcode;
|
|
stkptr--;
|
|
rplExpandStack(2); // NOW GROW THE STACK
|
|
if(Exceptions) { DSTop=endofstk+1; return NULL; }
|
|
}
|
|
|
|
|
|
|
|
--stkptr;
|
|
}
|
|
|
|
|
|
//*******************************************
|
|
// SCAN THE SYMBOLIC FOR ITEM G)
|
|
// G) ALL INV(A*B*...) = INV(A)*INV(B)*INV(...)
|
|
|
|
stkptr=DSTop-1;
|
|
while(stkptr!=endofstk) {
|
|
sobj=*stkptr;
|
|
|
|
if(*sobj==MKOPCODE(LIB_OVERLOADABLE,OVR_INV)) {
|
|
WORDPTR *nextarg=stkptr-2;
|
|
|
|
if(**nextarg==MKOPCODE(LIB_OVERLOADABLE,OVR_MUL)) {
|
|
|
|
BINT nargs=OPCODE(**(nextarg-1))-1;
|
|
|
|
BINT c;
|
|
nextarg-=2;
|
|
for(c=0;c<nargs;++c) {
|
|
|
|
if(**nextarg==MKOPCODE(LIB_OVERLOADABLE,OVR_INV)) {
|
|
// INV/INV = REMOVE THE OPERATOR
|
|
WORDPTR *ptr=nextarg-1;
|
|
// AND REMOVE THE GAP
|
|
while(ptr!=DSTop-2) {
|
|
*ptr=*(ptr+2);
|
|
++ptr;
|
|
}
|
|
DSTop-=2;
|
|
stkptr-=2;
|
|
nextarg-=2;
|
|
}
|
|
else {
|
|
// INVERT THIS TERM
|
|
WORDPTR *ptr=DSTop-1;
|
|
// AND REMOVE THE GAP
|
|
while(ptr!=nextarg) {
|
|
*(ptr+2)=*ptr;
|
|
--ptr;
|
|
}
|
|
|
|
DSTop+=2;
|
|
stkptr+=2;
|
|
nextarg[1]=two_bint;
|
|
nextarg[2]=inverse_opcode;
|
|
nextarg+=2;
|
|
rplExpandStack(2);
|
|
if(Exceptions){ DSTop=endofstk+1; return NULL; }
|
|
}
|
|
|
|
nextarg=rplSymbSkipInStack(nextarg);
|
|
|
|
}
|
|
// REMOVE THE ORIGINAL INVERSION
|
|
WORDPTR *ptr=stkptr-1;
|
|
// AND REMOVE THE GAP
|
|
while(ptr!=DSTop-2) {
|
|
*ptr=*(ptr+2);
|
|
++ptr;
|
|
}
|
|
DSTop-=2;
|
|
stkptr-=2;
|
|
|
|
}
|
|
else stkptr--;
|
|
}
|
|
|
|
|
|
|
|
--stkptr;
|
|
}
|
|
|
|
|
|
//*******************************************
|
|
// SCAN THE SYMBOLIC FOR ITEM H)
|
|
// H) FLATTEN ALL MULTIPLICATION TREES
|
|
|
|
stkptr=DSTop-1;
|
|
while(stkptr!=endofstk) {
|
|
sobj=*stkptr;
|
|
|
|
if(*sobj==MKOPCODE(LIB_OVERLOADABLE,OVR_MUL)) {
|
|
BINT nargs=OPCODE(**(stkptr-1))-1;
|
|
|
|
BINT c,orignargs=nargs;
|
|
WORDPTR *nextarg=stkptr-2;
|
|
|
|
for(c=0;c<nargs;++c) {
|
|
|
|
if(**nextarg==MKOPCODE(LIB_OVERLOADABLE,OVR_MUL)) {
|
|
// FLATTEN BY REMOVING THE ADDITION
|
|
WORDPTR *ptr=nextarg-1;
|
|
nargs+=OPCODE(**(nextarg-1))-2; // ADD THE ARGUMENTS TO THE BASE LOOP
|
|
// AND REMOVE THE GAP
|
|
while(ptr!=DSTop-2) {
|
|
*ptr=*(ptr+2);
|
|
++ptr;
|
|
}
|
|
DSTop-=2;
|
|
stkptr-=2;
|
|
--c;
|
|
nextarg-=2;
|
|
}
|
|
else nextarg=rplSymbSkipInStack(nextarg);
|
|
|
|
}
|
|
|
|
// HERE stkptr IS POINTING TO THE ORIGINAL MUL COMMAND
|
|
// STORE THE NEW TOTAL NUMBER OF ARGUMENTS
|
|
if(orignargs!=nargs) {
|
|
WORDPTR newnumber=rplNewSINT(nargs+1,DECBINT);
|
|
if(!newnumber) { DSTop=endofstk+1; return NULL; }
|
|
*(stkptr-1)=newnumber;
|
|
}
|
|
|
|
stkptr--;
|
|
}
|
|
|
|
|
|
|
|
--stkptr;
|
|
}
|
|
|
|
|
|
//*******************************************
|
|
// SCAN THE SYMBOLIC FOR ITEM I)
|
|
// I) SORT ALL MULTIPLICATIONS WITH INV(...) LAST, NON-INVERSE FACTORS FIRST
|
|
// ALSO, IF ALL FACTORS ARE INV(...), THEN ADD A BINT 1 AS FIRST ELEMENT (1/X)
|
|
|
|
// TODO...
|
|
|
|
|
|
stkptr=DSTop-1;
|
|
while(stkptr!=endofstk) {
|
|
sobj=*stkptr;
|
|
|
|
if(*sobj==MKOPCODE(LIB_OVERLOADABLE,OVR_MUL)) {
|
|
BINT nargs=OPCODE(**(stkptr-1))-1;
|
|
|
|
BINT c,orignargs=nargs;
|
|
WORDPTR *nextarg=stkptr-2;
|
|
WORDPTR *firstarg=nextarg;
|
|
WORDPTR *firstinv=NULL;
|
|
|
|
for(c=0;c<nargs;++c) {
|
|
|
|
if(**nextarg!=MKOPCODE(LIB_OVERLOADABLE,OVR_INV)) {
|
|
if(firstinv) {
|
|
// MOVE nextarg BEFORE firstinv
|
|
BINT nterms=nextarg-rplSymbSkipInStack(nextarg);
|
|
// HERE THE LAYOUT IS: DSTop ... firstinv... otherobj ... nextarg ... otherobj... end
|
|
// ^________________________|
|
|
// GROW STACK BY nterms
|
|
rplExpandStack(nterms);
|
|
if(Exceptions) { DSTop=endofstk+1; return NULL; }
|
|
// MOVE nextarg TO THE END OF STACK
|
|
WORDPTR *ptr=DSTop;
|
|
BINT f;
|
|
for(f=0;f<nterms;++f) ptr[f]=nextarg[-(nterms-1)+f];
|
|
// MOVE firstinv BACK
|
|
ptr=nextarg+1;
|
|
while(ptr<=firstinv) { ptr[-nterms]=*ptr; ++ptr; }
|
|
// MOVE nextarg BACK IN PLACE OF firstinv
|
|
ptr=DSTop+nterms-1;
|
|
for(f=0;f<nterms;++f,--ptr) firstinv[-f]=*ptr;
|
|
firstinv-=nterms; // KEEP FIRST INV POINTING TO THE SAME PLACE
|
|
nextarg-=nterms;
|
|
}
|
|
else nextarg=rplSymbSkipInStack(nextarg);
|
|
|
|
} else {
|
|
if(!firstinv) firstinv=nextarg;
|
|
nextarg=rplSymbSkipInStack(nextarg);
|
|
}
|
|
|
|
}
|
|
|
|
if(firstarg==firstinv) {
|
|
// ALL FACTORS ARE INVERTED
|
|
|
|
// TODO: ADD A BINT 1 TO CREATE 1/X
|
|
|
|
}
|
|
|
|
stkptr--;
|
|
}
|
|
|
|
|
|
|
|
--stkptr;
|
|
}
|
|
|
|
|
|
|
|
|
|
if(Exceptions) {
|
|
DSTop=endofstk+1;
|
|
return NULL;
|
|
}
|
|
|
|
WORDPTR finalsymb=rplSymbImplode(DSTop-1-endofstk);
|
|
|
|
DSTop=endofstk+1;
|
|
if(Exceptions) return NULL;
|
|
|
|
rplPushData(finalsymb);
|
|
return rplPeekData(1);
|
|
|
|
}
|
|
|
|
|
|
|
|
// ATTEMPTS TO MATCH A RULE THAT IS A SERIES OF TERMS (OR FACTORS)
|
|
// THERE CAN BE 3 RESULTS:
|
|
// 0 = NO MATCH
|
|
// 1 = EXACT MATCH
|
|
// 2 = PARTIAL MATCH, THERE ARE TERMS THAT MATCH, AND SOME OTHER TERMS LEFT OVER.
|
|
// THE RESULT IS COMPOSED OF A MATCHING AND A NON-MATCHING SET OF TERMS.
|
|
|
|
// THIS FUNCTION ASSUMES Opcode IS ASSOCIATIVE AND COMMUTATIVE.
|
|
|
|
BINT rplSymbCommutativeMatch(WORD Opcode,WORDPTR rulelist,WORDPTR objlist)
|
|
{
|
|
// Opcode = MAIN OPCODE IN rulelist AND objlist (CAN BE OVR_ADD OR OVR_MUL)
|
|
// rulelist = SYMBOLIC OBJECT { Opcode arg1 arg2 ... argN } TO MATCH FROM
|
|
// objlist = OBJECT TO MATCH, IF IT'S NOT THE SAME OPERATION, IT'S CONSIDERED AS A SINGLE TERM { Opcode objlist }
|
|
|
|
// EXPLODE objlist ON THE STACK
|
|
|
|
// MATCH FIRST TERM IN rulelist WITH ANY TERM IN objlist, SORT objlist BRINGING THE TERM TO THE START OF THE LIST
|
|
// MATCH NEXT TERM IN rulelist WITH ANY OF THE REMAINDER TERMS IN objlist, SORTING AS NEEDED
|
|
// IF THE TERM IN rulelist IS A SPECIAL IDENT, MATCH AS MANY TERMS IN objlist AS REQUESTED AND DEFINE THE VARIABLE
|
|
// AT THE END OF rulelist, IF THERE ARE ANY UNMATCHED TERMS THERE IS A PARTIAL MATCH
|
|
|
|
}
|
|
|
|
|
|
// RECURSIVE SYMBOLIC MATCH AND APPLY
|
|
|
|
// MATCH ONE TO ANY: TAKE ONE RULE AND MATCH IT WITH ALL TERMS IN A LIST, RECURSE AS NEEDED AND APPLY
|
|
// ALL VARIABLE STORAGE IS WITHIN A LOCAL ENVIRONMENT
|
|
// LAMS:
|
|
// 1 = RULE TO MATCH
|
|
// 2 = LIST OF OBJECTS,
|
|
// 3 = PTR TO CURRENT RULE OBJECT
|
|
// 4 = PTR TO CURRENT OBJECT
|
|
// 5 = MATCH STATUS,
|
|
// 6 = NUMBER OF OBJECTS IN CURRENT OBJECT
|
|
// 5 ... N = NAMED LAMS WITH ALL SPECIAL IDENTS IN THE RULE, WITH THEIR ASSIGNED VALUES SO FAR
|
|
// N+1 ... M = LIST OF OBJECTS IN CURRENT OBJECT, FOR SORTING
|
|
|
|
// LOGIC:
|
|
// CREATE A NEW ENVIRONMENT
|
|
// INITIALIZE ALL VARIABLES
|
|
// EXPLODE THE OBJECT
|
|
// CURRENT RULE OBJECT = START OF RULE
|
|
// TAKE CURRENT OBJECT AND MATCH CURRENT RULE...
|
|
// IF RULE IS ATOMIC {
|
|
// IF RULE IS SPECIAL IDENT AND IS ALREADY DEFINED, TAKE VALUE OF IDENT + OBJECT AND GOTO LOGIC:
|
|
// IF RULE IS A SPECIAL IDENT NOT PREVIOUSLY DEFINED, DEFINE IT
|
|
// IF OBJECT IS ATOMIC, CHECK MATCH OR NOT
|
|
// IF OBJECT IS A SYMBOLIC AND OPCODE MATCHES RULE OPCODE, TAKE CURRENT RULE + CURRENT OBJECT AND GOTO LOGIC: (TO START WITH THE CURRENT OBJECT EXPLODED)
|
|
// }
|
|
// IF RULE IS SYMBOLIC OPERATION {
|
|
// EXPLODE THE RULE, AND DO A LOOP TAKING ONE RULE OBJECT TO MATCH WITH EACH OBJECT
|
|
|
|
void rplSymbRuleApply(WORDPTR expression,WORDPTR rule)
|
|
{
|
|
// CREATE A SEPARATE LOCAL ENVIRONMENT
|
|
rplCreateLAMEnvironment(expression);
|
|
|
|
rplCreateLAM(nulllam_ident,zero_bint); // LAM1 = MATCH RESULT IS THE FIRST LAM
|
|
|
|
if(Exceptions) return;
|
|
|
|
if(ISSYMBOLIC(expression)) expression=rplSymbUnwrap(expression);
|
|
if(ISSYMBOLIC(rule)) rule=rplSymbUnwrap(rule);
|
|
|
|
if(!rule || !expression) return;
|
|
BINT rulesize=rplObjSize(rule),expsize=rplObjSize(expression);
|
|
|
|
rplCreateLAM(nulllam_ident,expression); // LAM2 = ORIGINAL EXPRESSION
|
|
rplCreateLAM(nulllam_ident,rule); // LAM3 = ORIGINAL RULE
|
|
rplCreateLAM(nulllam_ident,expression); // LAM4 = CURRENT EXPRESSION POINTER
|
|
rplCreateLAM(nulllam_ident,rule); // LAM5 = CURRENT RULE POINTER
|
|
|
|
while(rplGetLAMn(5)-rplGetLAMn(2)<rulesize) {
|
|
// if()
|
|
|
|
|
|
|
|
}
|
|
|
|
if(Exceptions) return;
|
|
|
|
|
|
}
|