home *** CD-ROM | disk | FTP | other *** search
/ CP/M / CPM_CDROM.iso / cpm / languags / prolog / epro23.ark / EPRO.MAC < prev    next >
Text File  |  1986-11-02  |  7KB  |  404 lines
  1.  
  2. ; EPRO.Z80
  3. ;        ********   E-Prolog   ******
  4.  
  5. ;    G. A. Edgar
  6. ;    107 W. Dodridge St., Columbus, OH 43202
  7. ;    CompuServe 70715,1324
  8.  
  9. ;    Not copyrighted, but if you improve it, how about
  10. ;    at least letting me know?
  11.  
  12.     .Z80
  13. SIGNON:: DB    'E-Prolog   ver. 2.3'
  14.     DB    '     (August 1, 1985)',13,10,0
  15. SYMBSZ    EQU    3000        ; symbol table size
  16. STACKSZ    EQU    1500        ; stack size
  17.  
  18. .COMMENT %
  19.  
  20.  versions
  21.   1.0        April 2, 1985
  22.     For Macro-80, Z-80, CP/M 2.2
  23.     Based on PIL : Prolog in Lisp,
  24.     by Ken Kahn, Par Emanuelson, Martin Nilsson.
  25.   1.1        April 10, 1985
  26.     Packing of node space
  27.     Rewrite VALUE
  28.   1.2        April 19, 1985
  29.     Rearrange database
  30.     (version 1.2 released)
  31.   1.3        May 3, 1985
  32.     bug fixes
  33.   2.0        May 19, 1985
  34.     Rewritten, mostly in C
  35.   2.1        June 1, 1985
  36.     Back into M80, Z-80, CP/M
  37.   2.2        July 5, 1985
  38.     line-feed following BDOS 10 call
  39.     fixes for UNIFY, PROVE
  40.   2.3        August 1, 1985
  41.     version for SIG/M
  42.  
  43. Most of the C language source has been left in the code as
  44. comments.  The source files are:  EPRO.Z80, CLASS.Z80,
  45. SYMB.Z80, HEAP.Z80, DATBADD.Z80, UNIFY.Z80, CMD.Z80,
  46. PROVE.Z80, INPUT.Z80, OUTPUT.Z80, ERROR.Z80, ASSEM.Z80,
  47. INIT.Z80 .  The documentation file is EPRO.DOC .
  48.  
  49. /* types */
  50.  
  51. typedef    unsigned                NUMBER;
  52.  
  53. typedef    int                    BOOLEAN;
  54.  
  55. typedef    struct XSYMBOL {
  56.     char *            addr;
  57.     struct XSYMBOL *    lptr;
  58.     struct XSYMBOL *    rptr;
  59.     char            string[1];
  60.     }                    SYMBOL;
  61.  
  62. typedef    SYMBOL *                VARIABLE;
  63.  
  64. typedef    struct XNODE *                PAIR;
  65.  
  66. typedef    union {
  67.     PAIR            list;
  68.     SYMBOL *        symbol;
  69.     NUMBER            number;
  70.     }                    EXPR;
  71.  
  72. typedef    struct XNODE {
  73.     EXPR            left;
  74.     EXPR            right;
  75.     }                    NODE;
  76.  
  77. typedef    union XSUBVAL {
  78.     struct XSUBST *        val;
  79.     struct XSEXPR *        assgn;
  80.     }                    SUBVAL;
  81.  
  82. typedef    struct XSUBST {
  83.     VARIABLE        vname;
  84.     SUBVAL            back;
  85.     SUBVAL            forw;
  86.     }                    SUBST;
  87.  
  88. typedef    SUBST *                    LSUBST;
  89.  
  90. typedef struct XSEXPR {
  91.     EXPR            sexp;
  92.     SUBVAL            back;
  93.     LSUBST            slist;
  94.     }                    SEXPR;
  95.  
  96. typedef struct {
  97.     struct XALPHASTATE *    pred;
  98.     EXPR            assertion;
  99.     SUBST            subst[1];
  100.     }                    BETASTATE;
  101.  
  102. typedef struct XALPHASTATE {
  103.     BETASTATE *        pred; /* tree pred */
  104.     PAIR            goal;
  105.     PAIR            datb;
  106.     BETASTATE *        back; /* linear pred */
  107.     }                    ALPHASTATE;
  108.  
  109. END OF COMMENT %
  110.  
  111. FALSE    EQU    0
  112. TRUE    EQU    1
  113. EMPTY    EQU    -1        ; empty list
  114. UNDEF    EQU    -2        ; undefined pointer
  115. FROZEN    EQU    -3        ; frozen variable
  116.  
  117. HT    EQU    9
  118. LF    EQU    10
  119. CR    EQU    13
  120. CTLZ    EQU    26
  121.  
  122. CPM    EQU        0000H
  123. BDOS    EQU    CPM+0005H
  124. CDMA    EQU    CPM+0080H
  125. TPA    EQU    CPM+0100H
  126.  
  127. ; -------------- global variables --------------------
  128.  
  129.     DSEG
  130. ;unsigned    symbs = SYMBSZ;
  131. SYMBS::    DW    SYMBSZ
  132. ;unsigned    stacks = STACKSZ;
  133. STACKS:: DW    STACKSZ
  134. ;int        opar;        /* no. of open parentheses */
  135. OPAR::    DS    1
  136. ;char *        stop;        /* top of symbol table */
  137. ;#define    hbot    stop    /* bottom of heap */
  138. HBOT::
  139. STOP::    DS    2
  140. ;char *        hfree;        /* free space in heap */
  141. HFREE::    DS    2
  142. ;char *        htop;        /* top of heap */
  143. HTOP::    DS    2
  144. ;char *    datbtop;        /* top of database */
  145. DBTOP::    DS    2
  146.     CSEG
  147.  
  148. ;main()
  149. MAIN::
  150.     LD    SP,(6)
  151. ;  {
  152. ;  static EXPR e;
  153. ;
  154. ;  init();
  155.     CALL    INIT##
  156. ;  datbtop = hbot;
  157.     LD    HL,(HBOT)
  158.     LD    (DBTOP),HL
  159. ;  while (1)
  160. EP1:
  161. ;    {
  162. ;    hfree = datbtop;
  163.     LD    HL,(DBTOP)
  164.     LD    (HFREE),HL
  165. ;    opar = 0;
  166.     XOR    A
  167.     LD    (OPAR),A
  168. ;    e.list = rdg1();
  169.     CALL    RDG1
  170. ;    if (atomp(e.list) || varp(e.list))
  171.     CALL    ATOMP##
  172.     JR    NZ,EP3
  173.     CALL    VARP##
  174.     JR    Z,EP2
  175. ;      {
  176. EP3:
  177. ;      /* prove */
  178. ;      prove(e.list);
  179.     CALL    PROVE##
  180. ;      continue;
  181.     JR    EP1
  182. ;      }
  183. EP2:
  184. ;    if (!(nelistp(e.list)))
  185.     CALL    NELP##
  186.     JR    NZ,EP4
  187. ;      {
  188. ;      eprint(e.list,empty);
  189. EP5:
  190.     LD    DE,EMPTY
  191.     CALL    EPRINT##
  192. ;      error(" illegal.\r\n");
  193.     LD    HL,EP3MSG
  194.     CALL    ERROR##
  195.     DSEG
  196. EP3MSG:    DB    ' illegal.',CR,LF,0
  197.     CSEG
  198. ;      continue;
  199.     JR    EP1
  200. ;      }
  201. EP4:
  202. ;    if (clausep(e.list))
  203.     CALL    CLP##
  204.     JR    Z,EP5
  205. ;      {
  206. ;      /* add to database */
  207. ;      datbadd(e.list->left.list->left.symbol,e.list);
  208.     PUSH    HL
  209.     CALL    @LEFT##
  210.     CALL    @LEFT##
  211.     POP    DE
  212.     CALL    DBADD##
  213. ;      continue;
  214.     JR    EP1
  215. ;      }
  216. ;EP5: above
  217. ;    /* otherwise */
  218. ;    eprint(e.list,empty);
  219. ;    error(" illegal!\r\n");
  220. ;    }
  221. ;  exit(0);
  222. ;  }
  223.  
  224. ; READ A GOAL
  225. ;
  226. ; input:
  227. ;    none
  228. ; output:
  229. ;    HL -> goal [EXPR]
  230. ;EXPR
  231. ;rdg1()            /* recursive */
  232. ;  {
  233. RDG1::
  234. ;  while (separp(rdchar()))
  235. ;    ;
  236. RD1:
  237.     CALL    RDCHAR##
  238.     CALL    SEPARP
  239.     JR    NZ,RD1
  240. ;  if (character == '(')
  241.     LD    A,(CHR##)
  242.     CP    '('
  243.     JR    NZ,RD2
  244. ;    {
  245. ;    opar++;
  246.     LD    A,(OPAR)
  247.     INC    A
  248.     LD    (OPAR),A
  249. ;    return rdg2();
  250.     JP    RDG2
  251. ;    }
  252. RD2:
  253. ;  else
  254. ;    {
  255. ;    unrdchar();
  256.     CALL    UNRDCH##
  257. ;    return gtoken();
  258.     JP    GTOKEN##
  259. ;    }
  260. ;  }
  261. ;
  262. ;EXPR
  263. ;rdg2()
  264. RDG2:
  265. ;  {
  266. ;  unsigned temp;
  267.     DSEG
  268. TEMP:    DW    0
  269.     CSEG
  270. ;
  271. ;  while (separp(rdchar()))
  272. ;    ;
  273. RD3:
  274.     CALL    RDCHAR##
  275.     CALL    SEPARP
  276.     JR    NZ,RD3
  277. ;  if (character == ')')
  278.     LD    A,(CHR##)
  279.     CP    ')'
  280.     JR    NZ,RD4
  281. ;    {
  282. ;    opar--;
  283.     LD    A,(OPAR)
  284.     DEC    A
  285.     LD    (OPAR),A
  286. ;    return empty;
  287.     LD    HL,EMPTY
  288.     RET
  289. ;    }
  290. RD4:
  291. ;  else if (character == '|')
  292.     CP    '|'
  293.     JR    NZ,RD5
  294. ;    {
  295. ;    temp = rdg1();
  296.     CALL    RDG1            ; recursion
  297.     LD    (TEMP),HL
  298. ;    while (separp(rdchar()))
  299. ;      ;
  300. RD6:
  301.     CALL    RDCHAR##
  302.     CALL    SEPARP
  303.     JR    NZ,RD6
  304. ;    if (!(character == ')'))
  305.     LD    A,(CHR##)
  306.     CP    ')'
  307.     JR    Z,RD7
  308. ;      fatal("\r\nSyntax error.\r\n");
  309.     LD    HL,RD6MSG
  310.     JP    FATAL##
  311.     DSEG
  312. RD6MSG:    DB    CR,LF,'Syntax error.',CR,LF,0
  313.     CSEG
  314. RD7:
  315. ;    opar--;
  316.     LD    A,(OPAR)
  317.     DEC    A
  318.     LD    (OPAR),A
  319. ;    return temp;
  320.     LD    HL,(TEMP)
  321.     RET
  322. ;    }
  323. RD5:
  324. ;  else
  325. ;    {
  326. ;    unrdchar();
  327.     CALL    UNRDCH##
  328. ;    temp = rdg1();
  329.     CALL    RDG1            ; recursion
  330. ;    return makepair(temp,rdg2());
  331.     PUSH    HL
  332.     CALL    RDG2            ; recursion
  333.     EX    DE,HL
  334.     POP    HL
  335.     JP    MKPAIR##
  336. ;    }
  337. ;  }
  338.  
  339. ; SEPARATOR?
  340. ;
  341. ; is it a separator?  also, skip comment in [...]
  342. ; input:
  343. ;    none
  344. ; output:
  345. ;    Z flag set = no
  346. ;BOOLEAN
  347. ;separp()
  348. SEPARP::
  349. ;  {
  350. ;  switch (character)
  351.     LD    A,(CHR##)
  352. ;    {
  353. ;    case '[':
  354.     CP    '['
  355.     JR    NZ,SE1
  356. ;      do
  357. ;        rdchar();
  358. SE2:
  359.     CALL    RDCHAR##
  360.     LD    A,(CHR##)
  361. ;      while (character != ']') ;
  362.     CP    ']'
  363.     JR    NZ,SE2
  364.     JR    RETT
  365. SE1:
  366. ;    case ' ':
  367.     CP    ' '
  368.     JR    Z,RETT
  369. ;    case '\r':
  370.     CP    CR
  371.     JR    Z,RETT
  372. ;    case '\n':
  373.     CP    LF
  374.     JR    Z,RETT
  375. ;    case '\t':
  376.     CP    HT
  377.     JR    NZ,RETF
  378. ;      return TRUE;
  379. RETT:
  380.     OR    A
  381.     RET
  382. ;    default:
  383. ;      return FALSE;
  384. RETF:
  385.     XOR    A
  386.     RET
  387. ;    }
  388. ;  }
  389.  
  390. ; 16 bit compare
  391. ;
  392. ; input:
  393. ;    HL , DE
  394. ; output:
  395. ;    C, Z flags
  396. ; AF destroyed, others saved
  397. CPHL::    XOR    A        ; NC
  398.     PUSH    HL
  399.     SBC    HL,DE
  400.     POP    HL
  401.     RET
  402.  
  403.     END    MAIN
  404.