home *** CD-ROM | disk | FTP | other *** search
/ CP/M / CPM_CDROM.iso / cpm / languags / prolog / epro23.ark / CMD.MAC < prev    next >
Text File  |  1986-11-02  |  14KB  |  860 lines
  1.  
  2. ; ===========================================================
  3. ; CMD.Z80
  4. ;    built-in commands for E-Prolog
  5. ;    June 1, 1985
  6.  
  7.     .Z80
  8.  
  9. FALSE    EQU    0
  10. TRUE    EQU    1
  11. EMPTY    EQU    -1
  12. UNDEF    EQU    -2
  13.  
  14. HT    EQU    9
  15. LF    EQU    10
  16. CR    EQU    13
  17. CTLZ    EQU    26
  18.  
  19. CPM    EQU        0000H
  20. BDOS    EQU    CPM+0005H
  21. CDMA    EQU    CPM+0080H
  22. TPA    EQU    CPM+0100H
  23.  
  24. ; compare with given value
  25. ;
  26. ?CPHL    MACRO    ?VALUE
  27.     PUSH    DE
  28.     LD    DE,?VALUE
  29.     CALL    CPHL##
  30.     POP    DE
  31.     ENDM
  32.  
  33. ; copy string
  34. ;
  35. ; input:
  36. ;    HL -> source
  37. ; all registers destroyed
  38. ?COPY    MACRO    ?ADDR
  39.     LD    DE,?ADDR
  40.     CALL    COPY##
  41.     ENDM
  42.  
  43. ; local storage
  44.     DSEG
  45. LOCST:    DS    8
  46. REST    EQU    LOCST
  47. LS    EQU    LOCST+2
  48. X    EQU    LOCST+4
  49. Y    EQU    LOCST+6
  50. SV    EQU    LOCST+4
  51. PTR    EQU    LOCST
  52. LSS    EQU    LS
  53. X1    EQU    LOCST+4
  54. X2    EQU    LOCST+6
  55.     CSEG
  56.  
  57. ;noretry(ast)
  58. ;  ALPHASTATE * ast;
  59. ;  {
  60. ;  ast->datb = (PAIR)empty;
  61. ;  }
  62. NORE::
  63.     LD    HL,EMPTY
  64.  
  65. ;setretry(ast,addr)
  66. ;  ALPHASTATE * ast;
  67. ;  char * addr;
  68. ;  {
  69. ;  ast->datb = (PAIR *)addr;
  70. ;  }
  71. SETRE::
  72.     JP    XLDATB##
  73.  
  74. ;SYMBOL *
  75. ;vnext(pexp,plsub)
  76. ;  EXPR * pexp;
  77. ;  LSUBST * plsub;
  78. ;  {
  79. ;  SYMBOL * x;
  80. ;  SEXPR * y;
  81.     DSEG
  82. PEXP:    DW    0
  83. PLSUB:    DW    0
  84. VX:    DW    0
  85. VY:    DW    0
  86.     CSEG
  87. VNEXT::
  88.     LD    (PEXP),HL
  89.     LD    (PLSUB),DE
  90. ;
  91. ;  if (varp(pexp->list))
  92.     CALL    INDIR##
  93.     CALL    VARP##
  94.     JR    Z,VN1
  95. ;    {
  96. ;    y = value(vf(pexp->list,*plsub));
  97.     PUSH    HL
  98.     LD    HL,(PLSUB)
  99.     CALL    INDIR##
  100.     EX    DE,HL
  101.     POP    HL
  102.     CALL    VF##
  103.     CALL    VALUE##
  104.     LD    (VY),HL
  105. ;    if (substp(y))
  106.     CALL    SUBSTP##
  107.     JR    Z,VN2
  108. ;      return UNDEF;
  109.     LD    HL,UNDEF
  110.     RET
  111. VN2:
  112. ;    pexp->list = y->sexp.list;
  113.     CALL    @EXPR##
  114.     EX    DE,HL
  115.     LD    HL,(PEXP)
  116.     LD    (HL),E
  117.     INC    HL
  118.     LD    (HL),D
  119. ;    *plsub = y->slist;
  120.     LD    HL,(VY)
  121.     CALL    @SLIST##
  122.     EX    DE,HL
  123.     LD    HL,(PLSUB)
  124.     LD    (HL),E
  125.     INC    HL
  126.     LD    (HL),D
  127. ;    }
  128. VN1:
  129. ;  if (nelistp(pexp->list))
  130.     LD    HL,(PEXP)
  131.     CALL    INDIR##
  132.     CALL    NELP##
  133.     JR    Z,VN3
  134. ;    {
  135. ;    x = pexp->list->left.symbol;
  136.     CALL    @LEFT##
  137.     LD    (VX),HL
  138. ;    if (varp(x))
  139.     CALL    VARP##
  140.     JR    Z,VN4
  141. ;      {
  142. ;      y = value(vf(x,*plsub));
  143.     PUSH    HL
  144.     LD    HL,(PLSUB)
  145.     CALL    INDIR##
  146.     EX    DE,HL
  147.     POP    HL
  148.     CALL    VF##
  149.     CALL    VALUE##
  150.     LD    (VY),HL
  151. ;      x = y->sexp.symbol;
  152.     CALL    @EXPR##
  153.     LD    (VX),HL
  154. ;      if (varp(x))
  155.     CALL    VARP##
  156.     JR    Z,VN4
  157. ;        x = y;
  158.     LD    HL,(VY)
  159.     LD    (VX),HL
  160. ;      }
  161. VN4:
  162. ;    pexp->list = pexp->list->right.list;
  163.     LD    HL,(PEXP)
  164.     PUSH    HL
  165.     CALL    INDIR##
  166.     CALL    @RIGHT##
  167.     EX    DE,HL
  168.     POP    HL
  169.     LD    (HL),E
  170.     INC    HL
  171.     LD    (HL),D
  172. ;    return x;
  173.     LD    HL,(VX)
  174.     RET
  175. ;    }
  176. VN3:
  177. ;  return UNDEF;
  178.     LD    HL,UNDEF
  179.     RET
  180. ;  }
  181.  
  182. RETT::    LD    HL,TRUE
  183. RETX:    LD    A,H
  184.     OR    L
  185.     RET
  186. RETF::    LD    HL,FALSE
  187.     JR    RETX
  188.  
  189. ;built-in commands called in this form:
  190. ;    f(rest,ast,ls,pbst)
  191. ;    PAIR rest;        (in HL) rest of atom
  192. ;    ALPHASTATE * ast;    (in IX) this state
  193. ;    LSUBST ls;        (in DE ) substs for rest
  194. ;    BETASTATE * bst;    (in IY) empty, at first
  195. ;
  196. ;return TRUE to succeed, return FALSE to fail
  197. ;call noretry() to prohibit further retries
  198. ;call setretry() to set entry point for next retry
  199.  
  200. ; ====================  /  ====================
  201. ;_cut(rest,ast,ls,pbst)
  202. ;  PAIR rest;
  203. ;  ALPHASTATE * ast;
  204. ;  LSUBST ls;
  205. ;  BETASTATE ** pbst;
  206. ;  {
  207. ;  setretry(ast,&rcut);
  208. ;  return TRUE;
  209. ;  }
  210. _CUT::
  211.     LD    HL,RCUT
  212.     CALL    SETRE
  213.     JP    RETT
  214.  
  215. ;rcut()        /* retry of cut */
  216. ;  {
  217. ;  return EMPTY;
  218. ;  }
  219. RCUT::
  220.     LD    HL,EMPTY
  221.     LD    A,H
  222.     OR    L
  223.     RET
  224.  
  225. ; ==================== APPEND ====================
  226. ; APPEND command
  227. ;
  228. ; open file for output, position to the end of the file
  229. _APPEN::
  230.     PUSH    HL
  231.     PUSH    DE
  232.     CALL    NORE
  233.     CALL    CLOSE##        ; close existing output file
  234.     POP    DE
  235.     POP    HL
  236.     CALL    DOOUT##
  237.     LD    A,(OUTF##)
  238.     DEC    A
  239.     JP    NZ,RETT        ; not disk file
  240.     LD    DE,OUTFCB##
  241.     LD    C,15        ; open file
  242.     CALL    BDOS
  243.     INC    A
  244.     JR    NZ,APPEN1
  245.     LD    (OUTF),A    ; not found, revert to console
  246.     JP    RETF
  247. APPEN1:    LD    DE,OUTFCB##
  248.     LD    C,35        ; compute file size
  249.     CALL    BDOS
  250.     LD    HL,(OUTFCB##+33) ; random record number
  251.     DEC    HL
  252.     LD    (OUTFCB##+33),HL ; last existing record
  253.     LD    DE,OUTDMA##
  254.     LD    C,26        ; set DMA
  255.     CALL    BDOS
  256.     LD    DE,OUTFCB##
  257.     LD    C,33        ; read random
  258.     CALL    BDOS
  259.     LD    HL,OUTDMA##
  260. APPEN2:    LD    A,(HL)
  261.     CP    CTLZ
  262.     JR    Z,APPEN3
  263.     INC    HL
  264.     ?CPHL    OUTE##
  265.     JR    NZ,APPEN2
  266.     LD    DE,OUTFCB##    ; read sequential to prepare
  267.     LD    C,20        ;  next record field
  268.     CALL    BDOS
  269.     LD    HL,OUTE##
  270. APPEN3:    LD    (OUTP),HL
  271.     JP    RETT
  272.  
  273. ; ==================== CLOSE ====================
  274. ;_close(rest,ast)
  275. ;  PAIR rest;
  276. ;  ALPHASTATE * ast;
  277. ;  {
  278. ;  noretry(ast);
  279. ;  close();
  280. ;  }
  281.  
  282. _CLOSE::
  283.     CALL    NORE
  284. CLOSEX:    CALL    CLOSE##
  285.     JP    RETT
  286.  
  287. ; ==================== CREATE ====================
  288. ; CREATE command
  289. ;
  290. ; opens a new file as output
  291. ; deletes any existing file with the same name
  292. ; (cf. APPEND command)
  293. _CREA::
  294.     PUSH    HL
  295.     PUSH    DE
  296.     CALL    NORE
  297.     CALL    CLOSE##        ; close existing output file
  298.     POP    DE
  299.     POP    HL
  300.     CALL    DOOUT##
  301.     CALL    SAVEX
  302.     JP    RETT
  303.  
  304. ; ==================== FAIL ====================
  305. ;_fail()
  306. ;  {
  307. ;  return FALSE;
  308. ;  }
  309. _FAIL::
  310.     JP    RETF
  311.  
  312. ; ==================== LESS ====================
  313. ;_less(rest,ast,ls,pbst)
  314. ;  PAIR rest;
  315. ;  ALPHASTATE * ast;
  316. ;  LSUBST ls;
  317. ;  BETASTATE ** pbst;
  318. ;  {
  319. ;  static EXPR x1;
  320. ;  static EXPR x2;
  321. ;  static LSUBST lss;
  322. _LESS::
  323. ;
  324. ;  lss = ls;
  325.     LD    (REST),HL
  326.     LD    (LSS),DE
  327. ;  noretry(ast);
  328.     CALL    NORE
  329. ;  x1.list = vnext(&rest,&lss);
  330.     LD    HL,REST
  331.     LD    DE,LSS
  332.     CALL    VNEXT
  333.     LD    (X1),HL
  334. ;  if (x1.list == UNDEF)
  335. ;    return FALSE;
  336.     ?CPHL    UNDEF
  337.     JP    Z,RETF
  338. ;  x2.list = vnext(&rest,&lss);
  339.     LD    HL,REST
  340.     LD    DE,LSS
  341.     CALL    VNEXT
  342.     LD    (X2),HL
  343. ;  if (x2.list == UNDEF)
  344. ;    return FALSE;
  345.     ?CPHL    UNDEF
  346.     JP    Z,RETF
  347. ;  if (numbp(x1.number) && numbp(x2.number))
  348. ;    return (x1.number < x2.number);
  349.     LD    HL,(X1)
  350.     CALL    NUMBP##
  351.     JR    Z,LE1
  352.     LD    HL,(X2)
  353.     CALL    NUMBP##
  354.     JR    Z,LE1
  355.     LD    HL,(X1)
  356.     LD    DE,(X2)
  357.     CALL    CPHL##
  358.     JP    C,RETT
  359.     JP    RETF
  360. LE1:
  361. ;  if (symbp(x1.symbol) && symbp(x2.symbol))
  362. ;    return (strcmp(x1.symbol->string,x2.symbol->string) < 0);
  363.     LD    HL,(X1)
  364.     CALL    SYMBP##
  365.     JR    Z,LE2
  366.     LD    HL,(X2)
  367.     CALL    SYMBP##
  368.     JR    Z,LE2
  369.     LD    HL,(X2)
  370.     CALL    @STR##
  371.     PUSH    HL
  372.     LD    HL,(X1)
  373.     CALL    @STR##
  374.     POP    DE
  375.     CALL    STRCMP##
  376.     JP    C,RETT
  377.     JP    RETF
  378. LE2:
  379. ;  *pbst = makebeta(ast,empty);
  380.     LD    HL,EMPTY
  381.     CALL    MKBETA##
  382. ;  if (substp(x1.symbol))
  383.     LD    HL,(X1)
  384.     CALL    SUBSTP##
  385.     JR    Z,LE3
  386. ;    {
  387. ;    setretry(ast,&rless);
  388.     LD    HL,RLESS
  389.     CALL    SETRE
  390. ;    if (numbp(x2.number))
  391.     LD    HL,(X2)
  392.     CALL    NUMBP##
  393.     JR    Z,LE5
  394. ;      {
  395. ;      lessv(x2.number-1,x1.symbol);
  396.     LD    HL,(X2)
  397.     DEC    HL
  398.     LD    DE,(X1)
  399.     CALL    LESSV
  400. ;      return TRUE;
  401.     JP    RETT
  402. ;      }
  403. LE5:
  404. ;    if (substp(x2.symbol))
  405.     LD    HL,(X2)
  406.     CALL    SUBSTP##
  407.     JP    Z,LE6
  408. ;      {
  409. ;      lessv(0,x1.symbol);
  410.     LD    HL,0
  411.     LD    DE,(X1)
  412.     CALL    LESSV
  413. ;      lessv(1,x2.symbol);
  414.     LD    HL,1
  415.     LD    DE,(X2)
  416.     CALL    LESSV
  417. ;      return TRUE;
  418.     JP    RETT
  419. ;      }
  420. LE6    EQU    RETF
  421. ;    }
  422. LE3:
  423. ;  else if (substp(x2.symbol))
  424.     LD    HL,(X2)
  425.     CALL    SUBSTP##
  426.     JP    Z,LE4
  427. ;    {
  428. ;    setretry(ast,&rless);
  429.     LD    HL,RLESS
  430.     CALL    SETRE
  431. ;    if (numbp(x1.number))
  432.     LD    HL,(X1)
  433.     CALL    NUMBP##
  434.     JP    Z,LE4
  435. ;      {
  436. ;      lessv(x1.number+1,x2.symbol);
  437.     LD    HL,(X1)
  438.     INC    HL
  439.     LD    DE,(X2)
  440.     CALL    LESSV
  441. ;      return TRUE;
  442.     JP    RETT
  443. ;      }
  444. ;    }
  445. LE4    EQU    RETF
  446. ;  return FALSE;
  447. ;  }
  448. ;
  449. ;rless()
  450. RLESS:            ; needs more work to do retries
  451. ;  {
  452. ;  fatal("\r\nRetry on LESS.");
  453.     LD    HL,RLMSG
  454.     JP    FATAL##
  455.     DSEG
  456. RLMSG:    DB    CR,LF,'Retry on LESS.',0
  457.     CSEG
  458. ;  }
  459. ;
  460. ;lessv(val,sub)
  461. ;  NUMBER val;
  462. ;  SUBST * sub;
  463. ;  {
  464. ;  unify(val,empty,sub->vname,sub);
  465. LESSV:
  466.     PUSH    DE
  467.     LD    DE,EMPTY
  468.     EXX
  469.     POP    HL
  470.     PUSH    HL
  471.     CALL    @VNAME##
  472.     POP    DE
  473.     EXX
  474.     JP    UNIFY##
  475. ;  }
  476.  
  477. ; ==================== LIST ====================
  478. ;_list(rest,ast)
  479. ;  PAIR rest;
  480. ;  ALPHASTATE * ast;
  481. ;  {
  482. _LIST::
  483. ;  noretry(ast);
  484.     CALL    NORE
  485. ;  listt((SYMBOL *)sbot);
  486. LISTX:    LD    HL,(SBOT##)
  487.     CALL    LISTT
  488. ;  return TRUE;
  489.     JP    RETT
  490. ;  }
  491. ;
  492. ;listt(ptr)    /* recursive */
  493. ;  SYMBOL * ptr;
  494. ;  {
  495. ;  PAIR x;
  496. LISTT:
  497.     LD    (PTR),HL
  498. ;
  499. ;  if (ptr != (SYMBOL *)empty)
  500.     ?CPHL    EMPTY
  501.     RET    Z
  502. ;    {
  503. ;    listt(ptr->lptr);
  504.     LD    HL,(PTR)
  505.     PUSH    HL
  506.     CALL    @LPTR##
  507.     CALL    LISTT        ; recursive
  508.     POP    HL
  509.     LD    (PTR),HL
  510. ;    if (nelistp(x = (PAIR)(ptr->addr)))
  511.     CALL    @ADDR##
  512.     LD    (X),HL
  513.     CALL    NELP##
  514.     JR    Z,LI1
  515. ;      {
  516. ;      do
  517. LI2:
  518. ;        {
  519. ;        listpr(x->left.list);
  520.     LD    HL,(X)
  521.     CALL    @LEFT##
  522.     CALL    LISTPR
  523. ;        }
  524. ;      while (nelistp(x = x->right.list)) ;
  525.     LD    HL,(X)
  526.     CALL    @RIGHT##
  527.     LD    (X),HL
  528.     CALL    NELP##
  529.     JR    NZ,LI2
  530. ;      chrout('\r');
  531. ;      chrout('\n');
  532.     CALL    CRLF##
  533. ;      }
  534. LI1:
  535. ;    listt(ptr->rptr);
  536.     LD    HL,(PTR)
  537.     CALL    @RPTR##
  538.     JR    LISTT        ; tail recursion
  539. ;    }
  540. ;  }
  541. ;
  542. ;listpr(y)
  543. ;  PAIR y;
  544. ;  {
  545. LISTPR:
  546.     LD    (Y),HL
  547. ;  chrout('(');
  548.     LD    A,'('
  549.     CALL    CHROUT##
  550. ;  eprint(y->left.list,empty);
  551.     LD    HL,(Y)
  552.     CALL    @LEFT##
  553.     LD    DE,EMPTY
  554.     CALL    EPRINT##
  555. ;  for (y = y->right.list ; nelistp(y) ; y = y->right.list)
  556. ;    {
  557. LI4:
  558.     LD    HL,(Y)
  559.     CALL    @RIGHT##
  560.     LD    (Y),HL
  561.     CALL    NELP##
  562.     JR    Z,LI3
  563. ;    msg("\r\n\t");
  564.     LD    HL,LI4MSG
  565.     DSEG
  566. LI4MSG:    DB    CR,LF,HT,0
  567.     CSEG
  568.     CALL    MSG##
  569. ;    eprint(y->left.list,empty);
  570.     LD    HL,(Y)
  571.     CALL    @LEFT
  572.     LD    DE,EMPTY
  573.     CALL    EPRINT##
  574. ;    }
  575.     JR    LI4
  576. LI3:
  577. ;  msg(")\r\n");
  578.     LD    HL,LI3MSG
  579.     DSEG
  580. LI3MSG:    DB    ')',CR,LF,0
  581.     CSEG
  582.     JP    MSG##
  583. ;  }
  584.  
  585. ; ==================== LOAD ====================
  586. ; LOAD command
  587. ;
  588. ; load from given disk file
  589. ; default filetype 'PRO'
  590. _LOAD::
  591.     CALL    DOIN##
  592.     CALL    NORE
  593.     LD    A,(INF##)
  594.     DEC    A
  595.     JP    NZ,RETT        ; not a disk file
  596.     LD    A,(INFCB##+9)
  597.     CP    ' '        ; no filetype?
  598.     JR    NZ,LOAD1
  599.     LD    HL,APRO##    ; use default 'PRO'
  600.     ?COPY    INFCB##+9
  601. LOAD1:    JP    LOADX
  602.  
  603. ; ==================== OPEN ====================
  604. ; OPEN command
  605. ;
  606. ; opens an existing file as input
  607. _OPEN::
  608.     CALL    DOIN##
  609.     CALL    NORE
  610.     LD    A,(INF##)
  611.     DEC    A
  612.     JP    NZ,RETT        ; not a disk file
  613. LOADX:    LD    DE,INFCB##
  614.     LD    C,15        ; open file
  615.     CALL    BDOS
  616.     INC    A        ; file found?
  617.     JR    NZ,OPEN1    ; yes
  618.     XOR    A
  619.     LD    (INF##),A
  620.     JP    RETF
  621. OPEN1:    XOR    A
  622.     LD    (INFCB##+32),A    ; zero current record
  623.     LD    HL,INE##    ; pointer beyond end
  624.     LD    (INP##),HL
  625.     JP    RETT
  626.  
  627. ; ====================  READ  ====================
  628. ;_read(rest,ast,ls,pbst)
  629. ;  PAIR rest;
  630. ;  ALPHASTATE * ast;
  631. ;  LSUBST ls;
  632. ;  BETASTATE ** pbst;
  633. ;  {
  634. ;  PAIR x;
  635. _READ::
  636.     LD    (REST),HL
  637.     LD    (LS),DE
  638. ;  noretry(ast);
  639.     CALL    NORE
  640. ;  x = makepair(gtoken(),empty);
  641.     CALL    GTOKEN##
  642.     JR    READX
  643.  
  644. ; ====================  READCHAR  ====================
  645. ;_readc(rest,ast,ls,pbst)
  646. ;  PAIR rest;
  647. ;  ALPHASTATE * ast;
  648. ;  LSUBST ls;
  649. ;  BETASTATE ** pbst;
  650. ;  {
  651. ;  PAIR x;
  652. ;
  653. _READC::
  654.     LD    (REST),HL
  655.     LD    (LS),DE
  656. ;  noretry(ast);
  657.     CALL    NORE
  658. ;  rdchar();
  659.     CALL    RDCHAR##
  660. ;  x = makepair(character,empty);
  661.     LD    A,(CHR##)
  662.     LD    L,A
  663.     LD    H,0
  664. READX:    LD    DE,EMPTY
  665.     CALL    MKPAIR##
  666.     LD    (X),HL
  667. ;  *pbst = makebeta(ast,empty);
  668.     LD    HL,EMPTY
  669.     CALL    MKBETA##
  670. ;  if (unify(rest,ls,x,empty))
  671. ;    return TRUE;
  672.     LD    HL,(X)
  673.     LD    DE,EMPTY
  674.     EXX
  675.     LD    HL,(REST)
  676.     LD    DE,(LS)
  677.     CALL    UNIFY##
  678.     JP    NZ,RETT
  679. ;  release(x);
  680.     LD    HL,(X)
  681.     CALL    RLS##
  682. ;  return FALSE;
  683.     JP    RETF
  684. ;  }
  685.  
  686. ; ====================  READLIST  ====================
  687. ;_readl(rest,ast,ls,pbst)
  688. ;  PAIR rest;
  689. ;  ALPHASTATE * ast;
  690. ;  LSUBST ls;
  691. ;  BETASTATE ** pbst;
  692. ;  {
  693. ;  PAIR x;
  694. ;
  695. _READL::
  696.     LD    (REST),HL
  697.     LD    (LS),DE
  698. ;  noretry(ast);
  699.     CALL    NORE
  700. ;  opar = 0;
  701.     XOR    A
  702.     LD    (OPAR##),A
  703. ;  x = makepair(rdg1(),empty);
  704.     CALL    RDG1##
  705.     JR    READX
  706.  
  707. ; ====================  SAVE  ====================
  708. ; SAVE command
  709. ;
  710. ; saves database to named file
  711. ; default filetype 'PRO'
  712. _SAVE::
  713.     PUSH    HL
  714.     PUSH    DE
  715.     CALL    NORE
  716.     CALL    CLOSE##        ; close existing output file
  717.     POP    DE
  718.     POP    HL
  719.     CALL    DOOUT##
  720.     LD    A,(OUTFCB##+9)
  721.     CP    ' '        ; no filetype?
  722.     JR    NZ,SAVE1
  723.     LD    HL,APRO##    ; use default 'PRO'
  724.     ?COPY    OUTFCB##+9
  725. SAVE1:    CALL    SAVEX        ; create the file for output
  726.     CALL    LISTX        ; send listing to file
  727.     JP    CLOSEX        ; close file
  728. SAVEX:
  729.     LD    A,(OUTF##)
  730.     DEC    A
  731.     RET    NZ        ; not disk file
  732.     LD    DE,OUTFCB##
  733.     LD    C,19        ; delete file
  734.     CALL    BDOS
  735.     LD    DE,OUTFCB##
  736.     LD    C,22        ; make file
  737.     CALL    BDOS
  738.     INC    A
  739.     JP    Z,RETF        ; unsuccessful
  740.     LD    HL,OUTDMA##
  741.     LD    (OUTP##),HL
  742.     RET
  743.  
  744. ; ====================  WRITE  ====================
  745. ;_write(rest,ast,ls,pbst)
  746. ;  PAIR rest;
  747. ;  ALPHASTATE * ast;
  748. ;  LSUBST ls;
  749. ;  BETASTATE ** pbst;
  750. ;  {
  751. ;  static SUBVAL sv;
  752. _WRITE::
  753.     LD    (REST),HL
  754.     LD    (LS),DE
  755. ;  noretry(ast);
  756.     CALL    NORE
  757. ;  if (varp(rest))
  758.     LD    HL,(REST)
  759.     CALL    VARP##
  760.     JR    Z,WR1
  761. ;    {
  762. ;    if (substp(sv.val = value(vf(rest,ls))))
  763. ;      ;
  764.     LD    DE,(LS)
  765.     CALL    VF##
  766.     CALL    VALUE##
  767.     LD    (SV),HL
  768.     CALL    SUBSTP##
  769.     JR    NZ,WR1
  770. ;    else
  771. ;      {
  772. ;      rest = sv.assgn->sexp.list;
  773.     CALL    @EXPR##
  774.     LD    (REST),HL
  775. ;      ls = sv.assgn->slist;
  776.     LD    HL,(SV)
  777.     CALL    @SLIST##
  778.     LD    (LS),HL
  779. ;      }
  780. ;    }
  781. WR1:
  782. ;  while (nelistp(rest))
  783.     LD    HL,(REST)
  784.     CALL    NELP##
  785.     JR    Z,WR2
  786. ;    {
  787. ;    eprint(rest->left.list,ls);
  788.     CALL    @LEFT
  789.     LD    DE,(LS)
  790.     CALL    EPRINT##
  791. ;    rest = rest->right.list;
  792.     LD    HL,(REST)
  793.     CALL    @RIGHT##
  794.     LD    (REST),HL
  795. ;    if (varp(rest))
  796.     CALL    VARP##
  797.     JR    Z,WR3
  798. ;      {
  799. ;      if (substp(sv.val = value(vf(rest,ls))))
  800. ;        ;
  801.     LD    DE,(LS)
  802.     CALL    VF##
  803.     CALL    VALUE##
  804.     LD    (SV),HL
  805.     CALL    SUBSTP##
  806.     JR    NZ,WR3
  807. ;      else
  808. ;        {
  809. ;        rest = sv.assgn->sexp.list;
  810.     CALL    @EXPR##
  811.     LD    (REST),HL
  812. ;        ls = sv.assgn->slist;
  813.     LD    HL,(SV)
  814.     CALL    @SLIST##
  815.     LD    (LS),HL
  816. ;        }
  817. ;      }
  818. WR3    EQU    WR1
  819.     JR    WR1
  820. ;    }
  821. WR2:
  822. ;  return TRUE;
  823.     JP    RETT
  824. ;  }
  825.  
  826. ; ====================  WRITECHAR  ====================
  827. ;_wrch(rest,ast,ls,pbst)
  828. ;  PAIR rest;
  829. ;  ALPHASTATE * ast;
  830. ;  LSUBST ls;
  831. ;  BETASTATE ** pbst;
  832. ;  {
  833. ;  NUMBER x;
  834. _WRCH::
  835.     LD    (REST),HL
  836.     LD    (LS),DE
  837. ;  noretry(ast);
  838.     CALL    NORE
  839. ;  x = vnext(&rest,&ls);
  840.     LD    HL,REST
  841.     LD    DE,LS
  842.     CALL    VNEXT
  843. ;  if (! numbp(x))
  844. ;    return FALSE;
  845.     CALL    NUMBP##
  846.     JP    Z,RETF
  847. ;  if (x > 255)
  848. ;    return FALSE;
  849.     LD    DE,256
  850.     CALL    CPHL##
  851.     JP    NC,RETF
  852. ;  putc(x,outfile);
  853.     LD    A,L
  854.     CALL    CHROUT##
  855. ;  return TRUE;
  856.     JP    RETT
  857. ;  }
  858.  
  859.     END
  860.