lsASMEPRO SUB+ASSEM Z80 HCLASS Z80CMD Z804lDATBADD Z80 <6EPRO COM.EPRO DOCaEPRO Z80;3ERROR Z80nHEAP Z80u5)INIT Z803~INPUT Z80/OUTPUT Z8027P VAL[PROVE Z80 M/SAMPLE PROVSCIAM PROZ STD PROdSYMB Z80k+UNIFY Z803OVALGOL DOC'UVALGOL PROCZ; completely reassemble E-Prolog m80 =epro.z80 m80 =class.Z80 m80 =symb.Z80 m80 =heap.Z80 m80 =init.z80 m80 =datbadd.Z80 m80 =unify.Z80 m80 =cmd.Z80 m80 =prove.Z80 m80 =input.z80 m80 =output.z80 m80 =error.z80 m80 =assem.z80/z xsub l80 epro/n,epro,class,symb,heap,datbadd,unify,cmd,prove input,output,error,assem,init/e  ; =========================================================== ; ASSEM.Z80 ; assembly-language portions of E-Prolog ; May 11, 1985 ; (for Macro-80) ; This module should be loaded last (except for initialization ; code), since anything following it will be overwritten by ; the symbol table. .Z80 EMPT EQU -1 ?STNG MACRO ?TXT,?ADDR,?LP,?RP DW ?ADDR DW ?LP DW ?RP DB ?TXT DB 0 ENDM ; char * sbot = ASBOT; SBOT:: DW ASBOT ; char * sfree = ASFREE; SFREE:: DW ASFREE $MEMRY:: DS 2 CSEG SETTOP:: LD DE,($MEMRY) PUSH DE ADD HL,DE PUSH HL LD DE,128 ADD HL,DE SBC HL,SP JR C,SET1 POP DE POP DE JP RETF## SET1: POP HL LD ($MEMRY),HL POP HL RET EXTRN _APPEN,_CLOSE,_CREA,_LESS,_LIST,_LOAD EXTRN _OPEN,_READ,_READC,_READL,_SAVE EXTRN _WRITE,_WRCH,_CUT,_FAIL ; symbol table ASBOT: ADOT:: ?STNG <'.'>,EMPT,EMPT,A10 A2: ?STNG <'/'>,_CUT,EMPT,EMPT ACOLON:: ?STNG <':'>,EMPT,A2,A4 A4: ?STNG <'APPEND'>,_APPEN,EMPT,EMPT A5: ?STNG <'CLOSE'>,_CLOSE,ACOLON,A6 ACON:: ?STNG <'CON'>,EMPT,EMPT,EMPT A6: ?STNG <'CREATE'>,_CREA,ACON,A8 A7: ?STNG <'FAIL'>,_FAIL,EMPT,EMPT A8: ?STNG <'LESS'>,_LESS,A7,A9 A9: ?STNG <'LIST'>,_LIST,EMPT,EMPT A10: ?STNG <'LOAD'>,_LOAD,A5,A15 ANULL:: ?STNG <'NULL'>,EMPT,EMPT,EMPT A12: ?STNG <'OPEN'>,_OPEN,ANULL,A14 APRO:: ?STNG <'PRO'>,EMPT,EMPT,EMPT A14: ?STNG <'READ'>,_READ,APRO,EMPT A15: ?STNG <'READCHAR'>,_READC,A12,A17 A16: ?STNG <'READLIST'>,_READL,EMPT,EMPT A17: ?STNG <'SAVE'>,_SAVE,A16,A19 A18: ?STNG <'WRITE'>,_WRITE,EMPT,EMPT A19: ?STNG <'WRITECHAR'>,_WRCH,A18,EMPT ASFREE: END  ; =========================================================== ; CLASS.Z80 ; predicates, classifiers and tag-movers for E-Prolog ; June 22, 1985 .Z80 FALSE EQU 0 TRUE EQU 1 EMPTY EQU -1 UNDEF EQU -2 HT EQU 9 LF EQU 10 CR EQU 13 CTLZ EQU 26 CPM EQU 0000H BDOS EQU CPM+0005H CDMA EQU CPM+0080H TPA EQU CPM+0100H ;BOOLEAN ;atomp(p) ; char * p; ; { ; return (nelistp(p) && symbp(first(p))); ; } ATOMP:: PUSH HL CALL NELP JP Z,POPF CALL @LEFT CALL SYMBP POP HL RET ;BOOLEAN ;clausep(p) ; char * p; ; { ; return (nelistp(p) && atomp(first(p))); ; } CLP:: PUSH HL CALL NELP JP Z,POPF CALL @LEFT CALL ATOMP POP HL RET ;BOOLEAN ;listp(p) ; char * p; ; { ; return (p == empty || nelistp(p)); ; } LISTP:: PUSH HL CALL NELP JP NZ,POPT LD DE,EMPTY CALL CPHL## JP Z,POPT JP POPF ;BOOLEAN ;nelistp(p) ; char * p; ; { ; return (hbot <= p && p < hfree); ; } NELP:: PUSH HL LD DE,(STOP##) CALL CPHL## JP C,POPF LD DE,(HFREE##) CALL CPHL## JP NC,POPF JP POPT ;BOOLEAN ;numbp(p) ; char * p; ; { ; return (0 <= p && p < sbot); ; } NUMBP:: PUSH HL LD DE,(SBOT) CALL CPHL## JP C,POPT JP POPF ;BOOLEAN ;substp(x) ; /* distinguish (SUBST *) from (SEXPR *) in SUBVAL */ ; SUBVAL * x; ; { ; return varp(x->vname); ; } SUBSTP:: PUSH HL CALL @VNAME CALL VARP POP HL RET ;BOOLEAN ;symbp(p) ; char * p; ; { ; return (sbot <= p && p < sfree); ; } SYMBP:: PUSH HL LD DE,(SBOT##) CALL CPHL## JP C,POPF LD DE,(SFREE##) CALL CPHL## JP NC,POPF JP POPT ;BOOLEAN ;varp(p) ; SYMBOL * p; ; { ; return (symbp(p) && (p->string[0] == '?')); ; } VARP:: PUSH HL CALL SYMBP JR Z,POPF CALL @STR LD A,(HL) CP '?' JR Z,POPT JR POPF POPT: LD A,1 OR A POP HL RET POPF: XOR A POP HL RET ; ------------ indirect reference routines ---------------- INDIR:: LD A,(HL) INC HL LD H,(HL) LD L,A RET @LINDIR: PUSH HL ADD HL,BC LINDIR:: LD (HL),E INC HL LD (HL),D POP HL RET @INDIR: ADD HL,DE JR INDIR @IND0 EQU INDIR @IND2: LD DE,2 JR @INDIR @IND4: LD DE,4 JR @INDIR @IND6: LD DE,6 JR @INDIR @LIND0: LD BC,0 JR @LINDIR @LIND2: LD BC,2 JR @LINDIR @LIND4: LD BC,4 JR @LINDIR @LIND6: LD BC,6 JR @LINDIR ; for (SYMBOL *) or VARIABLE PUBLIC @ADDR,@LPTR,@RPTR,@LADDR,@LLPTR,@LRPTR,@STR @ADDR EQU @IND0 @LPTR EQU @IND2 @RPTR EQU @IND4 @LADDR EQU @LIND0 @LLPTR EQU @LIND2 @LRPTR EQU @LIND4 @STR: LD DE,6 ; pointer ADD HL,DE RET ; for (NODE *) or PAIR PUBLIC @LEFT,@RIGHT,@LLEFT,@LRIGHT @LEFT EQU @IND0 @RIGHT EQU @IND2 @LLEFT EQU @LIND0 @LRIGHT EQU @LIND2 ; for (SUBST *) or LSUBST PUBLIC @VNAME,@BACK,@FORW,@LVNAME,@LBACK,@LFORW @VNAME EQU @IND0 @BACK EQU @IND2 @FORW EQU @IND4 @LVNAME EQU @LIND0 @LBACK EQU @LIND2 @LFORW EQU @LIND4 ; for (SEXPR *) PUBLIC @EXPR,@SLIST,@LEXPR,@LSLIST @EXPR EQU @IND0 ;@BACK as above @SLIST EQU @IND4 @LEXPR EQU @LIND0 ;@LBACK as above @LSLIST EQU @LIND4 ; for (ALPHASTATE *) PUBLIC @PRED,@XBACK @PRED EQU @IND0 XPRED:: LD L,(IX+0) LD H,(IX+1) RET XGOAL:: LD L,(IX+2) LD H,(IX+3) RET XDATB:: LD L,(IX+4) LD H,(IX+5) RET XBACK:: LD L,(IX+6) LD H,(IX+7) RET @XBACK EQU @IND6 XLPRED:: LD (IX+0),L LD (IX+1),H RET XLGOAL:: LD (IX+2),L LD (IX+3),H RET XLDATB:: LD (IX+4),L LD (IX+5),H RET XLBACK:: LD (IX+6),L LD (IX+7),H RET ; for (BETASTATE *) YPRED:: LD L,(IY+0) LD H,(IY+1) RET YASS:: LD L,(IY+2) LD H,(IY+3) RET YLPRED:: LD (IY+0),L LD (IY+1),H RET YLASS:: LD (IY+2),L LD (IY+3),H RET YSUBST:: PUSH IY ; pointer POP HL @SUBST:: INC HL INC HL INC HL INC HL RET END  ; =========================================================== ; CMD.Z80 ; built-in commands for E-Prolog ; June 1, 1985 .Z80 FALSE EQU 0 TRUE EQU 1 EMPTY EQU -1 UNDEF EQU -2 HT EQU 9 LF EQU 10 CR EQU 13 CTLZ EQU 26 CPM EQU 0000H BDOS EQU CPM+0005H CDMA EQU CPM+0080H TPA EQU CPM+0100H ; compare with given value ; ?CPHL MACRO ?VALUE PUSH DE LD DE,?VALUE CALL CPHL## POP DE ENDM ; copy string ; ; input: ; HL -> source ; all registers destroyed ?COPY MACRO ?ADDR LD DE,?ADDR CALL COPY## ENDM ; local storage DSEG LOCST: DS 8 REST EQU LOCST LS EQU LOCST+2 X EQU LOCST+4 Y EQU LOCST+6 SV EQU LOCST+4 PTR EQU LOCST LSS EQU LS X1 EQU LOCST+4 X2 EQU LOCST+6 CSEG ;noretry(ast) ; ALPHASTATE * ast; ; { ; ast->datb = (PAIR)empty; ; } NORE:: LD HL,EMPTY ;setretry(ast,addr) ; ALPHASTATE * ast; ; char * addr; ; { ; ast->datb = (PAIR *)addr; ; } SETRE:: JP XLDATB## ;SYMBOL * ;vnext(pexp,plsub) ; EXPR * pexp; ; LSUBST * plsub; ; { ; SYMBOL * x; ; SEXPR * y; DSEG PEXP: DW 0 PLSUB: DW 0 VX: DW 0 VY: DW 0 CSEG VNEXT:: LD (PEXP),HL LD (PLSUB),DE ; ; if (varp(pexp->list)) CALL INDIR## CALL VARP## JR Z,VN1 ; { ; y = value(vf(pexp->list,*plsub)); PUSH HL LD HL,(PLSUB) CALL INDIR## EX DE,HL POP HL CALL VF## CALL VALUE## LD (VY),HL ; if (substp(y)) CALL SUBSTP## JR Z,VN2 ; return UNDEF; LD HL,UNDEF RET VN2: ; pexp->list = y->sexp.list; CALL @EXPR## EX DE,HL LD HL,(PEXP) LD (HL),E INC HL LD (HL),D ; *plsub = y->slist; LD HL,(VY) CALL @SLIST## EX DE,HL LD HL,(PLSUB) LD (HL),E INC HL LD (HL),D ; } VN1: ; if (nelistp(pexp->list)) LD HL,(PEXP) CALL INDIR## CALL NELP## JR Z,VN3 ; { ; x = pexp->list->left.symbol; CALL @LEFT## LD (VX),HL ; if (varp(x)) CALL VARP## JR Z,VN4 ; { ; y = value(vf(x,*plsub)); PUSH HL LD HL,(PLSUB) CALL INDIR## EX DE,HL POP HL CALL VF## CALL VALUE## LD (VY),HL ; x = y->sexp.symbol; CALL @EXPR## LD (VX),HL ; if (varp(x)) CALL VARP## JR Z,VN4 ; x = y; LD HL,(VY) LD (VX),HL ; } VN4: ; pexp->list = pexp->list->right.list; LD HL,(PEXP) PUSH HL CALL INDIR## CALL @RIGHT## EX DE,HL POP HL LD (HL),E INC HL LD (HL),D ; return x; LD HL,(VX) RET ; } VN3: ; return UNDEF; LD HL,UNDEF RET ; } RETT:: LD HL,TRUE RETX: LD A,H OR L RET RETF:: LD HL,FALSE JR RETX ;built-in commands called in this form: ; f(rest,ast,ls,pbst) ; PAIR rest; (in HL) rest of atom ; ALPHASTATE * ast; (in IX) this state ; LSUBST ls; (in DE ) substs for rest ; BETASTATE * bst; (in IY) empty, at first ; ;return TRUE to succeed, return FALSE to fail ;call noretry() to prohibit further retries ;call setretry() to set entry point for next retry ; ==================== / ==================== ;_cut(rest,ast,ls,pbst) ; PAIR rest; ; ALPHASTATE * ast; ; LSUBST ls; ; BETASTATE ** pbst; ; { ; setretry(ast,&rcut); ; return TRUE; ; } _CUT:: LD HL,RCUT CALL SETRE JP RETT ;rcut() /* retry of cut */ ; { ; return EMPTY; ; } RCUT:: LD HL,EMPTY LD A,H OR L RET ; ==================== APPEND ==================== ; APPEND command ; ; open file for output, position to the end of the file _APPEN:: PUSH HL PUSH DE CALL NORE CALL CLOSE## ; close existing output file POP DE POP HL CALL DOOUT## LD A,(OUTF##) DEC A JP NZ,RETT ; not disk file LD DE,OUTFCB## LD C,15 ; open file CALL BDOS INC A JR NZ,APPEN1 LD (OUTF),A ; not found, revert to console JP RETF APPEN1: LD DE,OUTFCB## LD C,35 ; compute file size CALL BDOS LD HL,(OUTFCB##+33) ; random record number DEC HL LD (OUTFCB##+33),HL ; last existing record LD DE,OUTDMA## LD C,26 ; set DMA CALL BDOS LD DE,OUTFCB## LD C,33 ; read random CALL BDOS LD HL,OUTDMA## APPEN2: LD A,(HL) CP CTLZ JR Z,APPEN3 INC HL ?CPHL OUTE## JR NZ,APPEN2 LD DE,OUTFCB## ; read sequential to prepare LD C,20 ; next record field CALL BDOS LD HL,OUTE## APPEN3: LD (OUTP),HL JP RETT ; ==================== CLOSE ==================== ;_close(rest,ast) ; PAIR rest; ; ALPHASTATE * ast; ; { ; noretry(ast); ; close(); ; } _CLOSE:: CALL NORE CLOSEX: CALL CLOSE## JP RETT ; ==================== CREATE ==================== ; CREATE command ; ; opens a new file as output ; deletes any existing file with the same name ; (cf. APPEND command) _CREA:: PUSH HL PUSH DE CALL NORE CALL CLOSE## ; close existing output file POP DE POP HL CALL DOOUT## CALL SAVEX JP RETT ; ==================== FAIL ==================== ;_fail() ; { ; return FALSE; ; } _FAIL:: JP RETF ; ==================== LESS ==================== ;_less(rest,ast,ls,pbst) ; PAIR rest; ; ALPHASTATE * ast; ; LSUBST ls; ; BETASTATE ** pbst; ; { ; static EXPR x1; ; static EXPR x2; ; static LSUBST lss; _LESS:: ; ; lss = ls; LD (REST),HL LD (LSS),DE ; noretry(ast); CALL NORE ; x1.list = vnext(&rest,&lss); LD HL,REST LD DE,LSS CALL VNEXT LD (X1),HL ; if (x1.list == UNDEF) ; return FALSE; ?CPHL UNDEF JP Z,RETF ; x2.list = vnext(&rest,&lss); LD HL,REST LD DE,LSS CALL VNEXT LD (X2),HL ; if (x2.list == UNDEF) ; return FALSE; ?CPHL UNDEF JP Z,RETF ; if (numbp(x1.number) && numbp(x2.number)) ; return (x1.number < x2.number); LD HL,(X1) CALL NUMBP## JR Z,LE1 LD HL,(X2) CALL NUMBP## JR Z,LE1 LD HL,(X1) LD DE,(X2) CALL CPHL## JP C,RETT JP RETF LE1: ; if (symbp(x1.symbol) && symbp(x2.symbol)) ; return (strcmp(x1.symbol->string,x2.symbol->string) < 0); LD HL,(X1) CALL SYMBP## JR Z,LE2 LD HL,(X2) CALL SYMBP## JR Z,LE2 LD HL,(X2) CALL @STR## PUSH HL LD HL,(X1) CALL @STR## POP DE CALL STRCMP## JP C,RETT JP RETF LE2: ; *pbst = makebeta(ast,empty); LD HL,EMPTY CALL MKBETA## ; if (substp(x1.symbol)) LD HL,(X1) CALL SUBSTP## JR Z,LE3 ; { ; setretry(ast,&rless); LD HL,RLESS CALL SETRE ; if (numbp(x2.number)) LD HL,(X2) CALL NUMBP## JR Z,LE5 ; { ; lessv(x2.number-1,x1.symbol); LD HL,(X2) DEC HL LD DE,(X1) CALL LESSV ; return TRUE; JP RETT ; } LE5: ; if (substp(x2.symbol)) LD HL,(X2) CALL SUBSTP## JP Z,LE6 ; { ; lessv(0,x1.symbol); LD HL,0 LD DE,(X1) CALL LESSV ; lessv(1,x2.symbol); LD HL,1 LD DE,(X2) CALL LESSV ; return TRUE; JP RETT ; } LE6 EQU RETF ; } LE3: ; else if (substp(x2.symbol)) LD HL,(X2) CALL SUBSTP## JP Z,LE4 ; { ; setretry(ast,&rless); LD HL,RLESS CALL SETRE ; if (numbp(x1.number)) LD HL,(X1) CALL NUMBP## JP Z,LE4 ; { ; lessv(x1.number+1,x2.symbol); LD HL,(X1) INC HL LD DE,(X2) CALL LESSV ; return TRUE; JP RETT ; } ; } LE4 EQU RETF ; return FALSE; ; } ; ;rless() RLESS: ; needs more work to do retries ; { ; fatal("\r\nRetry on LESS."); LD HL,RLMSG JP FATAL## DSEG RLMSG: DB CR,LF,'Retry on LESS.',0 CSEG ; } ; ;lessv(val,sub) ; NUMBER val; ; SUBST * sub; ; { ; unify(val,empty,sub->vname,sub); LESSV: PUSH DE LD DE,EMPTY EXX POP HL PUSH HL CALL @VNAME## POP DE EXX JP UNIFY## ; } ; ==================== LIST ==================== ;_list(rest,ast) ; PAIR rest; ; ALPHASTATE * ast; ; { _LIST:: ; noretry(ast); CALL NORE ; listt((SYMBOL *)sbot); LISTX: LD HL,(SBOT##) CALL LISTT ; return TRUE; JP RETT ; } ; ;listt(ptr) /* recursive */ ; SYMBOL * ptr; ; { ; PAIR x; LISTT: LD (PTR),HL ; ; if (ptr != (SYMBOL *)empty) ?CPHL EMPTY RET Z ; { ; listt(ptr->lptr); LD HL,(PTR) PUSH HL CALL @LPTR## CALL LISTT ; recursive POP HL LD (PTR),HL ; if (nelistp(x = (PAIR)(ptr->addr))) CALL @ADDR## LD (X),HL CALL NELP## JR Z,LI1 ; { ; do LI2: ; { ; listpr(x->left.list); LD HL,(X) CALL @LEFT## CALL LISTPR ; } ; while (nelistp(x = x->right.list)) ; LD HL,(X) CALL @RIGHT## LD (X),HL CALL NELP## JR NZ,LI2 ; chrout('\r'); ; chrout('\n'); CALL CRLF## ; } LI1: ; listt(ptr->rptr); LD HL,(PTR) CALL @RPTR## JR LISTT ; tail recursion ; } ; } ; ;listpr(y) ; PAIR y; ; { LISTPR: LD (Y),HL ; chrout('('); LD A,'(' CALL CHROUT## ; eprint(y->left.list,empty); LD HL,(Y) CALL @LEFT## LD DE,EMPTY CALL EPRINT## ; for (y = y->right.list ; nelistp(y) ; y = y->right.list) ; { LI4: LD HL,(Y) CALL @RIGHT## LD (Y),HL CALL NELP## JR Z,LI3 ; msg("\r\n\t"); LD HL,LI4MSG DSEG LI4MSG: DB CR,LF,HT,0 CSEG CALL MSG## ; eprint(y->left.list,empty); LD HL,(Y) CALL @LEFT LD DE,EMPTY CALL EPRINT## ; } JR LI4 LI3: ; msg(")\r\n"); LD HL,LI3MSG DSEG LI3MSG: DB ')',CR,LF,0 CSEG JP MSG## ; } ; ==================== LOAD ==================== ; LOAD command ; ; load from given disk file ; default filetype 'PRO' _LOAD:: CALL DOIN## CALL NORE LD A,(INF##) DEC A JP NZ,RETT ; not a disk file LD A,(INFCB##+9) CP ' ' ; no filetype? JR NZ,LOAD1 LD HL,APRO## ; use default 'PRO' ?COPY INFCB##+9 LOAD1: JP LOADX ; ==================== OPEN ==================== ; OPEN command ; ; opens an existing file as input _OPEN:: CALL DOIN## CALL NORE LD A,(INF##) DEC A JP NZ,RETT ; not a disk file LOADX: LD DE,INFCB## LD C,15 ; open file CALL BDOS INC A ; file found? JR NZ,OPEN1 ; yes XOR A LD (INF##),A JP RETF OPEN1: XOR A LD (INFCB##+32),A ; zero current record LD HL,INE## ; pointer beyond end LD (INP##),HL JP RETT ; ==================== READ ==================== ;_read(rest,ast,ls,pbst) ; PAIR rest; ; ALPHASTATE * ast; ; LSUBST ls; ; BETASTATE ** pbst; ; { ; PAIR x; _READ:: LD (REST),HL LD (LS),DE ; noretry(ast); CALL NORE ; x = makepair(gtoken(),empty); CALL GTOKEN## JR READX ; ==================== READCHAR ==================== ;_readc(rest,ast,ls,pbst) ; PAIR rest; ; ALPHASTATE * ast; ; LSUBST ls; ; BETASTATE ** pbst; ; { ; PAIR x; ; _READC:: LD (REST),HL LD (LS),DE ; noretry(ast); CALL NORE ; rdchar(); CALL RDCHAR## ; x = makepair(character,empty); LD A,(CHR##) LD L,A LD H,0 READX: LD DE,EMPTY CALL MKPAIR## LD (X),HL ; *pbst = makebeta(ast,empty); LD HL,EMPTY CALL MKBETA## ; if (unify(rest,ls,x,empty)) ; return TRUE; LD HL,(X) LD DE,EMPTY EXX LD HL,(REST) LD DE,(LS) CALL UNIFY## JP NZ,RETT ; release(x); LD HL,(X) CALL RLS## ; return FALSE; JP RETF ; } ; ==================== READLIST ==================== ;_readl(rest,ast,ls,pbst) ; PAIR rest; ; ALPHASTATE * ast; ; LSUBST ls; ; BETASTATE ** pbst; ; { ; PAIR x; ; _READL:: LD (REST),HL LD (LS),DE ; noretry(ast); CALL NORE ; opar = 0; XOR A LD (OPAR##),A ; x = makepair(rdg1(),empty); CALL RDG1## JR READX ; ==================== SAVE ==================== ; SAVE command ; ; saves database to named file ; default filetype 'PRO' _SAVE:: PUSH HL PUSH DE CALL NORE CALL CLOSE## ; close existing output file POP DE POP HL CALL DOOUT## LD A,(OUTFCB##+9) CP ' ' ; no filetype? JR NZ,SAVE1 LD HL,APRO## ; use default 'PRO' ?COPY OUTFCB##+9 SAVE1: CALL SAVEX ; create the file for output CALL LISTX ; send listing to file JP CLOSEX ; close file SAVEX: LD A,(OUTF##) DEC A RET NZ ; not disk file LD DE,OUTFCB## LD C,19 ; delete file CALL BDOS LD DE,OUTFCB## LD C,22 ; make file CALL BDOS INC A JP Z,RETF ; unsuccessful LD HL,OUTDMA## LD (OUTP##),HL RET ; ==================== WRITE ==================== ;_write(rest,ast,ls,pbst) ; PAIR rest; ; ALPHASTATE * ast; ; LSUBST ls; ; BETASTATE ** pbst; ; { ; static SUBVAL sv; _WRITE:: LD (REST),HL LD (LS),DE ; noretry(ast); CALL NORE ; if (varp(rest)) LD HL,(REST) CALL VARP## JR Z,WR1 ; { ; if (substp(sv.val = value(vf(rest,ls)))) ; ; LD DE,(LS) CALL VF## CALL VALUE## LD (SV),HL CALL SUBSTP## JR NZ,WR1 ; else ; { ; rest = sv.assgn->sexp.list; CALL @EXPR## LD (REST),HL ; ls = sv.assgn->slist; LD HL,(SV) CALL @SLIST## LD (LS),HL ; } ; } WR1: ; while (nelistp(rest)) LD HL,(REST) CALL NELP## JR Z,WR2 ; { ; eprint(rest->left.list,ls); CALL @LEFT LD DE,(LS) CALL EPRINT## ; rest = rest->right.list; LD HL,(REST) CALL @RIGHT## LD (REST),HL ; if (varp(rest)) CALL VARP## JR Z,WR3 ; { ; if (substp(sv.val = value(vf(rest,ls)))) ; ; LD DE,(LS) CALL VF## CALL VALUE## LD (SV),HL CALL SUBSTP## JR NZ,WR3 ; else ; { ; rest = sv.assgn->sexp.list; CALL @EXPR## LD (REST),HL ; ls = sv.assgn->slist; LD HL,(SV) CALL @SLIST## LD (LS),HL ; } ; } WR3 EQU WR1 JR WR1 ; } WR2: ; return TRUE; JP RETT ; } ; ==================== WRITECHAR ==================== ;_wrch(rest,ast,ls,pbst) ; PAIR rest; ; ALPHASTATE * ast; ; LSUBST ls; ; BETASTATE ** pbst; ; { ; NUMBER x; _WRCH:: LD (REST),HL LD (LS),DE ; noretry(ast); CALL NORE ; x = vnext(&rest,&ls); LD HL,REST LD DE,LS CALL VNEXT ; if (! numbp(x)) ; return FALSE; CALL NUMBP## JP Z,RETF ; if (x > 255) ; return FALSE; LD DE,256 CALL CPHL## JP NC,RETF ; putc(x,outfile); LD A,L CALL CHROUT## ; return TRUE; JP RETT ; } END  ; =========================================================== ; DATBADD.Z80 ; add to the database in E-Prolog ; May 26, 1985 .Z80 FALSE EQU 0 TRUE EQU 1 EMPTY EQU -1 UNDEF EQU -2 HT EQU 9 LF EQU 10 CR EQU 13 CTLZ EQU 26 CPM EQU 0000H BDOS EQU CPM+0005H CDMA EQU CPM+0080H TPA EQU CPM+0100H DSEG ;PAIR alldb; ALLDB:: DS 2 ;PAIR * alldbe; ALLDBE:: DS 2 CSEG ;datbadd(relname,clause) ; SYMBOL * relname; ; EXPR clause; ; { ; static PAIR * ptr; DSEG CLAUSE: DW 0 PTR: DW 0 CSEG DBADD:: ; LD (CLAUSE),DE ; ptr = &relname->addr; LD (PTR),HL ; if (numbp(*ptr)) CALL INDIR## CALL NUMBP## JR Z,DB1 ; { ; errmsg(" Cannot change built-in commands.\r\n"); ; return; LD HL,DB1MSG JP ERRMSG## DSEG DB1MSG: DB ' Cannot change built-in commands.',CR,LF,0 CSEG ; } DB1: ; for ( ; *ptr != (PAIR)empty ; ptr = &(*ptr)->right.list) ; ; LD HL,(PTR) CALL INDIR## LD DE,EMPTY CALL CPHL## JR Z,DB2 INC HL INC HL LD (PTR),HL JR DB1 DB2: ; *ptr = makepair(clause,empty); LD HL,(CLAUSE) LD DE,EMPTY CALL MKPAIR## EX DE,HL LD HL,(PTR) LD (HL),E INC HL LD (HL),D ; *alldbe = makepair(clause,empty); LD HL,(CLAUSE) LD DE,EMPTY CALL MKPAIR## EX DE,HL LD HL,(ALLDBE) LD (HL),E INC HL LD (HL),D ; alldbe = &((*alldbe)->right.list); DEC HL CALL INDIR## INC HL INC HL LD (ALLDBE),HL ; datbtop = hfree; LD HL,(HFREE##) LD (DBTOP##),HL ; } RET END [  illegal. Syntax error. E-Prolog ver. 2.3 (August 1, 1985) {l*"*" 2ͩH (iy !.W(x͊ :( :<2͵È͊ :) :=2!| &ͩ"͊ :)(!D:=2*͵ͩ:[ ͊:]  ( ( ( ɯɯRyͨyHyB[B[ B[OB[OB[QBͨ( ~?(>ɯ~#fo s#rnfnfnfnfututututnfnfutut#### Out of string space.!"k͊ ͊(*!͊()T])):0_͊͵͑!:" ͙͊*k:w#"k͊:" I' ͙͊*k:w#"k͊:' (Ͱ(*k:w#"k͊Ͱ ͵ *k:w#"k*k6*O"m*m ̀ *m0 *m####"o*m##"o^#VSm!B *os#r#:08:0ɯ:^͊:^@2:_ʕ-ʕ?ʕ0ڗ:ڕAڗ[ڕaڗ{ڕ×*Qs#r#s#r#s#r#!~# "Q[B8!qD Out of heap space." c"[ B0"B( B(*"" c"[ BB **"* [ B!dU|( * d" !D".S0* "2####" ͬ*2[.[0":S4* " ͬ+*:2*4@c"8*:":('[8"6͟(*L9":"8*:":('[8"6͟(*L9":"8*:9"<* ####" U*<\[ ͬS@">(%*@[ B0[>B*> y*>* "B" *B* " ͬ0 Cannot change built-in commands. SP"R͑(!T.*RB(##"R*P*Rs#r*P*Ns#r+##"N* "͟(B("S[B( *"*"S"S(#["͟ *** ["͟*(n*[B(^0**""*B(,*-**KB-"*[*[>*[K-**[***y(_*(*[K-**y(5*[*[(*(*[K-*y [B2ʇ3w+ Retry on LESS. ) !9" S (2* " ͟(!* s#r* * s#r* y(A" (#* " " (* " * s#r* !!|!! n !| ʹʹ:=n < 2t #*+"!!~(#fB !f"fn ʹn ʹʹu n t " S !  " Bt !  " Bt * ͑(* ͑(* [ Bn t * ͨ(* ͨ(* * ̀n t !͞* ͟((a* * " y(! ͫ* ! ë͋ :=n : !͙ ͋ :=n < 2t 2!"n " S ͈" S ͊:o&" !͞* * [ n * Dt " S 2ͩ ʹʹ: !͙u  :=$D"9B H*9B(AGDB !͞~É(H!9B \$D͞9cNf(~N\ÉHÀNB Q"9NB 6[7B : : !;ͫ(*9GN[9 NN\ÀGB HÀ2B*7f"@͟(.> a ͫ!Cͫ*@z>2BZ*@"@:B Z!Gͫ͊ :Y(y(>"M͟(  ͫ*M!" ͟(!O.!" " @~{_͋9{_{:F:*@*?:?:*@%99i zi W{_*@*@99BK*@"@x*;+w ;"@4;ô9*&=*@99i zi W{_*@> "S2!#6! 6 ! ͨ(bB(X>2͙! ͨ(?B :@2! 6 oB ! ͨ(͙: E:2:(o&!ͫ > a2!~#"_6 #6:!"ȯ2*B(~(( 2#"ɯ2!Í*+":w 8L!="=*=6!=~G#^#VͣE !<O*R2= END B " DISK WRITE ERROR. | 'd Shf͑ [h~#"jSl2!#6! 6 !jl ͨ(rB(h>2BY>2͙!jl ͨ(?B :@2! 6 oB !jl ͨ(͙!nͫ_:(= !*ffB ͓!s#"f!qD~#a:=>2*ffB(6#͓"S*B($*["͟ "*"*͑ͨ( ë>(a*B**["S"(4*B('*["͟ *"*"*f $!ͫ**["""*B(> a3>)a| >0a _ WR8R8<0a> _ W IMPLEMENTATION ERROR.:(<(ʹ2ͫ.!oS[Sr8t "S.y /w: APPEND CLOSECON CREATE FAIL LESS LIST LOADNULL OPENPRO READ ,READCHAR< READLISTO CSAVE WRITE7WRITECHAR Cannot allocate space.22!"L!L"N!SR!0ͫ!U*R[RU| !SD*O["*[R" *"  Cannot allocate space.22!"L!L"N! E-PROLOG -------- (ver. 2.3 -- August 1, 1985) This is a small Prolog system for CP/M-80 Z-80 computer. The current code occupies less than 6K bytes of space, so that there is a lot of space left over for the database and for the VERY deep subroutine stack. The executable version of E-Prolog is called EPRO.COM. This version was prepared under CP/M 2.2, but if you do not use APPEND, it should run under CP/M 1.4. The source code is intended for Microsoft's Macro-80 compiler. The source files are: EPRO.Z80, CLASS.Z80, SYMB.Z80, HEAP.Z80, DATBADD.Z80, UNIFY.Z80, CMD.Z80, PROVE.Z80, INPUT.Z80, OUTPUT.Z80, ERROR.Z80, ASSEM.Z80, INIT.Z80 . Some E-Prolog sample programs are included on the disk, also: STD.PRO some standard connectives SAMPLE.PRO a sample database - see below SCIAM.PRO a logic puzzle from Scientific American VALGOL.PRO a compiler written in Prolog (from May, 1985, Dr. Dobb's Journal) --------------------------------------------------------------- EXPLANATION ----------- This DOC file DOES NOT teach Prolog. See the appropriate books for that. 1. W. F. Clocksin & C. S. Mellish, Programming in Prolog, Springer-Verlag, 1981. 2. K. L. Clark and F. G. McCabe, Micro-PROLOG: Programming in Logic, Prentice-Hall, 1984. E-Prolog does not have the special features of the large systems described in these books, but neither does it have the large price tags of those systems. Here are the peculiarities of E-Prolog. (Mostly things were done this way to save space.) TOKENS are the smallest elements recognized by the language. They are used to identify individuals (constants) and relations (predicate symbols), and some of them have special uses as well. The most common tokens are strings consisting of letters (upper and lower case are different), digits, and the characters '-', '_' , and '?' . Most other printable characters usually represent tokens of a single character. Exceptions to this can be enforced by enclosing a string in quotation marks (either " or ' ). Inside such a string, control characters are indicated as usual with the escape character '^'. Text enclosed in square brackets [ and ] is a comment, and is ignored. Space, Tab, Carriage return, Linefeed and comments separate one token from the next. Examples: Here there is one token on each line: ken Ken / "A long string with spaces." But this line has eight tokens: How-to-tell.where one/token[really]ends. They are: How-to-tell . where one / token ends . VARIABLES are represented as strings beginning with the character '?'. Examples: ?X ?who ?mother-in-law LISTS are represented by placing the items of the list between a pair of parentheses. Examples: (A B C D E) a list with 5 items () the empty list (A (B C D E)) a list with 2 items (LOAD A:SAMPLE.PRO) a list with 6 items (LOAD A : SAMPLE . PRO) the same list PAIRS are represented using the vertical '|'. Example: (A | B) Technically, lists are built from the empty list up as pairs. The list (A B C D) is (A | (B | (C| (D | ())))) . Example: if (?X | ?Y) matches (first second third fourth) then ?X must be first and ?Y must be (second third fourth) This idea is extended to work with longer lists, too: If (?a ?b ?c | ?d) matches (alpha beta gamma) then ?a is alpha, ?b is beta, ?c is gamma, and ?d is (). NUMBERS are not really implemented in E-Prolog. Numbers from 0 to about 5500 can be used. They can be compared using LESS, but no arithmetic has been implemented. ATOMS are what Prolog asserions and rules are built from. They are lists: the first item in the list is the "predicate symbol" or "relation name", the others are the arguments. Example: (father jack ken) means that the relation "father" holds between the individuals "jack" and "ken". In Clocksin & Mellish, this is written: father(jack,ken). It might have the interpretation (if we choose) that Jack is the father of Ken. CLAUSES are lists of atoms. This is how Prolog rules are stored in the database. The first atom is the conclusion, and the others are the conditions. Example: ((grandparent ?A ?C) (parent ?A ?B) (parent ?B ?C)) This clause represents the Prolog rule: A is the grandparent of C if A is the parent of B and B is the parent of C. In Clocksin & Mellish it would be: grandparent(A,C) :- parent(A,B) , parent(B,C). --------------------------------------------------------------- BUILT-IN PREDICATES ------------------- Certain predicates are built into E-Prolog. These have to be special so that they can have "side effects", such as printing out information to the outside world. Here are brief descriptions of these special predicates. LESS This compares two strings (or two numbers). Examples: (LESS help hurt) succeeds (LESS help help) fails LIST This sends the entire database to the console (or other current output device). Example: (LIST) READ This is used to input a token from the console (or the current input file). Example: (READ ?X) will read one token and unify it with ?X. READLIST This is used to input a list from the console (or the current input file). Examples: (READ ?X), where ?X is a variable that does not have a current value, will read one item from the console, and assign it to ?X. But (READ (?X A : C)) will read one item from the console, and attempt to unify it with the list (?X A : C). Try it! READCHAR This inputs one character, which is treated internally as a number between 0 and 255. Example: (READCHAR ?x) WRITE This writes items to the console (or other output device). Examples: (WRITE ?X ?Y ?Z) (WRITE "Now is the time.") (WRITE "The father's name is " ?father ".^M^J") WRITECHAR This outputs as one character a number between 0 and 255. This number presumably was obtained using a READCHAR. Example: (WRITECHAR ?x) OPEN This opens a file for input. After an OPEN atom is verified, input is taken from that file instead of from the console. Any remaining input in the previous input file (or the input line from the console) is ignored. When EOF is reached, input reverts to the console. The input device may also be altered by a LOAD or OPEN command in the file. This command requires a file name. The name may be CON for the console. Examples: (OPEN A:FILE.INP) (OPEN CON) CREATE This opens a previously nonexistent file for output. (If the file already exists, then it will be deleted, and a new file opened with the same name.) After a CREATE atom is verified, output goes to the file instead of to the console. To end output to the file, use CLOSE, or CREATE another file. This command requires a file name, as in OPEN. The file name may be CON for the console, or NULL for Never-Never Land. Examples: (CREATE A:FILE.OUT) (CREATE | ?file) the variable should be matched before this is attempted APPEND This is used to open an existing file for output. It is like CREATE, except that output starts at the end of the existing information. Requires a file name. Examples: (APPEND A:SAMPLE.PRO) (APPEND FAM) no filetype CLOSE This closes the output file. Further output will go to the console. Output sent to a file that is never closed will probably be lost. Example: (CLOSE) SAVE This writes the current database to a file. Requires a file name. The default file type is 'PRO'. Example: (SAVE A) is roughly equivalent to the following commands, in order: (CREATE A.PRO) (LIST) (CLOSE). LOAD This loads input from a given file. Usually used to add to the database. Use this only at command level, not from a program. (Use OPEN to get commands from a file.) Requires a file name. When EOF is reached, the input device reverts to the console. Loading may also be prematurely terminated with another LOAD or OPEN command in the file. Requires a file name. The file type 'PRO' is the default. / This is the CUT. It prohibits backtracking of the current predicate past the point it marks. See example below. --------------------------------------------------------------- SAMPLE SESSION -------------- In the sample session below, the comments are written flush left, and the actual input and output is indented. We will use the sample database SAMPLE.PRO. If you have a working E-Prolog, follow along yourself. Begin from CP/M. The tail of the command line is the first input to E-Prolog. (Remember that CP/M converts the command line to upper case.) A> EPRO (LOAD SAMPLE) E-Prolog ver. 2.3 (August 1, 1985) > This is the E-Prolog prompt. It is only shown when the input device is the console. To ask E-Prolog to attempt to prove a statement, just enter the atom. > (father jack ken) Yes. > The statement was proved. (The 'Yes' response is shown only when the input and output devices are both the console.) > (mother jack ken) > If the statement was not proved, no response is printed. Now let's try one with variables. > (father jack ?who) Yes. ?who = ken One solution was found. E-Prolog asks whether to try for other solutions: More?> y Yes. ?who = karen More?> y > The commands are entered just like other atoms. > (LIST) ((father jack ken)) ((father jack karen)) ((grandparent ?grandparent ?grandchild) (parent ?grandparent ?parent) (parent ?parent ?grandchild)) ((mother el ken)) ((mother cele jack)) ((parent ?parent ?child) (mother ?parent ?child)) ((parent ?parent ?child) (father ?parent ?child)) Yes. > Let's try something more difficult to solve: > (grandparent ?001 ?002) Yes. ?001 = cele ?002 = ken More?> y Yes. ?001 = cele ?002 = karen More?> y > Here is another variation. Try this one on your expensive Prolog system! > (?relation jack karen) Yes. ?relation = father More?> y Yes. ?relation = parent More?> y > To add to the database, enter a clause in the form of a list of atoms. > ((father carl jack)) > (LIST) ((father jack ken)) ((father jack karen)) ((father carl jack)) ((grandparent ?grandparent ?grandchild) (parent ?grandparent ?parent) (parent ?parent ?grandchild)) ((mother el ken)) ((mother cele jack)) ((parent ?parent ?child) (mother ?parent ?child)) ((parent ?parent ?child) (father ?parent ?child)) Yes. > Now let's add a rule to the database. (The prompt '1>' indicates that there is one open parenthesis that has not been closed.) > ((z ?x ?y) 1> (father jack ?x) 1> (father jack ?y) 1> ) This one illustrates backtracking. > (z | ?u) ?u = (ken ken) More?> y Yes. ?u = (ken karen) More?> y Yes. ?u = (karen ken) More?> y Yes. ?u = (karen karen) More?> y > Here is one with a cut to prohibit backtracking. > ((zz ?x ?y) (father jack ?x) (/) (father jack ?y)) > (zz | ?v) Yes. ?v = (ken ken) More?> y Yes. ?v = (ken karen) More?> y > Isn't the next one interesting: > ?x Yes. ?x = (father jack ken) More?> y Yes. ?x = (father jack karen) More?> y Yes. ?x = (grandparent cele ken) More?> y Yes. ?x = (grandparent cele karen) More?> y Yes. ?x = (grandparent carl ken) More?> n > If we didn't cut it off, it would go ahead and list all the facts that can be deduced from these rules! Some standard connectives are in the file STD.PRO. (Currently EQ , AND , OR , NOT, IF, IFF .) > (LOAD STD) > (EQ 3 6) > (EQ 3 3) Yes. > (AND (parent ?x ?y)(parent ?y ?z)) Yes. ?x = cele ?y = jack ?z = ken More?> y Yes. ?x = cele ?y = jack ?z = karen More?> n > ^C This is the way to leave E-Prolog. Don't forget to (CLOSE) first if you have been writing to the disk. --------------------------------------------------------------- G. A. Edgar CompuServe 70715,1324 107 W. Dodridge St. Columbus, OH 43202  ; EPRO.Z80 ; ******** E-Prolog ****** ; G. A. Edgar ; 107 W. Dodridge St., Columbus, OH 43202 ; CompuServe 70715,1324 ; Not copyrighted, but if you improve it, how about ; at least letting me know? .Z80 SIGNON:: DB 'E-Prolog ver. 2.3' DB ' (August 1, 1985)',13,10,0 SYMBSZ EQU 3000 ; symbol table size STACKSZ EQU 1500 ; stack size .COMMENT % versions 1.0 April 2, 1985 For Macro-80, Z-80, CP/M 2.2 Based on PIL : Prolog in Lisp, by Ken Kahn, Par Emanuelson, Martin Nilsson. 1.1 April 10, 1985 Packing of node space Rewrite VALUE 1.2 April 19, 1985 Rearrange database (version 1.2 released) 1.3 May 3, 1985 bug fixes 2.0 May 19, 1985 Rewritten, mostly in C 2.1 June 1, 1985 Back into M80, Z-80, CP/M 2.2 July 5, 1985 line-feed following BDOS 10 call fixes for UNIFY, PROVE 2.3 August 1, 1985 version for SIG/M Most of the C language source has been left in the code as comments. The source files are: EPRO.Z80, CLASS.Z80, SYMB.Z80, HEAP.Z80, DATBADD.Z80, UNIFY.Z80, CMD.Z80, PROVE.Z80, INPUT.Z80, OUTPUT.Z80, ERROR.Z80, ASSEM.Z80, INIT.Z80 . The documentation file is EPRO.DOC . /* types */ typedef unsigned NUMBER; typedef int BOOLEAN; typedef struct XSYMBOL { char * addr; struct XSYMBOL * lptr; struct XSYMBOL * rptr; char string[1]; } SYMBOL; typedef SYMBOL * VARIABLE; typedef struct XNODE * PAIR; typedef union { PAIR list; SYMBOL * symbol; NUMBER number; } EXPR; typedef struct XNODE { EXPR left; EXPR right; } NODE; typedef union XSUBVAL { struct XSUBST * val; struct XSEXPR * assgn; } SUBVAL; typedef struct XSUBST { VARIABLE vname; SUBVAL back; SUBVAL forw; } SUBST; typedef SUBST * LSUBST; typedef struct XSEXPR { EXPR sexp; SUBVAL back; LSUBST slist; } SEXPR; typedef struct { struct XALPHASTATE * pred; EXPR assertion; SUBST subst[1]; } BETASTATE; typedef struct XALPHASTATE { BETASTATE * pred; /* tree pred */ PAIR goal; PAIR datb; BETASTATE * back; /* linear pred */ } ALPHASTATE; END OF COMMENT % FALSE EQU 0 TRUE EQU 1 EMPTY EQU -1 ; empty list UNDEF EQU -2 ; undefined pointer FROZEN EQU -3 ; frozen variable HT EQU 9 LF EQU 10 CR EQU 13 CTLZ EQU 26 CPM EQU 0000H BDOS EQU CPM+0005H CDMA EQU CPM+0080H TPA EQU CPM+0100H ; -------------- global variables -------------------- DSEG ;unsigned symbs = SYMBSZ; SYMBS:: DW SYMBSZ ;unsigned stacks = STACKSZ; STACKS:: DW STACKSZ ;int opar; /* no. of open parentheses */ OPAR:: DS 1 ;char * stop; /* top of symbol table */ ;#define hbot stop /* bottom of heap */ HBOT:: STOP:: DS 2 ;char * hfree; /* free space in heap */ HFREE:: DS 2 ;char * htop; /* top of heap */ HTOP:: DS 2 ;char * datbtop; /* top of database */ DBTOP:: DS 2 CSEG ;main() MAIN:: LD SP,(6) ; { ; static EXPR e; ; ; init(); CALL INIT## ; datbtop = hbot; LD HL,(HBOT) LD (DBTOP),HL ; while (1) EP1: ; { ; hfree = datbtop; LD HL,(DBTOP) LD (HFREE),HL ; opar = 0; XOR A LD (OPAR),A ; e.list = rdg1(); CALL RDG1 ; if (atomp(e.list) || varp(e.list)) CALL ATOMP## JR NZ,EP3 CALL VARP## JR Z,EP2 ; { EP3: ; /* prove */ ; prove(e.list); CALL PROVE## ; continue; JR EP1 ; } EP2: ; if (!(nelistp(e.list))) CALL NELP## JR NZ,EP4 ; { ; eprint(e.list,empty); EP5: LD DE,EMPTY CALL EPRINT## ; error(" illegal.\r\n"); LD HL,EP3MSG CALL ERROR## DSEG EP3MSG: DB ' illegal.',CR,LF,0 CSEG ; continue; JR EP1 ; } EP4: ; if (clausep(e.list)) CALL CLP## JR Z,EP5 ; { ; /* add to database */ ; datbadd(e.list->left.list->left.symbol,e.list); PUSH HL CALL @LEFT## CALL @LEFT## POP DE CALL DBADD## ; continue; JR EP1 ; } ;EP5: above ; /* otherwise */ ; eprint(e.list,empty); ; error(" illegal!\r\n"); ; } ; exit(0); ; } ; READ A GOAL ; ; input: ; none ; output: ; HL -> goal [EXPR] ;EXPR ;rdg1() /* recursive */ ; { RDG1:: ; while (separp(rdchar())) ; ; RD1: CALL RDCHAR## CALL SEPARP JR NZ,RD1 ; if (character == '(') LD A,(CHR##) CP '(' JR NZ,RD2 ; { ; opar++; LD A,(OPAR) INC A LD (OPAR),A ; return rdg2(); JP RDG2 ; } RD2: ; else ; { ; unrdchar(); CALL UNRDCH## ; return gtoken(); JP GTOKEN## ; } ; } ; ;EXPR ;rdg2() RDG2: ; { ; unsigned temp; DSEG TEMP: DW 0 CSEG ; ; while (separp(rdchar())) ; ; RD3: CALL RDCHAR## CALL SEPARP JR NZ,RD3 ; if (character == ')') LD A,(CHR##) CP ')' JR NZ,RD4 ; { ; opar--; LD A,(OPAR) DEC A LD (OPAR),A ; return empty; LD HL,EMPTY RET ; } RD4: ; else if (character == '|') CP '|' JR NZ,RD5 ; { ; temp = rdg1(); CALL RDG1 ; recursion LD (TEMP),HL ; while (separp(rdchar())) ; ; RD6: CALL RDCHAR## CALL SEPARP JR NZ,RD6 ; if (!(character == ')')) LD A,(CHR##) CP ')' JR Z,RD7 ; fatal("\r\nSyntax error.\r\n"); LD HL,RD6MSG JP FATAL## DSEG RD6MSG: DB CR,LF,'Syntax error.',CR,LF,0 CSEG RD7: ; opar--; LD A,(OPAR) DEC A LD (OPAR),A ; return temp; LD HL,(TEMP) RET ; } RD5: ; else ; { ; unrdchar(); CALL UNRDCH## ; temp = rdg1(); CALL RDG1 ; recursion ; return makepair(temp,rdg2()); PUSH HL CALL RDG2 ; recursion EX DE,HL POP HL JP MKPAIR## ; } ; } ; SEPARATOR? ; ; is it a separator? also, skip comment in [...] ; input: ; none ; output: ; Z flag set = no ;BOOLEAN ;separp() SEPARP:: ; { ; switch (character) LD A,(CHR##) ; { ; case '[': CP '[' JR NZ,SE1 ; do ; rdchar(); SE2: CALL RDCHAR## LD A,(CHR##) ; while (character != ']') ; CP ']' JR NZ,SE2 JR RETT SE1: ; case ' ': CP ' ' JR Z,RETT ; case '\r': CP CR JR Z,RETT ; case '\n': CP LF JR Z,RETT ; case '\t': CP HT JR NZ,RETF ; return TRUE; RETT: OR A RET ; default: ; return FALSE; RETF: XOR A RET ; } ; } ; 16 bit compare ; ; input: ; HL , DE ; output: ; C, Z flags ; AF destroyed, others saved CPHL:: XOR A ; NC PUSH HL SBC HL,DE POP HL RET END MAIN  ; =========================================================== ;ERROR.Z80 ; error routines for E-Prolog ; May 20, 1985 .Z80 FALSE EQU 0 TRUE EQU 1 EMPTY EQU -1 UNDEF EQU -2 HT EQU 9 LF EQU 10 CR EQU 13 CTLZ EQU 26 CPM EQU 0000H BDOS EQU CPM+0005H CDMA EQU CPM+0080H TPA EQU CPM+0100H ;errmsg(s) ; char * s; ; { ; if (outfile != stdout && outfile != null) ; { ; fclose(outfile); ; } ; outfile == stdout; ; msg(s); ; } ERRMSG:: ERROR:: PUSH HL LD A,(OUTF##) OR A JR Z,ERR1 INC A JR Z,ERR1 CALL CLOSE## ERR1: XOR A LD (OUTF##),A POP HL CALL MSG## RET ;fatal(s) ; char * s; FATAL:: CALL ERROR JP CPM ;imperr() IMPERR:: LD HL,MSG1 JR FATAL DSEG MSG1: DB CR,LF,"IMPLEMENTATION ERROR.",0 CSEG END  ; =========================================================== ; HEAP.Z80 ; heap management for E-Prolog ; June 22, 1985 .Z80 FALSE EQU 0 TRUE EQU 1 EMPTY EQU -1 UNDEF EQU -2 FROZEN EQU -3 HT EQU 9 LF EQU 10 CR EQU 13 CTLZ EQU 26 CPM EQU 0000H BDOS EQU CPM+0005H CDMA EQU CPM+0080H TPA EQU CPM+0100H ;release(p) ; NODE * p; ; { ; hfree = p; ; } RLS:: LD (HFREE##),HL RET ;brls(bptr) ; /* release the stack above bptr; cancel all unifications ; at this level. */ ; BETASTATE * bptr; ; { ; SUBST * x; DSEG X: DW 0 CSEG ; BRLS:: ; for (x = bptr->subst ; x < (SUBST *)hfree ; x++) CALL YSUBST## LD (X),HL BR1: LD DE,(HFREE##) CALL CPHL## JR NC,BR2 ; if (x->back.val != UNDEF && x->back.val != FROZEN) CALL @BACK## LD DE,FROZEN CALL CPHL## JR Z,BR3 LD DE,UNDEF CALL CPHL## JR Z,BR3 ; x->back.val->forw.val = (SUBST *)UNDEF; CALL @LFORW## BR3: LD HL,(X) LD DE,6 ADD HL,DE LD (X),HL JR BR1 BR2: ; hfree = (char *)bptr; LD (HFREE##),IY ; } RET ;/* freeze this beta-state */ ;freeze(bptr) ; BETASTATE * bptr; passed in IY FREEZE:: ; { ; SUBST * x; ; for (x = bptr->subst ; x < (SUBST *)hfree ; x++) CALL YSUBST## LD (X),HL FR1: LD DE,(HFREE##) CALL CPHL## RET NC ; if (x->back == UNDEF) CALL @BACK## LD DE,UNDEF CALL CPHL## JR NZ,FR2 ; x->back == FROZEN; LD HL,(X) LD DE,FROZEN CALL @LBACK## FR2: LD HL,(X) LD DE,6 ADD HL,DE LD (X),HL JR FR1 ; } ;#define cksp() if (hfree > htop) space() CKSP: LD HL,(HFREE##) LD DE,(HTOP##) CALL CPHL## RET C ; ;space() ; { ; if (settop(100)) LD HL,100 CALL SETTOP## LD A,H OR L JR Z,SP1 ; htop += 100; LD HL,(HTOP##) LD DE,100 ADD HL,DE LD (HTOP##),HL RET ; else SP1: ; fatal("\r\nOut of heap space."); LD HL,SP1MSG JP FATAL## DSEG SP1MSG: DB CR,LF,'Out of heap space.',0 CSEG ; } ;PAIR ;makepair(x1,x2) ; /* EXPR */ int x1,x2; ; { ; PAIR temp; DSEG X1: DW 0 X2: DW 0 TEMP: DW 0 CSEG ; MKPAIR:: LD (X1),HL LD (X2),DE ; temp = hfree; LD HL,(HFREE##) LD (TEMP),HL ; hfree += 4; INC HL INC HL INC HL INC HL LD (HFREE##),HL ; cksp(); CALL CKSP ; temp->left = x1; LD HL,(TEMP) LD DE,(X1) CALL @LLEFT## ; temp->right = x2; LD DE,(X2) CALL @LRIGHT## ; return temp; RET ; } ;ALPHASTATE * in IX ;makealpha(bptr,x,bback) ; BETASTATE * bptr; in IY ; EXPR x; in HL ; char * bback; in DE ; { ; ALPHASTATE * aptr; in IX ; static SUBVAL sv; ; static LSUBST ls; ; static EXPR ex; DSEG BBACK: DW 0 SV: DW 0 LS: DW 0 EEX: DW 0 CSEG ; MKALPHA:: LD (EEX),HL LD (BBACK),DE ; aptr = (ALPHASTATE *)hfree; LD HL,(HFREE##) PUSH HL POP IX ; hfree += 8; LD DE,8 ADD HL,DE LD (HFREE##),HL ; cksp(); CALL CKSP ; aptr->pred = bptr; PUSH IY POP HL CALL XLPRED## ; aptr->goal = x; LD HL,(EEX) CALL XLGOAL## ; aptr->back = bback; LD HL,(BBACK) CALL XLBACK## ; ls = bptr->subst; CALL YSUBST## LD (LS),HL ; if (varp(ex.list = x->left.list)) LD HL,(EEX) CALL @LEFT## LD (EEX),HL CALL VARP## JR Z,MKA1 ; { ; sv.val = value(vf(ex.list,ls)); LD DE,(LS) CALL VF## CALL VALUE## LD (SV),HL ; if (substp(sv.val)) CALL SUBSTP## JR Z,MKA2 ; { ; aptr->datb = alldb; LD HL,(ALLDB##) CALL XLDATB## ; return aptr; RET ; } MKA2: ; else ; { ; ex.list = sv.assgn->sexp.list; PUSH HL CALL @EXPR## LD (EEX),HL ; ls = sv.assgn->slist; POP HL CALL @SLIST## LD (LS),HL ; } ; } MKA1: ; if (varp(ex.list = ex.list->left.list)) LD HL,(EEX) CALL @LEFT## LD (EEX),HL CALL VARP## JR Z,MKA3 ; { ; sv.val = value(vf(ex.list,ls)); LD DE,(LS) CALL VF## CALL VALUE## LD (SV),HL ; if (substp(sv.val)) CALL SUBSTP## JR Z,MKA4 ; { ; aptr->datb = alldb; LD HL,(ALLDB##) CALL XLDATB## ; return aptr; RET ; } MKA4: ; else ; { ; ex.list = sv.assgn->sexp.list; PUSH HL CALL @EXPR## LD (EEX),HL ; ls = sv.assgn->slist; POP HL CALL @SLIST## LD (LS),HL ; } ; } MKA3: ; aptr->datb = (PAIR)(ex.symbol->addr); LD HL,(EEX) CALL @ADDR## CALL XLDATB## ; return aptr; RET ; } ;BETASTATE * in IY ;mkb(aptr,lst) ; ALPHASTATE * aptr; in IX ; PAIR lst; in HL ; { ; BETASTATE * bptr; in IY ; DSEG LST: DW 0 CSEG MKBETA:: LD (LST),HL ; bptr = hfree; LD HL,(HFREE##) PUSH HL POP IY ; hfree += 4; INC HL INC HL INC HL INC HL LD (HFREE##),HL ; bptr->pred = aptr; PUSH IX POP HL CALL YLPRED## ; bptr->assertion.list = lst; LD HL,(LST) CALL YLASS## ; makelsubst(lst,hfree); LD DE,(HFREE##) CALL MKLSUBST ; cksp(); CALL CKSP ; return bptr; RET ; } ;makelsubst(lst,st) /* recursive */ ; EXPR lst; ; SUBST * st; ; { ; EXPR lstx; ; SUBST * x; DSEG LSTX: DW 0 STX: DW 0 CSEG ; MKLSUBST:: LD (STX),DE MKLR: LD (LSTX),HL ; lstx.number = lst; /* synonym */ ; if (varp(lst)) CALL VARP## JR Z,MKL1 ; { ; for (x = st ; x < (SUBST *)hfree; x++ ) LD HL,(STX) MKL2: LD DE,(HFREE##) CALL CPHL## JR NC,MKL3 ; if (lstx.symbol == x->vname) ; return; PUSH HL CALL @VNAME## LD DE,(LSTX) CALL CPHL## POP HL RET Z LD DE,6 ADD HL,DE JR MKL2 MKL3: ; makesubst(lst); LD HL,(LSTX) JP MKSUBST ; } MKL1: ; else if (nelistp(lst)) CALL NELP## RET Z ; { ; makelsubst(lstx.list->left.list,st); LD HL,(LSTX) PUSH HL CALL @LEFT## CALL MKLR ; recursion ; makelsubst(lstx.list->right.list,st); POP HL CALL @RIGHT## JP MKLR ; tail recursion ; } ; } ;SUBST * ;makesubst(var) ; VARIABLE var; ; { ; SUBST * ptr; DSEG PTR: DW 0 CSEG MKSUBST:: PUSH HL ; ; ptr = (SUBST *)hfree; LD HL,(HFREE##) LD (PTR),HL ; hfree += 6; LD DE,6 ADD HL,DE LD (HFREE##),HL ; ptr->vname = var; LD HL,(PTR) POP DE CALL @LVNAME## ; ptr->back.val = (SUBST *)UNDEF; LD DE,UNDEF CALL @LBACK## ; ptr->forw.val = (SUBST *)UNDEF; LD DE,UNDEF CALL @LFORW## ; return ptr; RET ; } ;SEXPR * ;makesexpr(se,ba,sl) ; EXPR se; ; SUBST * ba; ; LSUBST sl; ; { ; SEXPR * temp; ; MKSEXPR:: PUSH BC PUSH DE PUSH HL ; temp = (SEXPR *)hfree; LD HL,(HFREE##) PUSH HL ; hfree += 6; LD DE,6 ADD HL,DE LD (HFREE##),HL ; cksp(); CALL CKSP ; temp->sexp.list = se; POP HL POP DE CALL @LEXPR## ; temp->back.val = ba; POP DE CALL @LBACK## ; temp->slist = sl; POP DE CALL @LSLIST## ; return temp; RET ; } END  ; =========================================================== ;INIT.Z80 ; initialization for E-Prolog ; August 1, 1985 .Z80 FALSE EQU 0 TRUE EQU 1 EMPTY EQU -1 UNDEF EQU -2 DEBUG EQU FALSE HT EQU 9 LF EQU 10 CR EQU 13 CTLZ EQU 26 CPM EQU 0000H BDOS EQU CPM+0005H BDBOT EQU CPM+0006H CDMA EQU CPM+0080H TPA EQU CPM+0100H CSEG INIT:: ; infile = stdin; XOR A LD (INF##),A ; outfile = stdout; LD (OUTF##),A ; alldb = (PAIR)empty; LD HL,EMPTY LD (ALLDB##),HL ; alldbe = &alldb; LD HL,ALLDB## LD (ALLDBE##),HL ; inptr = strcpy(indma,cdma+1); LD HL,CDMA LD DE,RDBUFF##+1 LD (INP##),DE LD BC,127 LDIR CALL INIX## ; msg(SIGNON); LD HL,SIGNON## CALL MSG## ; stop = settop(0); LD HL,0 CALL SETTOP## ; stop = settop((bdosbot-stop)-stacks); EX DE,HL LD HL,(BDBOT) SBC HL,DE LD DE,(STACKS##) SBC HL,DE CALL SETTOP## ; if (stop == NULL) ; fatal("\nCannot allocate space."); LD A,H OR L JR NZ,INI1 LD HL,MSG1 JP FATAL## DSEG MSG1: DB CR,LF,"Cannot allocate space.",0 CSEG INI1: ; stop = sbot+symbs; LD HL,(SBOT##) LD DE,(SYMBS##) ADD HL,DE LD (STOP##),HL ; htop = bdosbot-stacks; LD HL,(BDBOT) LD DE,(STACKS##) SBC HL,DE LD (HTOP##),HL ; hfree = hbot; LD HL,(STOP##) LD (HFREE##),HL IF DEBUG ; msg("code:"); LD HL,MSG2 CALL MSG## ; prdec(sbot-0x100); LD HL,(SBOT##) LD DE,100H SBC HL,DE CALL PRDEC## ; msg(" symb:"); LD HL,MSG3 CALL MSG## ; prdec(stop-sbot); LD HL,(STOP##) LD DE,(SBOT##) SBC HL,DE CALL PRDEC## ; msg(" heap:"); LD HL,MSG4 CALL MSG## ; prdec(htop-hbot); LD HL,(HTOP##) LD DE,(STOP##) SBC HL,DE CALL PRDEC## ; msg(" stack:"); LD HL,MSG5 CALL MSG## ; prdec(bdosbot-htop); LD HL,(BDBOT) LD DE,(HTOP##) SBC HL,DE CALL PRDEC## ; chrout('\n'); CALL CRLF## DSEG MSG2: DB "code:",0 MSG3: DB " symb:",0 MSG4: DB " heap:",0 MSG5: DB " stack:",0 CSEG ENDIF RET END  ; =========================================================== ;INPUT.Z80 ; input routines for E-Prolog ; June 19, 1985 .Z80 FALSE EQU 0 TRUE EQU 1 EMPTY EQU -1 UNDEF EQU -2 CTLC EQU 3 HT EQU 9 LF EQU 10 CR EQU 13 CTLZ EQU 26 CPM EQU 0000H BDOS EQU CPM+0005H CDMA EQU CPM+0080H TPA EQU CPM+0100H ; compare with given value ; ?CPHL MACRO ?VALUE PUSH DE LD DE,?VALUE CALL CPHL## POP DE ENDM DSEG ;int character; /* input character */ CHR:: DB ' ' ; input file: 0 = console, 1 = disk INF:: DB 0 ; file control block for input file INFCB:: DB 0 DB ' ' DB ' ' DB 0,0,0,0 DS 20 ; buffer for input RDBUFF:: DB 128,0 INDMA:: DB 0 DS 127 INE:: INP:: DW INDMA CSEG ; fill with one character ; ; all registers destroyed ?FILL MACRO ?ADDR,?COUNT,?VAL LD HL,?ADDR PUSH HL POP DE INC DE LD BC,?COUNT-1 LD (HL),?VAL LDIR ENDM ; copy string ; ; input: ; HL -> source ; all registers destroyed ?COPY MACRO ?ADDR LD DE,?ADDR CALL COPY## ENDM ; create FCB for input file. ; ; input: ; HL = list (rest of atom) ; DE = lsub (substitutions for HL) DSEG PEXP: DW 0 PLSUB: DW 0 CSEG DOIN:: LD (PEXP),HL LD (PLSUB),DE XOR A LD (INF),A ?FILL INFCB,36,0 ?FILL INFCB+1,11,' ' DOIN1: LD HL,PEXP LD DE,PLSUB CALL VNEXT## CALL SYMBP## JR Z,DOIN3 ?CPHL ACON## JR Z,DOIN3 LD A,1 LD (INF),A ?COPY INFCB+1 LD HL,PEXP LD DE,PLSUB CALL VNEXT## CALL SYMBP## JR Z,DOIN3 ?CPHL ACOLON## JR NZ,DOIN2 LD A,(INFCB+1) SUB 'A'-1 LD (INFCB),A ?FILL INFCB+1,11,' ' JR DOIN1 DOIN2: ?CPHL ADOT## JR NZ,DOIN3 LD HL,PEXP LD DE,PLSUB CALL VNEXT## CALL SYMBP## JR Z,DOIN3 ?COPY INFCB+9 DOIN3: RET ; read into buffer ; ; abort program upon reading ^C ; output: ; console - line read (CR, 0 terminated) in RDBUFF ; disk - 128 byte block in RDBUFF ; all registers destroyed RDBUF:: LD A,(INF) ; input device OR A JR NZ,RDF RDF1: LD A,(OUTF##) ; current output device PUSH AF XOR A ; prompt to the conole LD (OUTF##),A LD A,(OPAR##) ; number of open parentheses OR A JR Z,RDB3 LD L,A LD H,0 CALL PRDEC## RDB3: LD HL,PRMSG DSEG PRMSG: DB '> ',0 CSEG CALL MSG## LD DE,RDBUFF LD C,10 ; read console buffer CALL BDOS LD A,LF ; standard BDOS doesn't echo CALL CHROUT## ; the line feed (DRI bug) POP AF ; restore output device LD (OUTF##),A INIX:: LD HL,RDBUFF+1 LD A,(HL) ; count INC HL LD (INP),HL ; pointer LD E,A LD D,0 ADD HL,DE ; end LD (HL),CR INC HL LD (HL),0 LD A,(INDMA) CP CTLC JP Z,CPM RET RDF: LD DE,INDMA LD C,26 ; set DMA CALL BDOS LD DE,INFCB LD C,20 ; read sequential CALL BDOS LD HL,INDMA LD (INP),HL ; pointer OR A ; successful read? RET Z ; yes, return XOR A ; no data (EOF) LD (INF),A ; revert to console JR RDF1 ; read character ; ; output: ; CHR = character RDCHAR:: PUSH BC PUSH DE PUSH HL RDB0: LD HL,(INP) LD DE,INE CALL CPHL## JR Z,RDB2 LD A,(HL) OR A JR Z,RDB1 CP 1AH JR Z,RDB1 LD (CHR),A INC HL LD (INP),HL POP HL POP DE POP BC RET RDB1: XOR A ; on EOF, input device .. LD (INF),A ; .. reverts to console RDB2: CALL RDBUF JP RDB0 ; un-read character UNRDCH:: LD HL,(INP) DEC HL LD (INP),HL LD A,(CHR) LD (HL),A RET END  ; =========================================================== ;OUTPUT.Z80 ; output routines for E-Prolog ; May 24, 1985 .Z80 FALSE EQU 0 TRUE EQU 1 EMPTY EQU -1 UNDEF EQU -2 HT EQU 9 LF EQU 10 CR EQU 13 CTLZ EQU 26 CPM EQU 0000H BDOS EQU CPM+0005H CDMA EQU CPM+0080H TPA EQU CPM+0100H ; compare with given value ; ?CPHL MACRO ?VALUE PUSH DE LD DE,?VALUE CALL CPHL## POP DE ENDM DSEG ; output file: 0 = console, 1 = disk, -1 = null OUTF:: DB 0 ; file control block for output file OUTFCB:: DB 0 DB ' ' DB ' ' DB 0,0,0,0 DS 20 ; buffer for output file OUTDMA:: DS 128 OUTE:: ; pointer for output file OUTP:: DW OUTDMA CSEG ; fill with one character ; ; all registers destroyed ?FILL MACRO ?ADDR,?COUNT,?VAL LD HL,?ADDR PUSH HL POP DE INC DE LD BC,?COUNT-1 LD (HL),?VAL LDIR ENDM ; copy string ; ; input: ; HL -> source ; all registers destroyed ?COPY MACRO ?ADDR LD DE,?ADDR CALL COPY ENDM ; copy string ; ; input: ; HL -> source (string terminated by 0, which is ; not copied) ; DE -> destination ; all registers destroyed DSEG DEST: DW 0 CSEG COPY:: LD (DEST),DE CALL LISTP## RET NZ CALL NUMBP## RET NZ CALL @STR## LD DE,(DEST) COPY1: LD A,(HL) OR A RET Z LD (DE),A INC HL INC DE JR COPY1 ; create FCB for output file. ; ; input: ; HL = list (rest of atom) ; DE = lsub (substitutions for HL) DSEG PEXP: DW 0 PLSUB: DW 0 CSEG DOOUT:: LD (PEXP),HL LD (PLSUB),DE XOR A LD (OUTF),A ?FILL OUTFCB,36,0 ?FILL OUTFCB+1,11,' ' DOOUT1: LD HL,PEXP LD DE,PLSUB CALL VNEXT## CALL SYMBP## JR Z,DOOUT3 ?CPHL ACON## JR Z,DOOUT3 LD A,-1 LD (OUTF),A ?CPHL ANULL## JP Z,DOOUT3 LD A,1 LD (OUTF),A ?COPY OUTFCB+1 LD HL,PEXP LD DE,PLSUB CALL VNEXT## CALL SYMBP## JR Z,DOOUT3 ?CPHL ACOLON## JR NZ,DOOUT2 LD A,(OUTFCB+1) SUB 'A'-1 LD (OUTFCB),A ?FILL OUTFCB+1,11,' ' JR DOOUT1 DOOUT2: ?CPHL ADOT## JR NZ,DOOUT3 LD HL,PEXP LD DE,PLSUB CALL VNEXT## CALL SYMBP## JR Z,DOOUT3 ?COPY OUTFCB+9 DOOUT3: RET CRLF:: LD HL,CRLFX CALL MSG RET DSEG CRLFX: DB CR,LF,0 CSEG ; character out ; ; input: ; character in A ; saves registers, except AF CHROUT:: PUSH BC PUSH DE PUSH HL LD E,A LD A,(OUTF) ; output device OR A JR Z,CHRO1 ; console DEC A JR NZ,CHROE ; null LD HL,(OUTP) ; disk file PUSH DE LD DE,OUTE CALL CPHL## POP DE JR NZ,CHRO2 PUSH DE ; E = character CALL FLUSH ; flush buffer POP DE ; E = character LD HL,OUTDMA CHRO2: LD (HL),E INC HL LD (OUTP),HL JR CHROE CHRO1: LD C,2 ; console write CALL BDOS CHROE: POP HL POP DE POP BC RET ; flush output file buffer FLUSH:: LD DE,OUTDMA LD C,26 ; set DMA CALL BDOS LD DE,OUTFCB LD C,21 ; write sequential CALL BDOS OR A RET Z LD HL,DSKERR JP FATAL## DSEG DSKERR: DB CR,LF,'DISK WRITE ERROR.',0 CSEG ;msg(s) ; char * s; ; { ; register char c; ; while(c = *s++) ; chrout(c); ; } MSG:: LD A,(HL) INC HL OR A RET Z CALL CHROUT JR MSG ; close existing output device CLOSE:: LD A,(OUTF) ; output device DEC A LD A,0 LD (OUTF),A ; revert to console RET NZ LD HL,(OUTP) CLOSE0: ?CPHL OUTE JR Z,CLOSE1 LD (HL),CTLZ ; fill with ^Z INC HL JR CLOSE0 CLOSE1: CALL FLUSH LD DE,OUTFCB LD C,16 ; close file CALL BDOS RET ;eprint(ex,ls) /* recursive */ ; EXPR ex; ; LSUBST ls; DSEG EXP: DW 0 LSU: DW 0 ; { ; EXPR e; ; SUBVAL sv; SV: DW 0 CSEG EPRINT:: ; LD (EXP),HL LD (LSU),DE ; e.list = ex; /* synonym */ ; if (varp(ex) && ls != (LSUBST)empty) CALL VARP JP Z,EP1 LD HL,(LSU) ?CPHL EMPTY JR Z,EP1 ; { ; sv.val = value(vf(ex,ls)); LD HL,(EXP) LD DE,(LSU) CALL VF## CALL VALUE## LD (SV),HL ; if (substp(sv.val)) CALL SUBSTP## JR NZ,EP1 ; ; ; else ; { ; ex = e.list = sv.assgn->sexp.list; CALL @EXPR## LD (EXP),HL ; ls = sv.assgn->slist; LD HL,(SV) CALL @SLIST## LD (LSU),HL ; } ; } EP1: ; if (numbp(ex)) ; return prdec(ex); LD HL,(EXP) CALL NUMBP## JP NZ,PRDEC ; if (symbp(ex)) ; return msg(e.symbol->string); CALL SYMBP## JR Z,EP2 CALL @STR## JP MSG EP2: ; chrout('('); LD A,'(' CALL CHROUT ; while (ex != (PAIR)empty) EP3: LD HL,(EXP) ?CPHL EMPTY JP Z,EP4 ; { ; eprint(ex->left.list,ls); LD HL,(SV) PUSH HL LD HL,(EXP) PUSH HL CALL @LEFT## LD DE,(LSU) PUSH DE CALL EPRINT ; recursion POP HL LD (LSU),HL POP HL POP DE LD (SV),DE ; ex = e.list = ex->right.list; CALL @RIGHT## LD (EXP),HL ; if (varp(ex) && ls != (LSUBST)empty) CALL VARP## JR Z,EP5 LD HL,(LSU) ?CPHL EMPTY JR Z,EP5 ; { ; sv.val = value(vf(ex,ls)); LD HL,(EXP) LD DE,(LSU) CALL VF## CALL VALUE## LD (SV),HL ; if (substp(sv.val)) ; ; CALL SUBSTP JR NZ,EP5 ; else ; { ; ex = e.list = sv.assgn->sexp.list; LD HL,(SV) CALL @EXPR## LD (EXP),HL ; ls = sv.assgn->slist; LD HL,(SV) CALL @SLIST LD (LSU),HL ; } ; } EP5: ; if (! listp(ex)) ; { LD HL,(EXP) CALL LISTP JR NZ,EP6 ; msg(" | "); LD HL,EPM DSEG EPM: DB ' | ',0 CSEG CALL MSG ; eprint(ex,ls); LD HL,(SV) PUSH HL LD HL,(EXP) PUSH HL LD DE,(LSU) PUSH DE CALL EPRINT ; recursion POP HL LD (LSU),HL POP HL LD (EXP),HL POP HL LD (SV),HL ; break; JR EP4 ; } EP6: ; if (ex != (PAIR)empty) ; chrout(' '); LD HL,(EXP) ?CPHL EMPTY JR Z,EP8 LD A,' ' CALL CHROUT ; } EP8: JP EP3 EP4: ; return chrout(')'); LD A,')' JP CHROUT ; } ; print decimal ; ; input: ; HL = number ; side effect: ; print out in decimal ; all registers destroyed PRDEC:: LD A,H OR L JR NZ,PRD1 LD A,'0' JP CHROUT PRD1: LD BC,DD1 PRD2: LD A,(BC) LD E,A INC BC LD A,(BC) LD D,A INC BC PUSH HL XOR A SBC HL,DE POP HL JR C,PRD2 PRDL: XOR A PRD3: SBC HL,DE JR C,PRD4 INC A JR PRD3 PRD4: ADD HL,DE ADD A,'0' CALL CHROUT LD A,1 CP E RET Z LD A,(BC) LD E,A INC BC LD A,(BC) LD D,A INC BC JR PRDL DSEG DD1: DW 10000 DW 1000 DW 100 DW 10 DW 1 CSEG END .begin .integer x ; 0 =: x ; .until x .= 15 .do .begin edit ( 1 + 14*x - x*x , '+' ) ; print ; x + 1 =: x .end .end  ; =========================================================== ; PROVE.Z80 ; prove routine for E-Prolog ; June 22, 1985 .Z80 FALSE EQU 0 TRUE EQU 1 EMPTY EQU -1 UNDEF EQU -2 FROZEN EQU -3 DEBUG EQU FALSE HT EQU 9 LF EQU 10 CR EQU 13 CTLZ EQU 26 CPM EQU 0000H BDOS EQU CPM+0005H CDMA EQU CPM+0080H TPA EQU CPM+0100H ;BETASTATE * prbase; DSEG PRBASE: DW 0 CSEG ; ;prove(glist) ;/* This routine is iterative rather than recursive ; in order to use as little heap space as possible. */ ; PAIR glist; /* list of goals */ in HL ; { ; ALPHASTATE * ast; in IX ; static BETASTATE * bst; in IY ; static BETASTATE * bbot; ; static int x; DSEG BBOT: DW 0 CSEG ; PROVE:: ; bst = prbase = makebeta(empty,listone(glist)); ;#define listone(x) makepair((x),empty) LD DE,EMPTY CALL MKPAIR## LD IX,EMPTY CALL MKBETA## LD (PRBASE),IY ; freeze(bst); CALL FREEZE## ; goto bstart; JP BSTART ; ;/*==========*/ ; astart: /* start an alpha state here */ ;/*==========*/ ASTART: ;#ifdef DEBUG IF DEBUG ; printf("\nALPHA %04x: ",ast); LD HL,AS1MSG CALL MSG## DSEG AS1MSG: DB CR,LF,'ALPHA ',0 CSEG PUSH IX POP HL CALL PRHEX LD A,' ' CALL CHROUT## ; eprint(ast->goal->left.list,ast->pred->subst); CALL XPRED## CALL @SUBST## PUSH HL CALL XGOAL## CALL @LEFT## POP DE CALL EPRINT## ;#endif ENDIF ; ;/*==========*/ ; arpt: /* repeat this alpha state */ ;/*==========*/ ARPT: ; if (numbp(ast->datb)) CALL XDATB## CALL NUMBP## JP Z,AR1 ; { ; /* built-in command */ ; bst = (BETASTATE *)empty; LD IY,EMPTY ; if (x = (*((BOOLEAN (*)())(ast->datb))) ; (ast->goal->left.list->right.list,ast, ; ast->pred->subst,&bst)) CALL XPRED## CALL @SUBST## PUSH HL ; ast->pred->subst CALL XGOAL## POP DE CALL V@LEFT CALL V@RIGHT PUSH HL ; ast->goal->left.list->right.list PUSH DE CALL XDATB## ; ast->datb LD (ADDR+1),HL POP DE POP HL ADDR: CALL 0 ; address filled in here JR Z,AR2 ; { ; if (x == EMPTY) LD DE,EMPTY CALL CPHL## JR NZ,AR4 ; { ; /* CUT */ ; bst = ast->back; CALL XBACK## PUSH HL POP IY ; release(ast); PUSH IX POP HL CALL RLS## ; ast = (bbot = (ast->pred))->pred; CALL XPRED## LD (BBOT),HL CALL @PRED## PUSH HL POP IX ; if (ast == (ALPHASTATE *)empty) LD DE,EMPTY CALL CPHL## JR NZ,AR5X ; return FALSE; RETF: XOR A RET ; *** release from here (bst) back to there (bbot) AR5X: CALL BRLS## LD HL,(BBOT) PUSH IY POP DE CALL CPHL## JR Z,AR5 CALL YPRED## CALL RLS## CALL @XBACK## PUSH HL POP IY JR AR5X ;AR5: combined with the other case, below ; AR4: ; /* A fake beta to hold temporary data for unifies */ ; if (bst == (BETASTATE *)empty) PUSH IY POP HL LD DE,EMPTY CALL CPHL## JR NZ,AR9 ; bst = makebeta(ast,empty); LD HL,EMPTY CALL MKBETA## AR9: ; freeze(bst); CALL FREEZE## ; goto bstart; JP BSTART ; } AR2: ; if (bst != (BETASTATE *)empty) PUSH IY POP HL LD DE,EMPTY JR Z,AR6 ; release(bst); CALL BRLS## ; ? RLS ? AR6: ; ast->datb = empty; /* failure */ LD HL,EMPTY CALL XLDATB## ; } AR1: ; if (ast->datb == (PAIR)empty) CALL XDATB## LD DE,EMPTY CALL CPHL## JR NZ,AR7 ; { AR5: ; /* no (more) facts in the database - FAIL*/ ; /* roll back pointer in tree-predecessor */ ; ast->pred->assertion.list = ast->goal; CALL XGOAL## PUSH HL CALL XPRED## PUSH HL POP IY POP HL CALL YLASS## ; bst = ast->back; CALL XBACK## PUSH HL POP IY ; release(ast); PUSH IX POP HL CALL RLS## ; goto bafail; JP BAFAIL ; } AR7: ; bst = makebeta(ast,ast->datb->left.list); CALL XDATB## CALL @LEFT## CALL MKBETA## ; ast->datb = ast->datb->right.list; CALL XDATB## CALL @RIGHT## CALL XLDATB## ; if (unify(ast->goal->left.list,ast->pred->subst, ; bst->assertion.list->left.list,bst->subst)) CALL YSUBST## PUSH HL CALL YASS## CALL @LEFT## POP DE EXX CALL XPRED## CALL @SUBST## PUSH HL CALL XGOAL## CALL @LEFT POP DE CALL UNIFY## JR Z,AR8 ; { ; freeze(bst); CALL FREEZE## ;#ifdef DEBUG IF DEBUG ;msg(" *** unified"); LD HL,AR7MSG CALL MSG## DSEG AR7MSG: DB ' *** unified',0 CSEG ;#endif ENDIF ; bst->assertion.list = bst->assertion.list->right.list; CALL YASS## ; *** how about variable here? CALL @RIGHT## CALL YLASS## ; goto bstart; JP BSTART ; } AR8: ;#ifdef DEBUG IF DEBUG ;msg(" *** not unified"); LD HL,AR8MSG CALL MSG## DSEG AR8MSG: DB ' *** not unified',0 CSEG ;#endif ENDIF ; brelease(bst); CALL BRLS## ; goto abfail; JP ABFAIL ; ;/*==========*/ ; absucc: /* return to alpha after success of beta */ ;/*==========*/ ; fatal("\r\nabsucc not written."); ; ;/*==========*/ ; abfail: /* return to alpha after failure of beta */ ;/*==========*/ ABFAIL EQU ARPT ; goto arpt; ; ;/*==========*/ ; bstart: /* start beta state here */ ;/*==========*/ BSTART: ;#ifdef DEBUG IF DEBUG ; printf("\nBETA %04x: ",bst); LD HL,BSMSG CALL MSG## DSEG BSMSG: DB CR,LF,'BETA ',0 CSEG PUSH IY POP HL CALL PRHEX LD A,' ' CALL CHROUT## ; eprint(bst->assertion.list,bst->subst); CALL YSUBST## PUSH HL CALL YASS## POP DE CALL EPRINT## ;#endif ENDIF ; ;/*==========*/ ; brpt: /* repeat beta state */ ;/*==========*/ ;BRPT: ; if (bst->assertion.list == (PAIR)empty) CALL YASS LD DE,EMPTY CALL CPHL## JR NZ,BR1 ; { ; /* no (more) goals - Succeed */ ; bbot = bst; LD (BBOT),IY ; while (bst->assertion.list == (PAIR)empty) BR3: CALL YASS## LD DE,EMPTY CALL CPHL## JR NZ,BR4 ; { ; if (bst == prbase) PUSH IY POP HL LD DE,(PRBASE) CALL CPHL## JR NZ,BR5 ; { ; if (infile == stdin && outfile == stdout) LD A,(INF##) OR A JR NZ,BR6 LD A,(OUTF##) OR A JR NZ,BR6 ; msg("Yes."); LD HL,BR6MSG CALL MSG## DSEG BR6MSG: DB 'Yes.',0 CSEG BR6: ; if (prvals()) CALL PRVALS JR Z,BR7 ; { ; bst = bbot; LD IY,(BBOT) ; goto bafail; JP BAFAIL ; } BR7: ; else ; return; RET ; } BR5: ; bst = bst->pred->pred; CALL YPRED## CALL @PRED## PUSH HL POP IY ; } JR BR3 BR4: ; ast = makealpha(bst,bst->assertion.list,bbot); CALL YASS## LD DE,(BBOT) CALL MKALPHA## ; } JR BR2 BR1: ; else ; /* both pointers are to bst */ ; ast = makealpha(bst,bst->assertion.list,bst); CALL YASS## PUSH IY POP DE CALL MKALPHA## BR2: ; bst->assertion.list = bst->assertion.list->right.list; CALL YASS## CALL @RIGHT## CALL YLASS## ; goto astart; JP ASTART ; ;/*==========*/ ; basucc: /* return to beta after success of alpha */ ;/*==========*/ ;BASUCC EQU BRPT ; goto brpt; ; ;/*==========*/ ; bafail: /* return to beta after failure of alpha */ ;/*==========*/ BAFAIL: ; ast = bst->pred; CALL YPRED## PUSH HL POP IX ; if (ast == (ALPHASTATE *)empty) LD DE,EMPTY CALL CPHL## JR NZ,BA1 ; return FALSE; XOR A RET BA1: ; brelease(bst); CALL BRLS## ; goto abfail; JP ABFAIL ; } ; ;prvals() ; { ; SUBST * x; ; int cnt; DSEG X: DW 0 CNT: DB 0 CSEG PRVALS: ; ; cnt = 0; XOR A LD (CNT),A ; for (x = prbase->subst ; substp(x) ; x++) LD HL,(PRBASE) CALL @SUBST## LD (X),HL PR2: CALL SUBSTP## JR Z,PR1 ; { ; chrout('\t'); LD A,HT CALL CHROUT## ; msg(x->vname->string); CALL @VNAME## CALL @STR## CALL MSG## ; msg(" = "); LD HL,PR1MSG CALL MSG## DSEG PR1MSG: DB ' = ',0 CSEG ; prval(x); LD HL,(X) CALL PRVAL ; cnt = 1; LD A,1 LD (CNT),A ; msg("\r\n"); CALL CRLF## ; } LD HL,(X) LD DE,6 ADD HL,DE LD (X),HL JR PR2 PR1: ; if (! cnt) LD A,(CNT) OR A JR NZ,PR3 ; { ; msg("\r\n"); CALL CRLF## ; return FALSE; XOR A RET ; } PR3: ; msg("More?"); LD HL,PR3MSG CALL MSG## DSEG PR3MSG: DB 'More?',0 CSEG ; while (separp(rdchar())) ; ; PR4: CALL RDCHAR## CALL SEPARP## JR NZ,PR4 ; if (character == 'Y' || character == 'y') ; return TRUE; ; return FALSE; LD A,(CHR##) CP 'Y' JR Z,RETT CP 'y' JR Z,RETT XOR A RET RETT: LD A,1 OR A RET ; } ; ;prval(sub) ; SUBST * sub; ; { ; static SUBVAL as; DSEG AS: DW 0 CSEG PRVAL: ; ; as.val = value(sub); CALL VALUE## LD (AS),HL ; if (substp(as.val)) CALL SUBSTP## JR Z,PR6 ; msg(as.val->vname->string); CALL @VNAME## CALL @STR## CALL MSG## RET PR6: ; else ; eprint(as.assgn->sexp.list,as.assgn->slist); CALL @SLIST## PUSH HL LD HL,(AS) CALL @EXPR## POP DE CALL EPRINT## RET ; } ; IF DEBUG ; display HL in hex PRHEX: LD A,H CALL HINYB CALL LONYB LD A,L CALL HINYB CALL LONYB RET HINYB: PUSH AF AND 0F0H RRCA RRCA RRCA RRCA CALL LONYBX POP AF RET LONYB: AND 00FH LONYBX: ADD A,90H DAA ADC A,40H DAA JP CHROUT## ENDIF ; right (value if variable) ; expression in HL, substs in DE V@RIGHT: PUSH DE PUSH HL LD HL,@RIGHT## LD (V@R+1),HL V@9: POP HL CALL VARP## JR NZ,V@0 V@R: CALL 0 ; filled in POP DE RET V@0: POP DE CALL VF## CALL VALUE## PUSH HL CALL SUBSTP## JR Z,V@1 LD HL,V@ERR JP ERROR## DSEG V@ERR: DB CR,LF,'Meta-variable remaining',0 CSEG V@1: POP HL PUSH HL CALL @SLIST## POP HL PUSH DE CALL @EXPR## JR V@R ; left (value if variable) ; expression in HL, substs in DE V@LEFT: PUSH DE PUSH HL LD HL,@LEFT## LD (V@R+1),HL JR V@9 END [ A sample database for testing E-Prolog. See the documentation file EPRO.DOC. ] ((father jack ken)) ((father jack karen)) ((grandparent ?grandparent ?grandchild) (parent ?grandparent ?parent) (parent ?parent ?grandchild)) ((mother el ken)) ((mother cele jack)) ((parent ?parent ?child) (mother ?parent ?child)) ((parent ?parent ?child) (father ?parent ?child)) [ This simple logic problem is found on p. 206 of the September, 1984, Scientific American, in the article "Computer Software for Intelligent Systems". To find out whether Marcus hates Caesar, use the query > (hates Marcus Caesar) ] [ 1. Marcus was a man.] ((man Marcus)) [ 2. Marcus was a Pompeian.] ((pompeian Marcus)) [ 3. All Pompeians were Romans.] ((roman ?X) (pompeian ?X)) [ 4. Caesar was a ruler.] ((ruler Caesar)) [ 5. All romans were either loyal to Caesar or hated him.] ((hates ?X Caesar) (roman ?X) (not-loyal-to ?X Caesar)) [ 6. People only try to assasinate rulers they are not loyal to.] ((not-loyal-to ?X ?Y) (man ?X) (tries-to-assasinate ?X ?Y)) [ 7. Marcus tried to assasinate Caesar.] ((tries-to-assasinate Marcus Caesar)) [ 8. A person hates someone who steals his wife.] ((hates ?X ?Y) (steals-wife-of ?Y ?X)) [ 9. If the wife of a man who is alive marries a second man, then the second man stole the first man's wife.] ((steals-wife-of ?X ?Y) (wife-of ?Z ?Y) (alive ?Y) (marries ?X ?Z)) [10. Lucretia was Marcus's wife.] ((wife-of Lucretia Marcus)) [11. Marcus was alive.] ((alive Marcus))  [Standard predicates for E-Prolog. JULY 5, 1985 ] [-- (EQ ?X ?Y) means ?X and ?Y are equal expressions ] ((EQ ?X ?X)) [-- (AND ?X1 ?X2 ?X3 ... ) means all succeed ] ((AND ?X | ?rest) ?X (AND | ?rest)) ((AND)) [-- (OR ?X1 ?X2 ?X3 ... ) means at least one succeeds (attempts stop upon the first success) ] ((OR ?X | ?rest) ?X) ((OR ?X | ?rest) (OR | ?rest)) [-- (NOT ?X) succeeds if and only if ?X fails ] ((NOT ?X) ?X (/) (FAIL)) ((NOT ?X)) [-- (IF ?X ?Y ?Z) is executed as: if ?X then ?Y else ?Z ?Z is optional ] ((IF ?X ?Y | ?Z) ?X (/) ?Y) ((IF ?X ?Y ?Z) (/) ?Z) ((IF ?X ?Y)) [-- (IFF ?X ?Y) succeeds if and only if both ?X and ?Y succeed or both fail ] ((IFF ?X ?Y) ?X (/) ?Y) ((IFF ?X ?Y) (NOT ?Y))  ; =========================================================== ; SYMB.Z80 ; symbol table routines for E-Prolog ; May 27, 1985 .Z80 FALSE EQU 0 TRUE EQU 1 EMPTY EQU -1 UNDEF EQU -2 HT EQU 9 LF EQU 10 CR EQU 13 CTLZ EQU 26 CPM EQU 0000H BDOS EQU CPM+0005H CDMA EQU CPM+0080H TPA EQU CPM+0100H ;SYMBOL * ;gtoken() ; { ; /* read token */ GTOKEN:: ; static int i; ; static char * tokptr; ; static SYMBOL * sadr; ; static SYMBOL ** sadrr; DSEG TOKPTR: DW 0 SADR: DW 0 SADRR: DW 0 CSEG ; ; tokptr = cdma; LD HL,CDMA LD (TOKPTR),HL ; while(separp(rdchar())) ; ; GT1: CALL RDCHAR## CALL SEPARP## JR NZ,GT1 ; if (digitp()) CALL DIGITP JR Z,GT2 ; { ; for (i = 0 ; digitp() ; rdchar()) LD HL,0 GT4: PUSH HL CALL DIGITP JR Z,GT3 ; i = i*10 + ((int)(character - '0')); POP HL ADD HL,HL LD D,H LD E,L ADD HL,HL ADD HL,HL ADD HL,DE LD A,(CHR##) SUB '0' LD E,A LD D,0 ADD HL,DE CALL RDCHAR## JR GT4 GT3: ; unrdchar(); CALL UNRDCH## ; if (numbp(i)) ; return i; POP HL CALL NUMBP## RET NZ ; return 0; LD HL,0 RET ; } GT2: ; if (character == '"') LD A,(CHR##) CP '"' JR NZ,GT5 ; { ; rdchar(); CALL RDCHAR## ; do GT9: ; { ; cntl(); CALL CNTL ; *tokptr++ = character; LD HL,(TOKPTR) LD A,(CHR##) LD (HL),A INC HL LD (TOKPTR),HL ; rdchar(); CALL RDCHAR## ; } ; while (character != '"') ; LD A,(CHR##) CP '"' JR NZ,GT9 ; } JR GT8 GT5: ; else if (character == '\'') CP "'" JR NZ,GT6 ; { ; rdchar(); CALL RDCHAR## ; do GT10: ; { ; cntl(); CALL CNTL ; *tokptr++ = character; LD HL,(TOKPTR) LD A,(CHR##) LD (HL),A INC HL LD (TOKPTR),HL ; rdchar(); CALL RDCHAR## ; } ; while (character != '\'') ; LD A,(CHR##) CP "'" JR NZ,GT10 ; } JR GT8 GT6: ; else if (goodchp()) CALL GOODCP JR Z,GT7 ; { ; do GT11: ; { ; *tokptr++ = character; LD HL,(TOKPTR) LD A,(CHR##) LD (HL),A INC HL LD (TOKPTR),HL ; rdchar(); CALL RDCHAR## ; } ; while (goodchp()) ; CALL GOODCP JR NZ,GT11 ; unrdchar(); CALL UNRDCH## ; } JR GT8 GT7: ; else ; *tokptr++ = character; LD HL,(TOKPTR) LD A,(CHR##) LD (HL),A INC HL LD (TOKPTR),HL GT8: ; *tokptr = '\0'; LD HL,(TOKPTR) LD (HL),0 ; ; /* find it in symbol table */ ; sadr = sbot; LD HL,(SBOT##) LD (SADR),HL ; do FS1: ; { ; if ((i = strcmp(sadr->string,cdma)) == 0) LD HL,(SADR) CALL @STR## LD DE,CDMA CALL STRCMP JR NZ,FS2 ; return sadr; LD HL,(SADR) RET FS2: ; if (i < 0) JR NC,FS3 ; sadrr = &(sadr->rptr); LD HL,(SADR) INC HL INC HL INC HL INC HL LD (SADRR),HL JR FS4 FS3: ; else ; sadrr = &(sadr->lptr); LD HL,(SADR) INC HL INC HL LD (SADRR),HL FS4: ; sadr = *sadrr; LD E,(HL) INC HL LD D,(HL) LD (SADR),DE ; } ; while (sadr != (SYMBOL *)empty) ; LD HL,EMPTY CALL CPHL## JR NZ,FS1 ; *sadrr = mksymb(); CALL MKSYMB EX DE,HL LD HL,(SADRR) LD (HL),E INC HL LD (HL),D ; return *sadrr; EX DE,HL RET ; } ; compare two strings ; ; input: ; HL, DE pointing to the strings ; output: ; Z and C flags: ; Z ,NC = (HL) = (DE) ; NZ,C = (HL) < (DE) ; NZ,NC = (HL) > (DE) STRCMP:: EX DE,HL ST1: LD A,(DE) CP (HL) RET NZ OR A RET Z INC HL INC DE JR ST1 ;BOOLEAN ;digitp() ; { ; return ('0' <= character && character <= '9'); ; } DIGITP: LD A,(CHR##) CP '0' JR C,RETF CP '9'+1 JR NC,RETF RETT: OR A RET RETF: XOR A RET ;cntl() CNTL: ; { ; if (character == '^') LD A,(CHR##) CP '^' RET NZ ; { ; rdchar(); CALL RDCHAR## ; if (character == '^') ; return; LD A,(CHR##) CP '^' RET Z ; if (character < '@') ; return; CP '@' RET C ; character &= 0x1F; AND 1FH LD (CHR##),A ; } ; } ;BOOLEAN ;goodchp() GOODCP: ; { ; switch (character) LD A,(CHR##) ; { ; case '_': ; case '-': ; case '?': ; return TRUE; ; } CP '_' JP Z,RETT CP '-' JP Z,RETT CP '?' JP Z,RETT ; return (('0' <= character && character <= '9') || ; ('A' <= character && character <= 'Z') || ; ('a' <= character && character <= 'z') ); CP '0' JP C,RETF CP '9'+1 JP C,RETT CP 'A' JP C,RETF CP 'Z'+1 JP C,RETT CP 'a' JP C,RETF CP 'z'+1 JP C,RETT JP RETF ; } ; Make an entry in the symbol table ; ;SYMBOL * ;mksymb() ; { MKSYMB:: ; static char * tokptr; ; static SYMBOL * sadr; ; ; sadr = (SYMBOL *)sfree; LD HL,(SFREE##) PUSH HL ; sadr->addr = empty; LD DE,EMPTY LD (HL),E INC HL LD (HL),D ; sadr->lptr = empty; INC HL LD (HL),E INC HL LD (HL),D ; sadr->rptr = empty; INC HL LD (HL),E INC HL LD (HL),D ; for (sfree = sadr->string , tokptr = cdma ; ; (*sfree++ = *tokptr++) != '\0' ; ) ; ; INC HL EX DE,HL LD HL,CDMA MK1: LD A,(HL) LD (DE),A INC HL INC DE OR A JR NZ,MK1 EX DE,HL LD (SFREE##),HL ; if (sfree >= stop) LD DE,(STOP##) DEC DE CALL CPHL## JR C,MK2 ; fatal("\r\nOut of string space."); LD HL,MK1MSG JP FATAL## DSEG MK1MSG: DB CR,LF,"Out of string space.",0 CSEG MK2: ; return sadr; POP HL RET ; } END  ; =========================================================== ; UNIFY.Z80 ; unify routine for E-Prolog ; June 10, 1985 .Z80 FALSE EQU 0 TRUE EQU 1 EMPTY EQU -1 UNDEF EQU -2 FROZEN EQU -3 DEBUG EQU FALSE HT EQU 9 LF EQU 10 CR EQU 13 CTLZ EQU 26 CPM EQU 0000H BDOS EQU CPM+0005H CDMA EQU CPM+0080H TPA EQU CPM+0100H ;SUBVAL ;value(v) ; SUBST * v; ; { ; SUBST * u; ; VALUE:: PUSH HL ; v ; while (substp(v) && ((u = v->forw.val) != (SUBST *)UNDEF)) VA2: CALL SUBSTP## ; substp(v) ? JR Z,VA1 CALL @FORW## ; u = v->forw LD DE,UNDEF CALL CPHL## ; u == UNDEF ? JR Z,VA1 ; { ; v = u; POP DE ; discard PUSH HL ; v ; } JR VA2 VA1: ; return v; POP HL ; v RET ; } ;LSUBST ;vf(var,lsub) ;/* find variable */ ; VARIABLE var; ; LSUBST lsub; DSEG VAR: DW 0 LSUB: DW 0 CSEG ; { VF:: LD (VAR),HL LD (LSUB),DE ; for ( ; var != (*lsub).vname ; lsub++) EX DE,HL VF1: CALL @VNAME## LD DE,(VAR) CALL CPHL## JR Z,VF2 ;#ifdef DEBUG IF DEBUG ; if (! varp((*lsub).vname)) CALL VARP## JR NZ,VF3 ; fatal("\r\nFaulty subststitution list.") LD HL,VF3MSG JP FATAL## DSEG VF3MSG: DB CR,LF,'Faulty substitution list.',0 CSEG VF3: ;#endif ENDIF ; ; LD HL,(LSUB) LD DE,6 ADD HL,DE LD (LSUB),HL JR VF1 VF2: ; return lsub; LD HL,(LSUB) RET ; } ; UNIFY ; ; recursive ; input: ; HL "low" expression ; DE lsubst for HL ; HL' "high" expression ; DE' lsubst for HL' ; output ; Z flag set = failure ;BOOLEAN ;unify(lowe,lows,hie,his) /* recursive */ ; EXPR lowe; ; LSUBST lows; ; EXPR hie; ; LSUBST his; ; { ; EXPR lowex; ; EXPR hiex; ; SUBVAL vfl; ; SUBVAL vfh; ; LSUBST temp; DSEG LOWEX: DW 0 HIEX: DW 0 LOWS: DW 0 HIS: DW 0 VFL: DW 0 VFH: DW 0 CSEG ; ; lowex.list = lowe; ; hiex.list = hie; /* synonyms */ UNIFY:: LD (LOWEX),HL LD (LOWS),DE EXX LD (HIEX),HL LD (HIS),DE IF DEBUG PUSH HL LD HL,UNMSG1 CALL MSG## LD HL,(LOWEX) LD DE,(LOWS) CALL EPRINT## LD HL,UNMSG2 CALL MSG## LD HL,(HIEX) LD DE,(HIS) CALL EPRINT## DSEG UNMSG1: DB CR,LF,' ++Unify ',0 UNMSG2: DB ' with ',0 CSEG POP HL ENDIF ; ; if (varp(hie)) CALL VARP## JR Z,UN1 ; { ; vfh.val = value(vf(hiex.symbol,his)); LD DE,(HIS) CALL VF CALL VALUE LD (VFH),HL ; if (! substp(vfh.val)) CALL SUBSTP JR NZ,UN1 ; return unify(lowe,lows, ; vfh.assgn->sexp.list,vfh.assgn->slist); LD HL,(VFH) CALL @SLIST## PUSH HL LD HL,(VFH) CALL @EXPR POP DE EXX JR UNIFY ; tail recursion ; } ; UN1: ; if (varp(lowe)) LD HL,(LOWEX) CALL VARP## JP Z,UN2 ; { ; vfl.val = value(vf(lowex.symbol,lows)); LD DE,(LOWS) CALL VF CALL VALUE LD (VFL),HL ; if (substp(vfl.val)) CALL SUBSTP## JP Z,UN3 ; { ; if (varp(hie)) LD HL,(HIEX) CALL VARP## JR Z,UN4 ; { ; /* both are really variables */ ; if (vfh == vfl) ; return TRUE; LD HL,(VFH) LD DE,(VFL) CALL CPHL## JR Z,RETT ; if (vfl.val > vfh.val) JR NC,UN7 ; { ; temp = vfh.val; LD HL,(VFH) PUSH HL ; vfh.val = vfl.val; LD HL,(VFL) LD (VFH),HL ; vfl.val = temp; POP HL LD (VFL),HL ; } UN7: ; if (vfh.val->back.val != (SUBST *)UNDEF) LD HL,(VFH) CALL @BACK## LD DE,UNDEF CALL CPHL## JR Z,UN8 ; { ; x = vfh->forw = makesexpr(vfh->vname,vfh,UNDEF) LD HL,(VFH) PUSH HL CALL @VNAME## POP DE LD BC,UNDEF CALL MKSEXPR## EX DE,HL PUSH DE LD HL,(VFH) CALL @LFORW## ; vfh = x->forw = makesexpr(vfh->vname,UNDEF,UNDEF) LD HL,(VFH) CALL @VNAME## LD DE,UNDEF LD C,E LD B,D CALL MKSEXPR## LD (VFH),HL EX DE,HL POP HL CALL @LFORW## ; } UN8: ; vfh.val->back.val = vfl.val; LD HL,(VFH) LD DE,(VFL) CALL @LBACK## ; vfl.val->forw.val = vfh.val; LD HL,(VFL) LD DE,(VFH) CALL @LFORW## ; return TRUE; RETT: LD A,1 OR A RET ; } ;UN6 EQU UN2 UN4: ; else ; { ; vfl.val->forw.assgn = makesexpr(hie,vfl.val,his); LD HL,(HIEX) LD DE,(VFL) LD BC,(HIS) CALL MKSEXPR## EX DE,HL LD HL,(VFL) CALL @LFORW## ; return TRUE; JR RETT ; } ; } ;UN5 EQU UN2 UN3: ; else ; return unify(vfl.assgn->sexp.list,vfl.assgn->slist, ; hie,his); LD HL,(HIEX) LD DE,(HIS) EXX LD HL,(VFL) CALL @SLIST## PUSH HL LD HL,(VFL) CALL @EXPR## POP DE JP UNIFY ; tail recursion ; } ; UN2: UN5 EQU UN2 UN6 EQU UN2 ; if (nelistp(lowex.list)) LD HL,(LOWEX) CALL NELP## JR Z,UN9 ; { ; if (varp(hie)) LD HL,(HIEX) CALL VARP## JR Z,UN10 ; { ; vfh.val->forw.assgn = makesexpr(lowe,vfh.val,lows); LD HL,(LOWEX) LD DE,(VFH) LD BC,(LOWS) CALL MKSEXPR## EX DE,HL LD HL,(VFH) CALL @LFORW## ; return TRUE; JP RETT ; } UN10: ; else if (nelistp(hie)) LD HL,(HIEX) CALL NELP## JR Z,UN11 ; { ; return (unify(lowex.list->left.list,lows, ; hiex.list->left.list,his) && ; unify(lowex.list->right.list,lows, ; hiex.list->right.list,his)); LD HL,(HIEX) PUSH HL CALL @LEFT## LD DE,(HIS) PUSH DE EXX LD HL,(LOWEX) PUSH HL CALL @LEFT## LD DE,(LOWS) PUSH DE CALL UNIFY ; recursion JR Z,UN12 POP DE POP HL PUSH DE CALL @RIGHT## POP DE EXX POP DE POP HL PUSH DE CALL @RIGHT## POP DE EXX JP UNIFY ; tail recursion ; } UN12: POP HL POP HL POP HL POP HL UN11: ; else /* hie is symbol or number or empty */ ; { ; return FALSE; RETF: XOR A RET ; } ; } UN9: ; else /* lowex is symbol or number or empty */ ; { ; if (varp(hie)) LD HL,(HIEX) CALL VARP## JR Z,UN13 ; { ; vfh.val->forw.assgn = makesexpr(lowe,vfh.val,lows); LD HL,(LOWEX) LD DE,(VFH) LD BC,(LOWS) CALL MKSEXPR## EX DE,HL LD HL,(VFH) CALL @LFORW## ; return TRUE; JP RETT ; } UN13: ; else if (nelistp(hie)) ; return FALSE; CALL NELP JR NZ,RETF ; else /* hie is symbol or number or empty */ ; { ; return (hiex.list == lowex.list); LD DE,(LOWEX) CALL CPHL## JP Z,RETT JR RETF ; } ; } ; } END  VALGOL I INFORMATION -------------------- G. A. Edgar This file contains a description of the language VALGOL I, a (very) small derivative of ALGOL-60. It is intended to explain the compiler VALGOL.PRO on this disk. This language was published in a paper by D. V. Schorre in 1964 as a sample language for META II. His paper was reprinted in Dr. Dobb's Journal, April, 1980. First, we will go through a description of the language. Then we will take a sample file and see what is involved in getting it to run. ----------------------------------------------------------- VALGOL I is basically a subset of ALGOL-60. The main peculiarities are these: (1) The key words that are usually typeset in boldface are preceded by a period. ( .begin .end .if .then .else .until .do .integer ) This also applies to the equal sign for comparing two expressions. ( .= ) (2) There is only one data type, namely .integer . This is a 16 bit two's-complement number in the compiler supplied. Thus you go from 0 up to 65535, and then back to 0. (3) The assignment statement is reverse from the normal order. ( 5 =: x assigns the value 5 to x ) (4) Arithmetic allows addition ( + ) subtraction ( - ) and multiplication ( * ) . There is no unary minus sign, so if you want -2 you can write either 0-2 or else 65534 (or, for that matter, 196606) . Let's walk through some of the syntax of the language. A program consists of the keyword ".begin", followed by an optional declaration, followed by one or more statements, separated by semicolons ( ; ) , followed by the keyword ".end". A declaration consists of the keyword ".integer" followed by a list of identifiers, separated by commas. A statement is one of the following: (1) an I/O statement. This is either of the form edit( expression , 'string') which will send (expression) spaces and then the (string) to the console, or of the form print which will send an end-of-line to the console. (2) an assignment statement, which has the form expression =: variable (3) a loop, of the form .until expression .do statement A value of 0 for the expression is considered false, and a nonzero value is true. (4) a conditional statement of the form .if expression .then statement .else statement The .else is not optional. (5) a block, which consists of the keyword ".begin", followed by an optional declaration, followed by zero or more statements, separated by semicolons, followed by the keyword ".end". Notice that the null statement in the form .begin .end is allowed. It is important that the semicolon is a statement separator, and not a statement terminator (as in some other languages, such as PL/I and C). You will get a syntax error message if you put a semicolon just before the ".end" in a block. A test for equality is allowed: 2 + x .= y * y This has value 1 if true and 0 if false. Expressions can be built up from variables, numbers, the operations + , - , *, and parentheses "(" , ")". -------------------------------------------------- Now we will go through a compile and run of a VALGOL program. Let's use this sample program: .begin .integer x ; 0 =: x ; .until x .= 15 .do .begin edit ( 1 + 14*x - x*x , '+' ) ; print ; x + 1 =: x .end .end Suppose it is in a file called P.VAL. We compile it: B>EPRO E-Prolog ver. 2.3 (August 1, 1985) > (LOAD VALGOL) > (compile P) VALGOL 1 compiler - translates VALGOL to ASM P.VAL -> P.ASM *** Compilation complete *** Yes. > ^C This creates an ASM-compatible assembly-language file that begins like this: VBDOS EQU 5 VTPA EQU 256 VCR EQU 13 VLF EQU 10 ORG VTPA LXI SP,VSTACK JMP V1 Vx: DW 0 V1: LXI H,0 SHLD Vx V2: LHLD Vx PUSH H LXI H,9 ... and so on. Next, the program can be compiled and run as normal: B>ASM P.BBZ CP/M ASSEMBLER - VER 2.0 01F5 001H USE FACTOR END OF ASSEMBLY B>LOAD P FIRST ADDRESS 0100 LAST ADDRESS 01B8 BYTES READ 00B7 RECORDS WRITTEN 02 B>P + + + + + + + + + + + + + + + And there it is. ------------------------------- G. A. Edgar May 21, 1984 [CompuServe release] revised October 21, 1984 [for Meta4 material, SIG/M vol. 208] revised August 1, 1985 [for E-Prolog release]  [ VALGOL.PRO Compiler for VALGOL I -- ver. 2.2 Written in E-Prolog. Translates VALGOL I to ASM-compatible 8080 assembly language. (Requires about 3000 bytes of string space.) See the May, 1985, issue of Dr. Dobb's Journal for an explanation of this compiler. Written by: G. A. EDGAR status: public domain versions 0.3 September 9, 1984 M80, Z80, Micro-PROLOG 1.0 September 16, 1984 output for ASM 1.1 November 1, 1984 display input 1.2 November 10, 1984 version for DDJ 2.0 April 10, 1985 converted to E-Prolog 2.1 May 16, 1985 for E-Prolog ver. 2.0 2.2 August 1, 1985 version for SIG/M Usage: (compile FOO BAR) FOO.VAL -> BAR.ASM (compile FOO) FOO.VAL -> FOO.ASM ] [ ---------- Language independent part ---------------] [ compile: input ?X, output ?Y] ((compile ?X) (compile ?X ?X)) ((compile ?A:?X ?Y)(comp (?A:?X.VAL)(?Y.ASM))) ((compile ?X ?B:?Y)(comp (?X.VAL)(?B:?Y.ASM))) ((compile ?A:?X) (comp (?A:?X.VAL) (?A:?X.ASM))) ((compile ?X ?Y) (comp (?X.VAL) (?Y.ASM))) ((compile ?A:?X ?B:?Y) (comp (?A:?X.VAL)(?B:?Y.ASM))) ((comp ?infile ?outfile) (message ?message) (WRITE ?message "^M^J") (WRITE | ?infile) (WRITE " -> " | ?outfile) (WRITE "^M^J") (open | ?infile) (CREATE | ?outfile) (readtoken ?token) (LESS ?dummy ?label) (syntax ?syntax) (/) (Q (?token | ?label) ?after ?syntax) (CLOSE) (OPEN CON) (WRITE "^M^J** Compilation complete **^M^J") (/)) ((comp | ?rest) (CLOSE) (OPEN CON) (WRITE "** Error detected **^M^J")(FAIL)) ((open | ?file) (OPEN | ?file)) ((open | ?file) (WRITE "OPEN FAILURE ON " | ?file) (WRITE "^M^J") (FAIL)) ((C | ?X) (compile | ?X)) [ Q: find it in the language-specific database] ((Q ?before ?after ?Z) (?Z | ?X1) [ (WRITE "^M^J Try " ?Z ?before) ] (sequential ?before ?after | ?X1) [ (WRITE "^M^J Succeed " ?Z ?after) ] ) ((sequential ?position ?position)) ((sequential ?position1 ?position3 (?z|?Z)|?rest) (?z ?position1 ?position2|?Z) (/) (sequential ?position2 ?position3|?rest)) [ out: send to outfile] ((out ?position ?position | ?data) (WRITE | ?data)) [ readtoken: read a new token, watch for "."] ((readtoken ?token) (READ ?token1) (readtokenx ?token1 ?token)) ((readtokenx . (. | ?token2)) (READ ?token2)) ((readtokenx ?token1 ?token1)) [ match: the input matches token] ((match ((. | ?token) | ?label) (?newtoken | ?label) . ?token) (readtoken ?newtoken)) ((match (?token | ?label) (?newtoken | ?label) ?token) (readtoken ?newtoken)) ((matchx ((. | ?token) | ?label) () . ?token)) ((matchx (?token | ?label) () ?token)) [ empty: matches automatically] ((empty ?position ?position)) [ multiple: match the following zero or more times] ((multiple ?position1 ?position3|?Z) (sequential ?position1 ?position2|?Z) (/) (multiple ?position2 ?position3|?Z)) ((multiple ?position ?position|?Z)) [ label: generate a new label] ((label (?token | ?label) (?token | ?newlabel) ?label) (LESS ?label ?newlabel) (/)) [ string: match a string quoted within characters '] ((string (?token | ?label) (?newtoken | ?label) ?token) (readtoken ?newtoken)) [ id: match an identifier] ((id (?token | ?label) (?newtoken | ?label) ?token) (LESS @ ?token) (/) (readtoken ?newtoken)) [ number: match a number] ((number (0 | ?label) (?newtoken | ?label) 0) (/) (readtoken ?newtoken)) ((number (?token | ?label) (?newtoken | ?label) ?token) (LESS 0 ?token) (/) (readtoken ?newtoken)) [ --- VALGOL specifics ------------------------------ ] ((message "VALGOL 1 compiler - translates VALGOL to ASM")) ((syntax PROGRAM)) ((PROGRAM (match .begin) (out "VCPM EQU 0^M^J" "VBDOS EQU 5^M^J" "VTPA EQU 256^M^J" "VCR EQU 13^M^J" "VLF EQU 10^M^J" " ORG VTPA^M^J" " LXI SP,VSTACK^M^J") (Q OPT-DECLARATION) (Q STATEMENT) (multiple (match ;) (Q STATEMENT)) (matchx .end) (out " JMP VCPM^M^J" "VMULT:^M^J" " MOV B,H^M^J" " MOV C,L^M^J" " XRA A^M^J" " MOV H,A^M^J" " MOV L,A^M^J" " MVI A,16^M^J" "VMULT1:^M^J" " PUSH PSW^M^J" " DAD H^M^J" " XRA A^M^J" " MOV A,C^M^J" " RAL^M^J" " MOV C,A^M^J" " MOV A,B^M^J" " RAL^M^J" " MOV B,A^M^J" " JNC VMULT2^M^J" " DAD D^M^J" "VMULT2:^M^J" " POP PSW^M^J" " DCR A^M^J" " ORA A^M^J" " JNZ VMULT1^M^J" " RET^M^J" "VEDIT:^M^J" " MOV A,H^M^J" " ORA L^M^J" " JZ VEDIT1^M^J" " MVI A,' '^M^J" " CALL VCPMOUT^M^J" " DCX H^M^J" " JMP VEDIT^M^J" "VEDIT1:^M^J" " POP H^M^J" "VEDIT2:^M^J" " MOV A,M^M^J" " CPI 0^M^J" " INX H^M^J" " JZ VEDIT3^M^J" " CALL VCPMOUT^M^J" " JMP VEDIT2^M^J" "VEDIT3:^M^J" " PUSH H^M^J" " RET^M^J" "VPRINT:^M^J" " MVI A,VCR^M^J" " CALL VCPMOUT^M^J" " MVI A,VLF^M^J" " CALL VCPMOUT^M^J" " RET^M^J" "VCPMOUT:^M^J" " PUSH H^M^J" " MOV E,A^M^J" " MVI C,2^M^J" " CALL VBDOS^M^J" " POP H^M^J" " RET^M^J" " DS 60^M^J" "VSTACK:^M^J" " END^M^J") )) ((OPT-DECLARATION (Q DECLARATION) (match ;))) ((OPT-DECLARATION (empty))) ((DECLARATION (match .integer) (label ?label1) (out " JMP V" ?label1 "^M^J") (Q ID-SEQUENCE) (out "V" ?label1 ":^M^J") )) ((ID-SEQUENCE (Q IDENTIFIER) (multiple (match ,) (Q IDENTIFIER) ))) ((IDENTIFIER (id ?identifier) (out ?identifier "V: DS 2^M^J") )) ((STATEMENT (Q BLOCK))) ((STATEMENT (Q UNTIL-STATEMENT))) ((STATEMENT (Q CONDITIONAL-STATEMENT))) ((STATEMENT (Q IO-STATEMENT))) ((STATEMENT (Q ASSIGNMENT-STATEMENT))) ((BLOCK (match .begin) (Q BLOCKBODY))) ((BLOCKBODY (Q DECL-OR-ST) (multiple (match ;) (Q STATEMENT) ) (match .end) )) ((BLOCKBODY (match .end) )) ((DECL-OR-ST (Q DECLARATION))) ((DECL-OR-ST (Q STATEMENT))) ((IO-STATEMENT (match edit) (match "(") (Q EXPRESSION) (match ,) (string ?Z) (out " CALL VEDIT^M^J") (out " DB '" ?Z "',0^M^J") (match ")") )) ((IO-STATEMENT (match print) (out " CALL VPRINT^M^J") )) ((CONDITIONAL-STATEMENT (match .if) (label ?label1) (label ?label2) (Q EXPRESSION) (match .then) (out " MOV A,H^M^J") (out " ORA L^M^J") (out " JZ V" ?label1 "^M^J") (Q STATEMENT) (match .else) (out " JMP V" ?label2 "^M^J") (out "V" ?label1 ":^M^J") (Q STATEMENT) (out "V" ?label2 ":^M^J") )) ((UNTIL-STATEMENT (match .until) (label ?label1) (label ?label2) (out "V" ?label1 ":^M^J") (Q EXPRESSION) (match .do) (out " MOV A,H^M^J") (out " ORA L^M^J") (out " JNZ V" ?label2 "^M^J") (Q STATEMENT) (out " JMP V" ?label1 "^M^J") (out "V" ?label2 ":^M^J") )) ((ASSIGNMENT-STATEMENT (Q EXPRESSION) (match =)(match :) (id ?identifier) (out " SHLD " ?identifier "V^M^J") )) ((EXPRESSION (Q EXPRESSION1) (Q OPT-RIGHT-SIDE))) ((OPT-RIGHT-SIDE (match .=) (label ?label1) (label ?label2) (out " PUSH H^M^J") (Q EXPRESSION1) (out " POP D^M^J" " MOV A,L^M^J" " SUB E^M^J" " JNZ V" ?label2 "^M^J" " MOV A,H^M^J" " SBB D^M^J" " JNZ V" ?label2 "^M^J" " LXI H,1^M^J" " JMP V" ?label1 "^M^J" "V" ?label2 ":^M^J" " LXI H,0^M^J" "V" ?label1 ":^M^J") )) ((OPT-RIGHT-SIDE (empty))) ((EXPRESSION1 (Q TERM) (multiple (Q SIGNED-TERM)))) ((SIGNED-TERM (match +) (out " PUSH H^M^J") (Q TERM) (out " POP D^M^J") (out " DAD D^M^J"))) ((SIGNED-TERM (match -) (out " PUSH H^M^J") (Q TERM) (out " POP D^M^J" " MOV A,E^M^J" " SUB L^M^J" " MOV L,A^M^J" " MOV A,D^M^J" " SBB H^M^J" " MOV H,A^M^J") )) ((TERM (Q PRIMARY) (multiple (match *) (out " PUSH H^M^J") (Q PRIMARY) (out " POP D^M^J") (out " CALL VMULT^M^J") ))) ((PRIMARY (id ?identifier) (out " LHLD " ?identifier "V^M^J"))) ((PRIMARY (number ?number) (out " LXI H," ?number "^M^J"))) ((PRIMARY (match "(") (Q EXPRESSION) (match ")") ))