home *** CD-ROM | disk | FTP | other *** search
/ Oakland CPM Archive / oakcpm.iso / cpm / prolog / epro23.ark / UNIFY.MAC < prev    next >
Encoding:
Text File  |  1986-11-02  |  6.4 KB  |  412 lines
  1.  
  2. ; ===========================================================
  3. ; UNIFY.Z80
  4. ;    unify routine for E-Prolog
  5. ;    June 10, 1985
  6.  
  7.     .Z80
  8.  
  9. FALSE    EQU    0
  10. TRUE    EQU    1
  11. EMPTY    EQU    -1
  12. UNDEF    EQU    -2
  13. FROZEN    EQU    -3
  14.  
  15. DEBUG    EQU    FALSE
  16.  
  17. HT    EQU    9
  18. LF    EQU    10
  19. CR    EQU    13
  20. CTLZ    EQU    26
  21.  
  22. CPM    EQU        0000H
  23. BDOS    EQU    CPM+0005H
  24. CDMA    EQU    CPM+0080H
  25. TPA    EQU    CPM+0100H
  26.  
  27. ;SUBVAL
  28. ;value(v)
  29. ;  SUBST * v;
  30. ;  {
  31. ;  SUBST * u;
  32. ;
  33. VALUE::
  34.     PUSH    HL        ; v
  35. ;  while (substp(v) && ((u = v->forw.val) != (SUBST *)UNDEF))
  36. VA2:    CALL    SUBSTP##    ; substp(v) ?
  37.     JR    Z,VA1
  38.     CALL    @FORW##        ; u = v->forw
  39.     LD    DE,UNDEF
  40.     CALL    CPHL##        ; u == UNDEF ?
  41.     JR    Z,VA1
  42. ;    {
  43. ;    v = u;
  44.     POP    DE        ; discard
  45.     PUSH    HL        ; v
  46. ;    }
  47.     JR    VA2
  48. VA1:
  49. ;  return v;
  50.     POP    HL        ; v
  51.     RET
  52. ;  }
  53.  
  54. ;LSUBST
  55. ;vf(var,lsub)
  56. ;/* find variable */
  57. ;  VARIABLE var;
  58. ;  LSUBST lsub;
  59.     DSEG
  60. VAR:    DW    0
  61. LSUB:    DW    0
  62.     CSEG
  63. ;  {
  64. VF::
  65.     LD    (VAR),HL
  66.     LD    (LSUB),DE
  67. ;  for ( ; var != (*lsub).vname ; lsub++)
  68.     EX    DE,HL
  69. VF1:
  70.     CALL    @VNAME##
  71.     LD    DE,(VAR)
  72.     CALL    CPHL##
  73.     JR    Z,VF2
  74. ;#ifdef DEBUG
  75. IF DEBUG
  76. ;    if (! varp((*lsub).vname))
  77.     CALL    VARP##
  78.     JR    NZ,VF3
  79. ;      fatal("\r\nFaulty subststitution list.")
  80.     LD    HL,VF3MSG
  81.     JP    FATAL##
  82.     DSEG
  83. VF3MSG:    DB    CR,LF,'Faulty substitution list.',0
  84.     CSEG
  85. VF3:
  86. ;#endif
  87. ENDIF
  88. ;    ;
  89.     LD    HL,(LSUB)
  90.     LD    DE,6
  91.     ADD    HL,DE
  92.     LD    (LSUB),HL
  93.     JR    VF1
  94. VF2:
  95. ;  return lsub;
  96.     LD    HL,(LSUB)
  97.     RET
  98. ;  }
  99.  
  100. ; UNIFY
  101. ;
  102. ; recursive
  103. ; input:
  104. ;    HL "low" expression
  105. ;    DE lsubst for HL
  106. ;    HL' "high" expression
  107. ;    DE' lsubst for HL'
  108. ; output
  109. ;    Z flag set = failure
  110. ;BOOLEAN
  111. ;unify(lowe,lows,hie,his)    /* recursive */
  112. ;  EXPR lowe;
  113. ;  LSUBST lows;
  114. ;  EXPR hie;
  115. ;  LSUBST his;
  116. ;  {
  117. ;  EXPR lowex;
  118. ;  EXPR hiex;
  119. ;  SUBVAL vfl;
  120. ;  SUBVAL vfh;
  121. ;  LSUBST temp;
  122.     DSEG
  123. LOWEX:    DW    0
  124. HIEX:    DW    0
  125. LOWS:    DW    0
  126. HIS:    DW    0
  127. VFL:    DW    0
  128. VFH:    DW    0
  129.     CSEG
  130. ;
  131. ;  lowex.list = lowe;
  132. ;  hiex.list = hie;    /* synonyms */
  133. UNIFY::
  134.     LD    (LOWEX),HL
  135.     LD    (LOWS),DE
  136.     EXX
  137.     LD    (HIEX),HL
  138.     LD    (HIS),DE
  139. IF DEBUG
  140.     PUSH    HL
  141.     LD    HL,UNMSG1
  142.     CALL    MSG##
  143.     LD    HL,(LOWEX)
  144.     LD    DE,(LOWS)
  145.     CALL    EPRINT##
  146.     LD    HL,UNMSG2
  147.     CALL    MSG##
  148.     LD    HL,(HIEX)
  149.     LD    DE,(HIS)
  150.     CALL    EPRINT##
  151.     DSEG
  152. UNMSG1:    DB    CR,LF,' ++Unify ',0
  153. UNMSG2:    DB    ' with ',0
  154.     CSEG
  155.     POP    HL
  156. ENDIF
  157. ;
  158. ;  if (varp(hie))
  159.     CALL    VARP##
  160.     JR    Z,UN1
  161. ;    {
  162. ;    vfh.val = value(vf(hiex.symbol,his));
  163.     LD    DE,(HIS)
  164.     CALL    VF
  165.     CALL    VALUE
  166.     LD    (VFH),HL
  167. ;    if (! substp(vfh.val))
  168.     CALL    SUBSTP
  169.     JR    NZ,UN1
  170. ;      return unify(lowe,lows,
  171. ;                   vfh.assgn->sexp.list,vfh.assgn->slist);
  172.     LD    HL,(VFH)
  173.     CALL    @SLIST##
  174.     PUSH    HL
  175.     LD    HL,(VFH)
  176.     CALL    @EXPR
  177.     POP    DE
  178.     EXX
  179.     JR    UNIFY        ; tail recursion
  180. ;    }
  181. ;
  182. UN1:
  183. ;  if (varp(lowe))
  184.     LD    HL,(LOWEX)
  185.     CALL    VARP##
  186.     JP    Z,UN2
  187. ;    {
  188. ;    vfl.val = value(vf(lowex.symbol,lows));
  189.     LD    DE,(LOWS)
  190.     CALL    VF
  191.     CALL    VALUE
  192.     LD    (VFL),HL
  193. ;    if (substp(vfl.val))
  194.     CALL    SUBSTP##
  195.     JP    Z,UN3
  196. ;      {
  197. ;      if (varp(hie))
  198.     LD    HL,(HIEX)
  199.     CALL    VARP##
  200.     JR    Z,UN4
  201. ;        {
  202. ;        /* both are really variables */
  203. ;        if (vfh == vfl)
  204. ;          return TRUE;
  205.     LD    HL,(VFH)
  206.     LD    DE,(VFL)
  207.     CALL    CPHL##
  208.     JR    Z,RETT
  209. ;        if (vfl.val > vfh.val)
  210.     JR    NC,UN7
  211. ;          {
  212. ;          temp = vfh.val;
  213.     LD    HL,(VFH)
  214.     PUSH    HL
  215. ;          vfh.val = vfl.val;
  216.     LD    HL,(VFL)
  217.     LD    (VFH),HL
  218. ;          vfl.val = temp;
  219.     POP    HL
  220.     LD    (VFL),HL
  221. ;          }
  222. UN7:
  223. ;        if (vfh.val->back.val != (SUBST *)UNDEF)
  224.     LD    HL,(VFH)
  225.     CALL    @BACK##
  226.     LD    DE,UNDEF
  227.     CALL    CPHL##
  228.     JR    Z,UN8
  229. ;          {
  230. ;          x = vfh->forw = makesexpr(vfh->vname,vfh,UNDEF)
  231.     LD    HL,(VFH)
  232.     PUSH    HL
  233.     CALL    @VNAME##
  234.     POP    DE
  235.     LD    BC,UNDEF
  236.     CALL    MKSEXPR##
  237.     EX    DE,HL
  238.     PUSH    DE
  239.     LD    HL,(VFH)
  240.     CALL    @LFORW##
  241. ;          vfh = x->forw = makesexpr(vfh->vname,UNDEF,UNDEF)
  242.     LD    HL,(VFH)
  243.     CALL    @VNAME##
  244.     LD    DE,UNDEF
  245.     LD    C,E
  246.     LD    B,D
  247.     CALL    MKSEXPR##
  248.     LD    (VFH),HL
  249.     EX    DE,HL
  250.     POP    HL
  251.     CALL    @LFORW##
  252. ;          }
  253. UN8:
  254. ;        vfh.val->back.val = vfl.val;
  255.     LD    HL,(VFH)
  256.     LD    DE,(VFL)
  257.     CALL    @LBACK##
  258. ;        vfl.val->forw.val = vfh.val;
  259.     LD    HL,(VFL)
  260.     LD    DE,(VFH)
  261.     CALL    @LFORW##
  262. ;        return TRUE;
  263. RETT:    LD    A,1
  264.     OR    A
  265.     RET
  266. ;        }
  267. ;UN6    EQU    UN2
  268. UN4:
  269. ;      else
  270. ;        {
  271. ;        vfl.val->forw.assgn = makesexpr(hie,vfl.val,his);
  272.     LD    HL,(HIEX)
  273.     LD    DE,(VFL)
  274.     LD    BC,(HIS)
  275.     CALL    MKSEXPR##
  276.     EX    DE,HL
  277.     LD    HL,(VFL)
  278.     CALL    @LFORW##
  279. ;        return TRUE;
  280.     JR    RETT
  281. ;        }
  282. ;      }
  283. ;UN5    EQU    UN2
  284. UN3:
  285. ;    else
  286. ;      return unify(vfl.assgn->sexp.list,vfl.assgn->slist,
  287. ;                   hie,his);
  288.     LD    HL,(HIEX)
  289.     LD    DE,(HIS)
  290.     EXX
  291.     LD    HL,(VFL)
  292.     CALL    @SLIST##
  293.     PUSH    HL
  294.     LD    HL,(VFL)
  295.     CALL    @EXPR##
  296.     POP    DE
  297.     JP    UNIFY        ; tail recursion
  298. ;    }
  299. ;
  300. UN2:
  301. UN5    EQU    UN2
  302. UN6    EQU    UN2
  303. ;  if (nelistp(lowex.list))
  304.     LD    HL,(LOWEX)
  305.     CALL    NELP##
  306.     JR    Z,UN9
  307. ;    {
  308. ;    if (varp(hie))
  309.     LD    HL,(HIEX)
  310.     CALL    VARP##
  311.     JR    Z,UN10
  312. ;      {
  313. ;      vfh.val->forw.assgn = makesexpr(lowe,vfh.val,lows);
  314.     LD    HL,(LOWEX)
  315.     LD    DE,(VFH)
  316.     LD    BC,(LOWS)
  317.     CALL    MKSEXPR##
  318.     EX    DE,HL
  319.     LD    HL,(VFH)
  320.     CALL    @LFORW##
  321. ;      return TRUE;
  322.     JP    RETT
  323. ;      }
  324. UN10:
  325. ;    else if (nelistp(hie))
  326.     LD    HL,(HIEX)
  327.     CALL    NELP##
  328.     JR    Z,UN11
  329. ;      {
  330. ;      return (unify(lowex.list->left.list,lows,
  331. ;                     hiex.list->left.list,his) &&
  332. ;              unify(lowex.list->right.list,lows,
  333. ;                     hiex.list->right.list,his));
  334.     LD    HL,(HIEX)
  335.     PUSH    HL
  336.     CALL    @LEFT##
  337.     LD    DE,(HIS)
  338.     PUSH    DE
  339.     EXX
  340.     LD    HL,(LOWEX)
  341.     PUSH    HL
  342.     CALL    @LEFT##
  343.     LD    DE,(LOWS)
  344.     PUSH    DE
  345.     CALL    UNIFY        ; recursion
  346.     JR    Z,UN12
  347.     POP    DE
  348.     POP    HL
  349.     PUSH    DE
  350.     CALL    @RIGHT##
  351.     POP    DE
  352.     EXX
  353.     POP    DE
  354.     POP    HL
  355.     PUSH    DE
  356.     CALL    @RIGHT##
  357.     POP    DE
  358.     EXX
  359.     JP    UNIFY        ; tail recursion
  360. ;      }
  361. UN12:
  362.     POP    HL
  363.     POP    HL
  364.     POP    HL
  365.     POP    HL
  366. UN11:
  367. ;    else /* hie is symbol or number or empty */
  368. ;      {
  369. ;      return FALSE;
  370. RETF:
  371.     XOR    A
  372.     RET
  373. ;      }
  374. ;    }
  375. UN9:
  376. ;  else /* lowex is symbol or number or empty */
  377. ;    {
  378. ;    if (varp(hie))
  379.     LD    HL,(HIEX)
  380.     CALL    VARP##
  381.     JR    Z,UN13
  382. ;      {
  383. ;      vfh.val->forw.assgn = makesexpr(lowe,vfh.val,lows);
  384.     LD    HL,(LOWEX)
  385.     LD    DE,(VFH)
  386.     LD    BC,(LOWS)
  387.     CALL    MKSEXPR##
  388.     EX    DE,HL
  389.     LD    HL,(VFH)
  390.     CALL    @LFORW##
  391. ;      return TRUE;
  392.     JP    RETT
  393. ;      }
  394. UN13:
  395. ;    else if (nelistp(hie))
  396. ;      return FALSE;
  397.     CALL    NELP
  398.     JR    NZ,RETF
  399. ;    else /* hie is symbol or number or empty */
  400. ;      {
  401. ;      return (hiex.list == lowex.list);
  402.     LD    DE,(LOWEX)
  403.     CALL    CPHL##
  404.     JP    Z,RETT
  405.     JR    RETF
  406. ;      }
  407. ;    }
  408. ;  }
  409.  
  410.     END
  411.  
  412.